1/* BEGIN LICENSE BLOCK 2 * Version: CMPL 1.1 3 * 4 * The contents of this file are subject to the Cisco-style Mozilla Public 5 * License Version 1.1 (the "License"); you may not use this file except 6 * in compliance with the License. You may obtain a copy of the License 7 * at www.eclipse-clp.org/license. 8 * 9 * Software distributed under the License is distributed on an "AS IS" 10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11 * the License for the specific language governing rights and limitations 12 * under the License. 13 * 14 * The Original Code is The ECLiPSe Constraint Logic Programming System. 15 * The Initial Developer of the Original Code is Cisco Systems, Inc. 16 * Portions created by the Initial Developer are 17 * Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 18 * 19 * Contributor(s): 20 * 21 * END LICENSE BLOCK */ 22 23/* 24 * SEPIA SOURCE FILE 25 * 26 * VERSION $Id: emu.c,v 1.32 2015/01/14 01:31:09 jschimpf Exp $ 27 */ 28 29/* 30 * IDENTIFICATION emu.c 31 * 32 * DESCRIPTION the C emulator for SEPIA's abstract machine 33 * 34 * CONTENTS: emulc() 35 * 36 */ 37 38 /* 39 * INCLUDES: 40 */ 41 42#define IN_C_EMULATOR /* before includes ! */ 43#undef USE_LAST_FLAG 44 45#include "config.h" 46#include "sepia.h" 47#undef SP 48#undef TT 49#undef TG 50#undef E 51#undef EB 52#undef GB 53#undef S 54#undef B 55#undef PP 56 57#ifdef __GNUC__ 58#define _GNU_SOURCE /* to get REG_R13 from ucontext.h */ 59#endif 60 61#if defined(_WIN32) && defined(__GNUC__) 62/* work around gcc bug */ 63#undef TagTypeC 64#define TagTypeC(item_tag) ((int8) ((item_tag)&0xff)) 65#endif 66 67#include "types.h" 68#include "error.h" 69#include "mem.h" 70#include "dict.h" 71#include "ec_io.h" 72#include "emu_export.h" 73#include "embed.h" 74 75#include "opcode.h" 76#include "database.h" 77#include "module.h" 78#include "debug.h" 79#include "property.h" 80 81#if defined(PROFILE) && !defined(__GNUC__) 82/* on sunos5, gcc inserts funny marking labels that confuse the assembler */ 83#undef MARK 84#define MARK 85#include <prof.h> 86#define Mark_Prof(x) MARK(x) 87#else 88#define Mark_Prof(x) 89#endif 90 91/* 92 * There are three variants of the emulator: 93 * !THREADED uses switch() 94 * THREADED && POSTPRO postprocess the assembler output to turn 95 * the emulator into a threaded code one 96 * THREADED && __GNUC__ use gnu's && operator and computed gotos 97 * to make a threaded code emulator 98 */ 99 100#if defined(THREADED) && defined(__GNUC__) 101 102#define Next_Pp goto *PP++->emu_addr; 103#define Case(Opcode, Oplab) case Opcode: Oplab: Mark_Prof(Opcode) 104 105#else /* !THREADED || (THREADED && POSTPRO) */ 106 107#define Next_Pp goto _loop_ 108#define Case(Opcode, Oplab) case Opcode: Mark_Prof(Opcode) 109 110#endif 111 112#define E_Case(Opcode, Oplab) case Opcode: Mark_Prof(Opcode) 113 114 115/* 116 * LOCAL TYPES: the abstract machine code as seen from the emulator 117 */ 118 119typedef union s_code_item { 120 vmcode inst; 121 word offset; 122 pword *arg; 123 pword *ptr; 124 word nint; 125 char *str; 126 float real; 127 dident did; 128 value val; 129 uword all; /* as for value */ 130 word kernel; /* for tags */ 131 pri *proc_entry; 132 int (*func)(); 133 union s_code_item *code; 134#if defined(__GNUC__) && defined(THREADED) 135 void *emu_addr; 136#endif 137} code_item; 138 139typedef code_item *emu_code; 140 141 142/*---------------------------------------------------------------------- 143 * Mapping of abstract machine registers to C variables 144 * This is important for performance! 145 *----------------------------------------------------------------------*/ 146/* 147 * The PP register: we are using tricks to be able to access 148 * it from within sigprof_handler() via Int_Pp 149 */ 150#ifdef __GNUC__ 151# ifdef i386 152#define Declare_Pp register emu_code pp asm("%esi"); 153#define Restore_Pp 154#define Import_Pp pp = (emu_code) g_emu_.pp; 155#ifdef HAVE_UCONTEXTGREGS 156#define Int_Pp (((ucontext_t*) context)->uc_mcontext.gregs[REG_ESI]) 157#else 158#define Int_Pp 0 159#endif 160# else 161# ifdef __x86_64 162#define Declare_Pp register emu_code pp asm("%r13"); 163#define Restore_Pp 164#define Import_Pp pp = (emu_code) g_emu_.pp; 165#ifdef HAVE_UCONTEXTGREGS 166#define Int_Pp (((ucontext_t*) context)->uc_mcontext.gregs[REG_R13]) 167#else 168#define Int_Pp 0 169#endif 170# else 171# if defined(sparc) 172/* Register choice for Sparc: 173 * Refer to developers.sum.com/solaris/articles/sparcv9abi.html 174 * Also the -mapp-regs gcc options is relevant for g2-4 175 * Experimentaly, this is (as of 2011) the only choice that works out of g1-5 176 * but of dubiouos reliability, as any callee could presumably clobber 177 * the register 178 */ 179register emu_code pp asm("%g4"); 180#define Declare_Pp 181#define Restore_Pp pp = (emu_code) g_emu_.pp; 182#define Import_Pp 183#define Int_Pp pp 184# else 185# ifdef __alpha__ 186register emu_code pp asm("$12"); 187#define Declare_Pp 188#define Restore_Pp pp = (emu_code) g_emu_.pp; 189#define Import_Pp 190#define Int_Pp pp 191# else 192#define Declare_Pp register emu_code pp; 193#define Restore_Pp 194#define Import_Pp pp = (emu_code) g_emu_.pp; 195#define Int_Pp 0 196# endif 197# endif 198# endif 199# endif 200#else 201#define Declare_Pp register emu_code pp; 202#define Restore_Pp 203#define Import_Pp pp = (emu_code) g_emu_.pp; 204#define Int_Pp 0 205#endif 206 207#define PP pp 208#define Export_Pp g_emu_.pp = (vmcode *) pp; 209 210#ifdef FEW_REGISTERS /* leave EB,GB,E,TG in the global structure */ 211 212#define Declare_Eb 213#define EB g_emu_.eb 214#define Declare_Gb 215#define GB g_emu_.gb 216#define Declare_E 217#define E g_emu_.e 218#define Declare_Tg 219#define TG g_emu_.tg 220 221#define Export_B_Sp_Tg_Tt g_emu_.sp = sp; \ 222 Export_Pp g_emu_.vm_flags |= EXPORTED; 223#define Export_B_Sp_Tg_Tt_Eb_Gb Export_B_Sp_Tg_Tt 224#define Import_Tg_Tt Import_None 225#define Import_B_Sp_Tg_Tt_Eb_Gb sp = g_emu_.sp; Import_Tg_Tt 226 227#else /* !FEW_REGISTERS: shadow EB,GB,E,TG in local variables */ 228 229#define Declare_Eb register pword *eb; 230#define EB eb 231#define Declare_Gb register pword *gb; 232#define GB gb 233#define Declare_E register pword *e; 234#define E e 235#define Declare_Tg register pword *tg; 236#define TG tg 237 238#define Export_B_Sp_Tg_Tt g_emu_.sp=sp; g_emu_.e=e; g_emu_.tg=tg;\ 239 Export_Pp g_emu_.vm_flags |= EXPORTED; 240#define Export_B_Sp_Tg_Tt_Eb_Gb g_emu_.eb=eb; g_emu_.gb=gb; Export_B_Sp_Tg_Tt 241#define Import_Tg_Tt tg=g_emu_.tg; Import_None 242#define Import_B_Sp_Tg_Tt_Eb_Gb eb=g_emu_.eb; gb=g_emu_.gb; sp=g_emu_.sp; e=g_emu_.e; Import_Tg_Tt 243 244#endif /* FEW_REGISTERS */ 245 246#define Declare_Sp register pword *sp; 247#define SP sp 248#define Declare_S register pword *s; 249#define S s 250#define TT g_emu_.tt 251#define B g_emu_.b 252 253#define Export_All Export_B_Sp_Tg_Tt_Eb_Gb 254#define Import_None Restore_Pp g_emu_.vm_flags &= ~EXPORTED; 255#define Import_All Import_Pp Import_B_Sp_Tg_Tt_Eb_Gb 256 257 258 /* 259 * EXTERNAL VARIABLE DECLARATIONS: 260 */ 261 262#if defined(PRINTAM) || defined(LASTPP) 263extern uword *vm_inst_ctr_; 264extern char *vm_inst_flag_; 265#endif /* PRINTAM */ 266 267#ifdef SAVEDSTATES 268extern int p_restore(); 269extern int p_save(); 270#endif 271 272extern void 273 ec_handle_async(void), 274 eng_msg_loop(), 275 get_job(), 276 sch_load_report(), 277 end_of_oracle(); 278 279extern vmcode *print_am(register vmcode *code, vmcode **label, int *res, int option); 280 281extern vmcode 282 *bip_error_code_, 283 *prolog_error_code_, 284 *do_exit_block_code_, 285 *fork_unify_code_, 286 *sync_it_code_, 287 *meta_exit_simple_code_, 288 *meta_last_exit_simple_code_, 289 *do_call_code_, 290 cut_to_code_[], 291 comma_body_code_[], 292 gc_fail_code_[], 293 semic_body_code_[], 294 cond_body_code_[], 295 cond3_body_code_[], 296 softcut5_body_code_[], 297 *auto_gc_code_, 298 fail_return_env_0_[], 299 restore_code_[], 300 restore_debug_code_[], 301 trace_exit_code_[], 302 return_code_[]; 303 304extern pri **default_error_handler_, 305 **interrupt_handler_, 306 **error_handler_; 307extern int *interrupt_handler_flags_; 308extern dident *interrupt_name_; 309 310 311 /* 312 * EXTERNAL VARIABLE DEFINITIONS: 313 */ 314 315 316 /* 317 * DEFINES: 318 */ 319 320#define Start_Countdown() \ 321 Disable_Int(); \ 322 EVENT_FLAGS |= COUNT_DOWN; \ 323 Enable_Int(); 324#define Stop_Countdown() \ 325 Disable_Int(); \ 326 EVENT_FLAGS &= ~COUNT_DOWN; \ 327 Enable_Int(); 328 329#define MODE_READ 0 330#define MODE_WRITE 1 331 332#if (defined(vax) || defined(CHIP) || defined(OBJECTS)) 333#define SPLIT_SWITCH 334/* The main emulator switch is split into two when there are extension */ 335/* instructions or when the C compiler can't handle big switches */ 336#endif 337 338#define ISVar(t) IsTag(t, TVAR_TAG) 339 340/* This macro creates a module that can be used to make a qualified 341 * call to the procedure proc in any module. If the original call was 342 * qualified, we can use the unmarked home module, if the original call 343 * used the visible procedure, we use the caller module (but it must be 344 * marked to enable :/2 to call a possibly local procedure). 345 */ 346#define Make_Lookup_Module(pw, proc) \ 347 if (PriScope(proc) == QUALI) { \ 348 Make_Atom(pw, PriHomeModule(proc)); \ 349 } else { \ 350 Make_Marked_Module(pw, PriModule(proc)); \ 351 } 352 353#define Make_Marked_Module(pw, mdid) \ 354 (pw)->val.did = mdid; \ 355 (pw)->tag.kernel = ModuleTag(mdid); 356 357/* 358 * CAUTION: redefinition of this macro should care about coming back 359 * in the main loop of the emulator 360 */ 361#define Fail goto _do_fail_; 362 363#define RetCodeAddr(e) ((pword *) ((pword **) e + 1)) 364#define ERetCode *((emu_code *) ((pword **) E + 1)) 365#define RetEnv(e) *((pword **) e) 366#define ERetEnv RetEnv(E) 367#define Pop_Ret_Code PP = *((emu_code *) SP);\ 368 SP = (pword *) (((emu_code *) SP) + 1); 369#define Read_Ret_Code PP = *((emu_code *) SP); 370#define Push_Ret_Code(x) SP = (pword *) (((emu_code *) SP) - 1);\ 371 *((emu_code *) SP) = (x); 372#define Push_Ret_Code_To_Eb(x) SP = (pword *) (((emu_code *) EB) - 1);\ 373 *((emu_code *) SP) = (x); 374#define Repush_Ret_Code SP = (pword *) (((emu_code *) SP) - 1);\ 375 *((emu_code *)SP) = *(((emu_code *)SP) + 1); 376#define Pop_Env SP = E;\ 377 E = *((pword **) SP);\ 378 SP = (pword *)(((pword **) SP) + 1); 379 380#define Push_Env SP = (pword *) (((pword **) SP) - 1);\ 381 *((pword **) SP) = E;\ 382 E = SP; 383 384/* 385#define Deterministic (VM_FLAGS & DET) 386#define Set_Det VM_FLAGS |= DET; 387#define Clr_Det VM_FLAGS &= ~DET; 388*/ 389#define Deterministic emu_flags 390#define Set_Det emu_flags = 1; 391#define Clr_Det emu_flags = 0; 392 393#ifdef lint 394 395#define ByteOffsetPlus(pw,off) ((pw) + (off)/sizeof(pword)) 396#define ByteOffsetMinus(pw,off) ((pw) - (off)/sizeof(pword)) 397 398#else /* !lint */ 399 400#define ByteOffsetPlus(pw,off) ((pword *) ((int8 *) (pw) + (off))) 401#define ByteOffsetMinus(pw,off) ((pword *) ((int8 *) (pw) - (off))) 402 403#endif /* lint */ 404 405#define Alloc_Env Push_Env\ 406 SP = ByteOffsetMinus(SP, PP++->offset);\ 407 Check_Local_Overflow 408 409/*#define Move_Pw(s,d) d->val.all=s->val.all; d->tag.all=s->tag.all;*/ 410#define Move_Pw(s,d) *d = *s; 411 412/* 413 * move an arbitrary prolog word to a location on the global stack. 414 * a local variable is globalized (like Write_local_value) 415 * the 'from' argument is modified, 416 * the 'to' argument is incremented 417 * The 'check' argument is here to make an occur check in Write_value 418 */ 419#define Move_Pw_To_Global_Stack(from, to, check)\ 420 Dereference_Pw(from) \ 421 if (IsRef((from)->tag) && IsLocal(from)) { \ 422 Trail_If_Needed_Eb(from); \ 423 from->val.ptr = to; \ 424 to->val.ptr = to; \ 425 (to++)->tag.kernel = TREF; \ 426 } else { \ 427 check \ 428 *(to++) = *from; \ 429 } 430 431#define Get_Local(p) p = ByteOffsetMinus(E, PP++->offset); 432 433#define Get_Temporary(p) p = ByteOffsetPlus(SP, PP++->offset); 434#define Get_Temporary_Offs(off, p) \ 435 p = ByteOffsetPlus(SP, (PP+(off))->offset); 436 437#define Get_Argument(d) d = (PP++->arg); 438 439#define Dereference_Pw_Tag(pw, t) \ 440 while(ISRef(((t) = (pw)->tag.kernel)) && pw->val.ptr != pw) {\ 441 pw = pw->val.ptr;\ 442 } 443 444#define Dereference_Pw(pw) \ 445 while(IsRef(pw->tag) && pw->val.ptr != pw) {\ 446 pw = pw->val.ptr;\ 447 } 448 449#define Set_Val(pw,v) pw->val.ptr = v; 450 451#define DELAY_SLOT 1 /* first extension */ 452#define DELAY_INST 1 453#define DELAY_BOUND 3 454 455/* bind a standard variable (*pw) to nonvariable v,t */ 456 457#define Bind_(pw,v,t) \ 458 Trail_If_Needed(pw)\ 459 pw->val.all = v;pw->tag.kernel = t; 460 461#define Bind_Tag(pw,t) Trail_If_Needed(pw) pw->tag.kernel = t; 462 463 464/* bind a nonstandard variable (*pw1) to nonvariable v,t */ 465 466#define Bind_CRef_pw1_Tag(t) \ 467 tmp1 = (t);\ 468 goto _bind_nonstandard_; 469 470#define Bind_CRef_pw1(v,t) \ 471 pw2 = (pword *)(v); tmp1 = (t); \ 472 goto _bind_nonstandard_; 473 474 475/* bind a standard or nonstandard variable (*pw1) to nonvariable v,t */ 476 477#define Bind_Ref_pw1(tvar,v,t) \ 478 if(ISVar(tvar)) { \ 479 Bind_(pw1,v,t) \ 480 } else { \ 481 Bind_CRef_pw1(v,t) \ 482 } 483 484#define Bind_Ref_pw1_Tag(tvar,t) \ 485 if(ISVar(tvar)) { \ 486 Bind_Tag(pw1,t) \ 487 } else { \ 488 Bind_CRef_pw1_Tag(t) \ 489 } 490 491/* The suffix is needed because float comparison is not bitwise comparison */ 492#define Unify_Simple_pw1(type,suffix,t)\ 493 Dereference_Pw_Tag(pw1,t)\ 494 if(ISVar(t)) {\ 495 Bind_(pw1,PP++->all,type) \ 496 } else if(!IsTag(t,type)) {\ 497 if(ISRef(t)) {\ 498 Bind_CRef_pw1(PP++->all,type)\ 499 } else { Fail }\ 500 } else if(pw1->val.suffix != PP++->suffix) {\ 501 Fail\ 502 } 503 504 505 506/* argument is a register variable that holds the value to cut to 507 * and which is destructively changed by this macro! 508 * Caution: During resetting of PPB we access data above B. This is 509 * only safe as long as async interrupts in the emulator are prevented. 510 */ 511#define Cut_To(Old_B_Reg) { \ 512 B.args = (Old_B_Reg); \ 513 (Old_B_Reg) = (Top(Old_B_Reg) - 1)->frame.args; \ 514 EB = Chp(Old_B_Reg)->sp; \ 515 GB = Chp(Old_B_Reg)->tg; \ 516 while (LCA >= GB) { \ 517 Export_B_Sp_Tg_Tt; \ 518 do_cut_action(); \ 519 Import_Tg_Tt; \ 520 } \ 521 Cut_To_Parallel(B.args); \ 522} 523 524#define Cut_Last(pw) { \ 525 B.args = pw = (B.top - 1)->frame.args; \ 526 pw = (Top(pw) - 1)->frame.args; \ 527 EB = Chp(pw)->sp; \ 528 GB = Chp(pw)->tg; \ 529} 530 531#ifdef PB_MAINTAINED 532#define Cut_To_Parallel(Old_B_Reg) { \ 533 if (Old_B_Reg < PB) { \ 534 Export_B_Sp_Tg_Tt; \ 535 if (cut_across_pb(Old_B_Reg)) { \ 536 Import_Tg_Tt; \ 537 } else { \ 538 Import_Tg_Tt; \ 539 Next_Pp; \ 540 } \ 541 } \ 542} 543#else /* PB_MAINTAINED */ 544#define Cut_To_Parallel(Old_B_Reg) { \ 545 if (Old_B_Reg < PPB) { \ 546 do \ 547 PPB = BPar(PPB)->ppb; \ 548 while (Old_B_Reg < PPB); \ 549 Export_B_Sp_Tg_Tt; \ 550 if (cut_public()) { \ 551 Import_Tg_Tt; \ 552 } else { \ 553 Import_Tg_Tt; \ 554 Next_Pp; \ 555 } \ 556 } \ 557} 558#endif /* PB_MAINTAINED */ 559 560 561#ifdef NEW_ORACLE 562 563#define DEBUG_ORACLE 564 565#define O_FROM_ORACLE 1 566#define O_NOCREATE 2 567 568/* 569#undef O_SHALLOW 570#define O_SHALLOW 0 571*/ 572 573#endif /* NEW_ORACLE */ 574 575 576/* PP points to 1st clause, back_code to 2nd alternative. 577 * They are updated according to laternative number n. 578 * For the last alternative, back_code is set to NULL. 579 */ 580 581#define Find_Alternative(n) { \ 582 int alt; word tmp2; \ 583 for (alt = (n)-1; alt; --alt) { \ 584 tmp2 = back_code->inst; \ 585 if (SameCode(tmp2, Retry_me_else)) { \ 586 PP = back_code + 3; \ 587 back_code = back_code[2].code; \ 588 } else if (SameCode(tmp2, Retry_me_inline)) { \ 589 PP = back_code + 4; \ 590 back_code = back_code[2].code; \ 591 } else if (SameCode(tmp2, Retry) || SameCode(tmp2,Retry_inline)) { \ 592 PP = back_code[2].code; \ 593 back_code = back_code + 3; \ 594 } else if (SameCode(tmp2, Trust) || SameCode(tmp2,Trust_inline)) { \ 595 PP = back_code[2].code; \ 596 back_code = (emu_code) 0; \ 597 break; \ 598 } else if (SameCode(tmp2, Trust_me)) { \ 599 PP = back_code + 2; \ 600 back_code = (emu_code) 0; \ 601 break; \ 602 } else if (SameCode(tmp2, Trust_me_inline) { \ 603 PP = back_code + 3; \ 604 back_code = (emu_code) 0; \ 605 break; \ 606 } else if (SameCode(tmp2, Retrylab)) { \ 607 PP = back_code[2].code; \ 608 back_code = back_code[3].code; \ 609 } else { \ 610 p_fprintf(current_err_, \ 611 "INTERNAL ERROR following oracle\n"); \ 612 } \ 613 } \ 614} 615 616/* on the PDL there are pointers (low bit 0) 617 * and encoded counters (<unifications left> * 2 + 1) 618 */ 619#define Pdl_Push_Pair(pw1, pw2) \ 620 SP = (pword *) (((pword **) SP) - 2);\ 621 *((pword **) SP) = pw1;\ 622 *(((pword **) SP) + 1) = pw2;\ 623 Check_Local_Overflow 624 625#define Pdl_Push_Frame(pw1, pw2, arity) \ 626 SP = (pword *) (((pword **) SP) - 3);\ 627 *((word *) SP) = ((arity) << 1) - 3;\ 628 *(((pword **) SP) + 1) = pw1;\ 629 *(((pword **) SP) + 2) = pw2;\ 630 Check_Local_Overflow 631 632/* get next pair of pointers from the (non-empty) PDL */ 633 634#define Pdl_Next(pw1, pw2, arity) \ 635 arity = *((word *) SP);\ 636 if (arity & 1) { /* a frame */ \ 637 pw1 = ((pword *) *(((pword **) SP) + 1)) + 1;\ 638 *(((pword **) SP) + 1) = pw1;\ 639 pw2 = ((pword *) *(((pword **) SP) + 2)) + 1;\ 640 *(((pword **) SP) + 2) = pw2;\ 641 if ((arity -= 2) > 1)\ 642 *((word *) SP) = arity;\ 643 else\ 644 SP = (pword *) (((pword **)SP) + 1);\ 645 } else { /* a pair */ \ 646 pw1 = ((pword *) arity) + 1;\ 647 pw2 = ((pword *) *(((pword **) SP) + 1)) + 1;\ 648 SP = (pword *) (((pword **)SP) + 2);\ 649 } 650 651/* Facility for stopping whenever TG crosses tg_trap */ 652#ifdef DEBUG_TRAP_TG 653pword *tg_trap = MAX_U_WORD; /* set this via dbx */ 654int tg_above_trap = 0; /* true while TG is above tg_trap */ 655#define Trap_Tg \ 656 if (tg_above_trap) { \ 657 if (TG <= tg_trap) { tg_above_trap = 0; emu_break(); } \ 658 } else { \ 659 if (TG > tg_trap) { tg_above_trap = 1; emu_break(); } \ 660 } 661#else 662#define Trap_Tg 663#endif 664 665/* brute force check of the whole global stack after every failure */ 666#ifdef DEBUG_CHECK_GLOBAL_STACK 667#define Debug_Check_Global Export_B_Sp_Tg_Tt check_global(); Import_None 668#else 669#define Debug_Check_Global 670#endif 671 672#if defined(PRINTAM) || defined(LASTPP) 673 674#define MAX_BACKTRACE 1024 675 676static vmcode *dummy_l = NULL; /* dummy arg for print_am() */ 677static int dummy_r; /* dummy arg for print_am() */ 678static emu_code stop_address = 0; /* for address breakpoints in the emulator */ 679vmcode *ec_backtrace[MAX_BACKTRACE]; /* record recent PP values */ 680int bt_index = 0; 681int bt_max = MAX_BACKTRACE; 682 683#define Begin_Execution(iptr) \ 684 if(VM_FLAGS & (TRACE | STATISTICS)) { \ 685 if(VM_FLAGS & STATISTICS) \ 686 vm_inst_ctr_[iptr->inst]++; \ 687 if(VM_FLAGS & TRACE) \ 688 (void) print_am((vmcode *) iptr, &dummy_l, &dummy_r, 2);\ 689 } \ 690 if (iptr == stop_address) {emu_break();} \ 691 ec_backtrace[bt_index] = (vmcode *) iptr; \ 692 bt_index = (bt_index + 1) % MAX_BACKTRACE; \ 693 Trap_Tg 694 695#else /* PRINTAM */ 696 697#define Begin_Execution(iptr) 698 699#endif /* PRINTAM */ 700 701 702/* 703 * stack overflow handling 704 */ 705 706#define Check_Local_Overflow \ 707 if (SP <= g_emu_.sp_limit) { \ 708 Export_B_Sp_Tg_Tt \ 709 if (local_ov()) goto _local_control_overflow_; \ 710 Import_None \ 711 } 712 713#define Check_Control_Overflow \ 714 if (B.args >= g_emu_.b_limit) { \ 715 Export_B_Sp_Tg_Tt \ 716 if (control_ov()) goto _local_control_overflow_; \ 717 Import_None \ 718 } 719 720#ifdef WIPE_FREE_GLOBAL 721#define Wipe(From, To) { pword *_p; \ 722 for(_p=(From);_p<(To);++_p) {_p->val.ptr=0; _p->tag.kernel=TEND;} } 723#else 724#define Wipe(From, To) 725#endif 726 727 728/* These macros can only be used at the end of the abstract instruction */ 729#define Handle_Events_Call if (EventPending) goto _handle_events_at_call_; 730#define Handle_Events_Return if (EventPending) goto _handle_events_at_return_; 731 732#define Reset_Unify_Exceptions MU = (pword *) 0; 733 734 735/* 736 * Interrupts while inside the emulator 737 * 738 * Interrupts inside the emulator are problematic because the abstract machine 739 * stack pointers may be in shadow registers of the emulator (indicated by 740 * the EXPORTED bit being reset). Recursive emulators can therefore not be 741 * initialised properly. Therefore, when the EXPORTED bit is reset, 742 * signals cannot be handled asynchronously and have to be treated like. 743 * synchronous events. This is done by posting integers to the event queue 744 * and setting the EVENT_POSTED bit in the EVENT_FLAGS register. 745 * 746 * The emulator is responsible for checking the EVENT_FLAGS condition 747 * bit regularly and calling handlers when it is set. 748 * When EXPORTED is set (i.e. the stack pointers are in the global variables), 749 * asynchronous interrupt handlers are called directly by _break() 750 * or delayed_break(). 751 * 752 * Optimisation: To avoid an extra check of EVENT_FLAGS, a global stack 753 * overflow is simulated as well (by setting TG_SL to 0). 754 * The event handling routine then checks if we had a true 755 * overflow or a faked one, and takes the appropriate action. 756 * While TG_SL may have a false value, its true one is always in TG_SLS 757 * We have to be careful not to lose this faked overflow, e.g. by resetting 758 * TG_SL from a control frame. Use the appropriate macros! 759 * 760 * When the control flow leaves the emulator (e.g. by calling some C function), 761 * the shadow registers have to be exported using an appropriate 762 * Export_... macro. If the function is allowed to modify the abstract 763 * machine registers, they also must be imported after returning. 764 */ 765 766 767/* 768 * FUNCTION NAME: emulc() 769 * 770 * PARAMETERS: m the abstract machine descriptor 771 * (currently still in g_emu_) 772 */ 773 774 775func_ptr 776ec_emulate(void) /* (struct machine *m) */ 777{ 778 Declare_Pp 779 Declare_Sp 780 Declare_S 781 register pword *pw1; 782 Declare_Tg 783 Declare_E 784 Declare_Eb 785 Declare_Gb 786 pword *pw2; 787 pword *pw3; 788 register int emu_flags; 789 register uword i; /* unsigned ! */ 790 register word tmp1; /* signed ! */ 791 control_ptr b_aux; 792 dident val_did; 793 int err_code; 794 pword scratch_pw; /* scratch space to have a pointer to a pword */ 795 pword *pdl; 796 pri *proc, *procb; 797 emu_code back_code; 798 double dbl_res; 799 800#ifdef lint 801 scratch_pw.tag.kernel = TNIL; 802 proc = (pri *) 0; 803 err_code = 0; 804#endif 805 806#if defined(__GNUC__) && defined(THREADED) 807 if (!op_addr[0]) 808 { 809 i = 0; 810#include "emu_op_addr.h" 811 A[0].val.nint = PSUCCEED; 812 return (func_ptr) 0; 813 } 814#endif 815 816 Import_All; /* B Sp Tg Tt EB Gb E PP */ 817 818/* 819 * initialize emulator auxiliaries 820 */ 821 Set_Det; /* should be imported from global vmflags */ 822 823 Check_Control_Overflow /* for the invocation frame */ 824 Next_Pp; 825 826 827/******************************************************************* 828 * Error in a regular goal: Construct the culprit goal structure 829 * from the argument registers. 830 *******************************************************************/ 831 832_recomp_err_: 833 err_code = RECOMP_FAILED; 834#ifdef PRINTAM 835 emu_break(); 836#endif 837 FO = (char *) 0; 838 val_did = d_.emulate; 839 /* goto _regular_err_; */ 840 841_regular_err_: /* (err_code, val_did), args in arg regs */ 842 tmp1 = DidArity(val_did); 843 if (tmp1 == 0) { 844 Make_Atom(&A[2], val_did); 845 } else { 846 S = TG; /* build goal structure */ 847 TG += tmp1 + 1; 848 S->val.did = val_did; 849 (S++)->tag.kernel = TDICT; 850 pw1 = &A[1]; 851 for(i = 0; i < tmp1; i++) { 852 pw2 = pw1++; 853 Move_Pw_To_Global_Stack(pw2,S, ;) 854 } 855 Make_Struct(&A[2], TG - tmp1 - 1); 856 } 857 pw1 = TG++; 858 Check_Gc 859 Make_Var(pw1); 860 Make_Ref(&A[3], pw1); 861 /* The culprit is known to be a kernel predicate, e.g. 862 * block/3, exit_block/1, or emulate/0. 863 * Lookup module can therefore be sepia_kernel. 864 */ 865 Make_Atom(&A[4], d_.kernel_sepia); 866 867_regular_err_2_: /* (err_code), goal A2, context module A3, lookup module A4 */ 868 Make_Integer(&A[1], -err_code); 869 Push_Ret_Code(PP) 870 Check_Local_Overflow 871 PP = (emu_code) prolog_error_code_; 872 Next_Pp; 873 874 875/****************************************************************** 876 * The diff routine is used to implement the builtins 877 * 878 * ==/2 \==/2 ~=/2 \==/3 879 * not unifiable fail succeed succeed succeed with [] 880 * identical succeed fail fail fail 881 * uncertain succeed succeed delay succeed with list 882 * 883 * It works on the terms whose addresses are held by pw1 and pw2, 884 * In addition, ~=/2 expects PP to point behind a BI_Inequality, 885 * and \==/3 expects PP to point to the last word of a BI_NotIdentList. 886 * The value matching instructions are handled like ==/2.. 887 ******************************************************************/ 888 889#define IsIdenticalProc(proc) (proc == identical_proc_) 890#define IsNotIdenticalProc(proc) (proc == not_identical_proc_) 891#define IsInequalityProc(proc) (proc == inequality_proc_) 892#define IsNotIdentListProc(proc) (proc == not_ident_list_proc_) 893 894_diff_: /* (pw1, pw2, [PP,] proc) */ 895 Mark_Prof(_diff_) 896 pdl = SP; 897_do_diff_: 898 Dereference_Pw_Tag(pw1,tmp1) /* dereference the two objects */ 899 Dereference_Pw(pw2) 900 if(pw1 == pw2) goto _diff_cont_; /* takes care of identical */ 901 /* normal variable */ 902 if (IsTag(tmp1, TUNIV)) 903 { 904 Trail_Tag(pw1) 905 pw1->tag.kernel = TREF; 906 pw1->val.ptr = pw2; 907 goto _diff_cont_; 908 } 909 else if (IsTag(pw2->tag.kernel, TUNIV)) 910 { 911 Trail_Tag(pw2) 912 pw2->tag.kernel = TREF; 913 pw2->val.ptr = pw1; 914 goto _diff_cont_; 915 }; 916 917 if (ISRef(tmp1)) 918 { /* the first is a normal or cdt variable */ 919 if(IsRef(pw2->tag)) 920 { /* the second as well */ 921 if (pw1->val.ptr == pw2->val.ptr) 922 { 923 goto _diff_cont_; /* identical cdt var */ 924 } 925 /* else variables not identical */ 926 if (IsIdenticalProc(proc)) 927 { SP = pdl; Fail; } 928 if (IsNotIdenticalProc(proc)) 929 { SP = pdl; Next_Pp; } 930 Push_var_delay_unif(pw2->val.ptr, pw2->tag.kernel); 931 Push_var_delay_unif(pw1->val.ptr,pw1->tag.kernel); 932 goto _diff_delay_; 933 } 934 if (IsIdenticalProc(proc)) 935 { SP = pdl; Fail; } 936 if (IsNotIdenticalProc(proc)) 937 { SP = pdl; Next_Pp; } 938 Push_var_delay(pw1->val.ptr,pw1->tag.kernel); 939 goto _diff_delay_; 940 } 941 else if (IsRef(pw2->tag)) 942 { /* only the 2nd is a variable*/ 943 if (IsIdenticalProc(proc)) 944 { SP = pdl; Fail; } 945 if (IsNotIdenticalProc(proc)) 946 { SP = pdl; Next_Pp; } 947 Push_var_delay(pw2->val.ptr,pw2->tag.kernel); 948 goto _diff_delay_; 949 } 950 else if (TagTypeC(tmp1) != TagType(pw2->tag)) 951 { 952 goto _diff_different_; /* tags differ */ 953 } 954 else if (ISSimple(tmp1)) /* both are simple */ 955 { 956 if (SimpleEq(tmp1, pw1->val, pw2->val)) 957 goto _diff_cont_; 958 else 959 goto _diff_different_; 960 } 961 else 962 { 963 pw1 = pw1->val.ptr; 964 pw2 = pw2->val.ptr; 965 if (pw1 == pw2) goto _diff_cont_; /* pointers identical */ 966 967 if (TagTypeC(tmp1) > TCOMP) /* strings, bignums, etc */ 968 { 969 if (IsTag(tmp1,TSTRG)) /* strings */ 970 { 971 Compare_Strings(pw1, pw2, err_code); 972 if (err_code >= 0) /* they are not the same strings */ 973 goto _diff_different_; 974 else 975 goto _diff_cont_; 976 } 977 Export_B_Sp_Tg_Tt 978 err_code = tag_desc[TagTypeC(tmp1)].equal(pw1, pw2); 979 Import_None 980 if (err_code) goto _diff_cont_; 981 else goto _diff_different_; 982 } 983 else /* the compound terms */ 984 { 985 Poll_Interrupts(); /* because we might be looping */ 986 987 if (IsTag(tmp1,TLIST)) /* lists */ 988 { 989_diff_list_: 990 Pdl_Push_Pair(pw1, pw2); 991 goto _do_diff_; 992 } 993 else /* if (IsTag(tmp1,TCOMP)) */ 994 { 995 if (pw1->val.did != (pw2++)->val.did) 996 { /* different functors */ 997 /* (arity check implicit) */ 998 goto _diff_different_; 999 } 1000 1001 tmp1 = DidArity((pw1++)->val.did); /* their arity */ 1002 /* at this point, pw1 and pw2 point to the first subterm */ 1003 switch(tmp1) 1004 { 1005 case 0: goto _diff_cont_; /* null arity: they unify */ 1006 case 1: goto _do_diff_; /* arity 1: directly unify subterms*/ 1007 case 2: goto _diff_list_; /* 2: we do not push the integer on */ 1008 /* the pdl */ 1009 default: 1010 Pdl_Push_Frame(pw1, pw2, tmp1); 1011 goto _do_diff_; 1012 } 1013 } 1014 } 1015 } 1016 1017_diff_cont_: /* the terms are equal (so far) */ 1018 if(pdl > SP) { 1019 Pdl_Next(pw1, pw2, tmp1); 1020 goto _do_diff_; /* continue */ 1021 } 1022 if (!IsIdenticalProc(proc)) 1023 Fail 1024 Next_Pp; 1025_diff_different_: /* the terms are different */ 1026 SP = pdl; /* remove PDL */ 1027 if (IsIdenticalProc(proc)) 1028 Fail 1029 else if (IsNotIdentListProc(proc)) 1030 { 1031 Get_Argument(pw1) /* unify last argument with [] */ 1032 Dereference_Pw(pw1) 1033 if (IsVar(pw1->tag)) 1034 { 1035 Trail_If_Needed(pw1) 1036 pw1->tag.kernel = TNIL; 1037 Next_Pp; 1038 } 1039 scratch_pw.tag.kernel = TNIL; 1040 pw2 = &scratch_pw; 1041 goto _unify_; /* (pw1, pw2) */ 1042 } 1043 Kill_DE; /* this is for BI_Inequality only! */ 1044 Next_Pp; 1045_diff_delay_: /* (SV, proc, PP points behind args) */ 1046 SP = pdl; /* remove PDL and delay */ 1047 if (IsInequalityProc(proc)) 1048 { 1049 if (!DE) /* make a suspension structure */ 1050 { 1051 val_did = PriDid(proc); 1052 DE = pw1 = TG; 1053 TG += SUSP_SIZE; 1054 Init_Susp_Header(pw1, proc); 1055 Init_Susp_State(pw1, PriPriority(proc), PriRunPriority(proc)); 1056 Make_Struct(&pw1[SUSP_GOAL], TG); /* goal */ 1057 Make_Atom(&pw1[SUSP_MODULE], PriModule(proc)); 1058 Make_Atom(TG, val_did); 1059 S = TG+1; 1060 TG += 3; 1061 pw1 = PP[-2].ptr; 1062 Move_Pw_To_Global_Stack(pw1, S, ;); 1063 pw1 = PP[-1].ptr; 1064 Move_Pw_To_Global_Stack(pw1, S, ;); 1065 Check_Gc 1066 } 1067 err_code = PDELAY | PDELAY_BOUND; 1068 goto _ndelay_de_sv_; /* (proc, de, sv, args?) */ 1069 } 1070 else /* IsNotIdentListProc(proc) */ 1071 { 1072 Get_Argument(pw1) /* unify last argument with SV list */ 1073 Dereference_Pw(pw1) 1074 if (IsVar(pw1->tag)) 1075 { 1076 Trail_If_Needed(pw1) 1077 pw1->val.ptr = SV; 1078 pw1->tag.kernel = TLIST; 1079 SV = (pword *) 0; 1080 Next_Pp; 1081 } 1082 scratch_pw.val.ptr = SV; 1083 scratch_pw.tag.kernel = TLIST; 1084 SV = (pword *) 0; 1085 pw2 = &scratch_pw; 1086 goto _unify_; /* (pw1, pw2) */ 1087 } 1088 1089 1090/****************************************************************** 1091 * Unification coded in the emulator and using the local stack to handle 1092 * recursion. It either fails or succeeds, but in both cases it resumes 1093 * the loop of the emulator. 1094 * It unifies the prolog words whose addresses are held by pw1 and pw2. 1095 ******************************************************************/ 1096 1097_unify_: 1098 Mark_Prof(_unify_) 1099 pdl = SP; 1100_do_unify_: 1101 Dereference_Pw_Tag(pw1,tmp1) /* dereference the two objects */ 1102 Dereference_Pw(pw2) 1103 if(ISVar(tmp1)) { /* the first is a free variable */ 1104 if(IsVar(pw2->tag)) { /* the second as well */ 1105 if (pw1 < pw2) 1106 if (pw1 < TG) 1107 { 1108 Trail_If_Needed(pw2); 1109 pw2->val.ptr = pw1; 1110 } 1111 else 1112 { 1113 Trail_If_Needed_Eb(pw1); 1114 pw1->val.ptr = pw2; 1115 } 1116 else if (pw1 > pw2) 1117 if (pw2 < TG) 1118 { 1119 Trail_If_Needed(pw1); 1120 pw1->val.ptr = pw2; 1121 } 1122 else 1123 { 1124 Trail_If_Needed_Eb(pw2); 1125 pw2->val.ptr = pw1; 1126 } 1127 else goto _unify_ok_; /* identical variables */ 1128 } else { /* only the 1st is free */ 1129 if (IsRef(pw2->tag)) { 1130 Trail_If_Needed(pw1); 1131 pw1->val.ptr = pw2->val.ptr; 1132 } else { 1133 Occur_Check_Read(pw1, pw2->val, pw2->tag, goto _unify_fail_) 1134 Bind_(pw1, pw2->val.all, pw2->tag.kernel) /* bind it */ 1135 } 1136 } 1137 goto _unify_ok_; 1138 } else if (IsVar(pw2->tag)) { /* only the 2nd is free */ 1139 if (ISRef(tmp1)) { 1140 Trail_If_Needed(pw2); 1141 pw2->val.ptr = pw1->val.ptr; 1142 } else { 1143 Occur_Check_Read(pw2, pw1->val, pw1->tag, goto _unify_fail_) 1144 Bind_(pw2, pw1->val.all, tmp1) /* bind it */ 1145 } 1146 } else if (ISRef(tmp1)) { 1147 pw1 = pw1->val.ptr; /* temporary, because of BIUnify */ 1148 if (IsRef(pw2->tag)) /* CRef = CRef */ 1149 { 1150 pw2 = pw2->val.ptr; /* temporary */ 1151 if (pw1 == pw2) goto _unify_ok_; /* identical */ 1152 /* call bind_c() */ 1153 } 1154 else /* CRef = Nonvar */ 1155 { 1156_unify_bind_cref_nvar_: /* (pw1, tmp1, pw2) */ 1157 Occur_Check_Read(pw1, pw2->val, pw2->tag, goto _unify_fail_) 1158 if (IsTag(tmp1, TNAME)) { 1159 Trail_Tag_If_Needed_Gb(pw1); 1160 *pw1 = *pw2; 1161 goto _unify_ok_; 1162 } else if (IsTag(tmp1, TMETA)) { 1163 Trail_Tag_If_Needed_Gb(pw1); 1164 *pw1 = *pw2; 1165 Update_MU(pw1) 1166 goto _unify_ok_; 1167 } 1168 /* else call bind_c() */ 1169 } 1170 Export_B_Sp_Tg_Tt_Eb_Gb 1171 if (bind_c(pw1, pw2, &MU) == PSUCCEED) { 1172 Import_Tg_Tt 1173 goto _unify_ok_; 1174 } else { 1175 Import_Tg_Tt 1176 goto _unify_fail_; 1177 } 1178 } else if (IsRef(pw2->tag)) { /* Nonvar = CRef */ 1179 tmp1 = pw2->val.nint; /* ->val temporary */ 1180 pw2 = pw1; 1181 pw1 = (pword *) tmp1; 1182 tmp1 = pw1->tag.kernel; 1183 goto _unify_bind_cref_nvar_; /* (pw1, tmp1, pw2) */ 1184 1185 } else if (TagTypeC(tmp1) != TagType(pw2->tag)) { 1186 goto _unify_fail_; /* different tags --> fail */ 1187 1188 } else if (ISSimple(tmp1)) { /* simple type? if yes ..*/ 1189 if (SimpleEq(tmp1, pw1->val, pw2->val)) 1190 goto _unify_ok_; /* nil or same values */ 1191 else 1192 goto _unify_fail_; 1193 } 1194 else 1195 { 1196 pw1 = pw1->val.ptr; /* get the pointers */ 1197 pw2 = pw2->val.ptr; 1198 if (pw1 == pw2) goto _unify_ok_; /* identical pointers */ 1199 1200 if (TagTypeC(tmp1) > TCOMP) /* string, bignum etc */ 1201 { 1202 if (IsTag(tmp1,TSTRG)) { 1203 Compare_Strings(pw1, pw2, err_code); 1204 if(err_code >= 0) /* they do not match */ 1205 goto _unify_fail_; 1206 else 1207 goto _unify_ok_; 1208 } 1209 Export_B_Sp_Tg_Tt 1210 err_code = tag_desc[TagTypeC(tmp1)].equal(pw1, pw2); 1211 Import_None 1212 if (err_code) goto _unify_ok_; 1213 else goto _unify_fail_; 1214 } 1215 else /* the compound terms */ 1216 { 1217 Poll_Interrupts(); /* because we might be looping */ 1218 if (IsTag(tmp1,TLIST)) { /* lists */ 1219_unify_list_: 1220 Pdl_Push_Pair(pw1, pw2); 1221 goto _do_unify_; /* but first, the heads */ 1222 1223 } else { /* if (IsTag(tmp1,TCOMP)) */ /* we have structures */ 1224 if (pw1->val.did != (pw2++)->val.did) 1225 goto _unify_fail_; /* different functors --> fail */ 1226 1227 tmp1 = DidArity((pw1++)->val.did); /* their arity */ 1228 /* at this point, pw1 and pw2 point to the first subterm */ 1229 switch(tmp1) { 1230 case 0: goto _unify_ok_; /* null arity: they unify */ 1231 case 1: goto _do_unify_; /* directly unify subterms */ 1232 case 2: goto _unify_list_; /* the same as a list */ 1233 default: 1234 Pdl_Push_Frame(pw1, pw2, tmp1); 1235 goto _do_unify_; 1236 } 1237 } 1238 } 1239 } 1240_unify_ok_: 1241 if (pdl <= SP) { 1242 Occur_Check_Boundary(0) 1243 Next_Pp; /* if PDL empty, unification succeeds */ 1244 } 1245 Pdl_Next(pw1, pw2, tmp1); /* else get next pair and unify */ 1246 goto _do_unify_; 1247 1248_unify_fail_: /* if the unification fails */ 1249 Occur_Check_Boundary(0) /* reset the occur check */ 1250 SP = pdl; /* remove the PDL */ 1251 Fail; /* and initiate backtracking */ 1252 1253 1254/* 1255 * Bind a nonstandard variable (*pw1) to the nonvariable term with tag tmp1 1256 * and value pw2, then fail or continue with the next instruction. 1257 * TMETA and TNAME are handled here for efficiency, the rest is given to bind_c() 1258 */ 1259 1260_bind_nonstandard_: /* *pw1 = (pw2,tmp1) */ 1261 Mark_Prof(_bind_nonstandard_) 1262 if (IsTag(pw1->tag.kernel, TNAME)) { 1263 Trail_Tag_If_Needed_Gb(pw1); 1264 pw1->val.ptr = pw2; 1265 pw1->tag.kernel = tmp1; 1266 } else if (IsTag(pw1->tag.kernel, TMETA)) { 1267 Trail_Tag_If_Needed_Gb(pw1); 1268 pw1->val.ptr = pw2; 1269 pw1->tag.kernel = tmp1; 1270 Update_MU(pw1) 1271 } else { 1272 scratch_pw.val.ptr = pw2; 1273 scratch_pw.tag.kernel = tmp1; 1274 Export_B_Sp_Tg_Tt_Eb_Gb 1275 err_code = bind_c(pw1, &scratch_pw, &MU); 1276 Import_Tg_Tt 1277 if (err_code == PFAIL) { Fail; } 1278 } 1279 Next_Pp; 1280 1281 1282 1283/***************************************************************** 1284 BIP Result management (new abstract machine instr version) 1285******************************************************************/ 1286 1287/* 1288 * Construct a goal structure for a builtin that is compiled into one 1289 * of the I_BI_Xxx instructions, e.g. bi_add(arg,arg,uninit_arg,mask). 1290 * We assume that PP points behind the instruction, i.e. behind mask. 1291 * Mask describes the preceding argument words, 2 bits for each argument: 1292 * 1293 * mask code contains 1294 * 0 pointer to argument register 1295 * 1 pointer to uninitialised argument register 1296 * 2 32-bit integer 1297 * 3 module did 1298 * ? possible extension: pri (for make_suspension/4) 1299 * 1300 * We assume that these predicates have arity>0 and are not tools. 1301 * We also assume no local stack variables (otherwise need to globalise). 1302 * CAUTION: this macro also materialises output variables for 1303 * "uninitialised output" arguments, and stores a ref to them in the 1304 * output register. This may clobber an input register, which is no 1305 * problem as long as they are always last and the input is copied first. 1306 */ 1307 1308#define Push_Bip_Goal(_did,_i,_mask) { \ 1309 (_i) = DidArity(_did)+1;\ 1310 TG->val.did = (_did);\ 1311 TG++->tag.kernel = TDICT;\ 1312 (_mask) = PP[-1].nint;\ 1313 do {\ 1314 switch((_mask) & 3) {\ 1315 case 0:\ 1316 *TG = *(PP[-(_i)].ptr);\ 1317 break;\ 1318 case 1:\ 1319 PP[-(_i)].ptr->val.ptr=TG; PP[-(_i)].ptr->tag.kernel=TREF;\ 1320 TG->val.ptr=TG; TG->tag.kernel=TREF;\ 1321 break;\ 1322 case 2:\ 1323 TG->val.nint = PP[-(_i)].nint; TG->tag.kernel=TINT;\ 1324 break;\ 1325 case 3:\ 1326 Make_Marked_Module(TG, PP[-(_i)].did);\ 1327 break;\ 1328 }\ 1329 ++TG; (_mask) >>= 2;\ 1330 } while (--(_i)>1);\ 1331} 1332 1333#define Push_Dummy_Results(_did,_i,_mask) { \ 1334 (_i) = DidArity(_did)+1;\ 1335 (_mask) = PP[-1].nint;\ 1336 while ((_mask) && (_i)>1) {\ 1337 switch((_mask) & 3) {\ 1338 case 1:\ 1339 PP[-(_i)].ptr->val.ptr=TG; PP[-(_i)].ptr->tag.kernel=TREF;\ 1340 TG->val.ptr=TG; TG++->tag.kernel=TREF;\ 1341 break;\ 1342 }\ 1343 (_mask) >>= 2; --(_i);\ 1344 }\ 1345} 1346 1347 1348_nbip_res_: /* (err_code,proc), args at *PP[-arity-1..-2] */ 1349 Mark_Prof(_nbip_res_) 1350 Occur_Check_Boundary(0) 1351 if (err_code == PSUCCEED) 1352 { 1353_nbip_succeed_: 1354 Reset_DE; /* demons are responsible to Kill_DE if appropriate */ 1355 Next_Pp; 1356_nbip_kill_succeed_: 1357 Kill_DE; 1358 Next_Pp; 1359 } 1360 else if (err_code == PFAIL) 1361 { 1362_nbip_fail_: 1363 Fail; 1364 } 1365 else if ((err_code & ~PDELAY_MASK) == PDELAY) 1366 { 1367 1368_npdelay_: /* (err_code, proc) */ 1369 if (!(GlobalFlags & CORTN)) 1370 { 1371 SV = (pword *) 0; 1372 err_code = INSTANTIATION_FAULT; 1373 goto _nbip_err_; 1374 } 1375_npdelay_always_: /* (err_code, proc) */ 1376 Mark_Prof(_npdelay_always_) 1377 val_did = PriDid(proc); 1378 if (!DE) /* make a suspension structure */ 1379 { 1380 DE = pw1 = TG; 1381 TG += SUSP_SIZE; 1382 Init_Susp_Header(pw1, proc); 1383 Init_Susp_State(pw1, PriPriority(proc), PriRunPriority(proc)); 1384 Make_Struct(&pw1[SUSP_GOAL], TG); /* goal */ 1385 Make_Atom(&pw1[SUSP_MODULE], PriModule(proc)); 1386 Push_Bip_Goal(val_did, i, tmp1) 1387 } 1388 else 1389 { 1390 /* When we redelay a builtin that uses uninitialised output convention, 1391 * we have to create a dummy result, which can be unified (without 1392 * any effect) with the caller's result argument by the subsequent 1393 * get_value instruction(s). 1394 */ 1395 Push_Dummy_Results(val_did, i, tmp1) 1396 } 1397 Check_Gc 1398 1399 /* 1400 * DE now points to the suspension 1401 * Link it to the suspending variables 1402 */ 1403 1404 if (err_code & PDELAY_MASK) /* delay on argument(s) 1-3 */ 1405 { 1406 Export_B_Sp_Tg_Tt_Eb_Gb 1407 tmp1 = DidArity(PriDid(proc)) + 1; 1408 if (err_code & (PDELAY_1 & PDELAY_MASK)) { 1409 pw1 = &DE[SUSP_GOAL].val.ptr[1]; 1410 Dereference_Pw(pw1) 1411 tmp1 = insert_suspension(pw1, 1, DE, DELAY_SLOT); 1412 if (tmp1 < 0) 1413 goto _ndelay_err_; 1414 } 1415 if (err_code & (PDELAY_2 & PDELAY_MASK)) { 1416 pw1 = &DE[SUSP_GOAL].val.ptr[2]; 1417 Dereference_Pw(pw1) 1418 tmp1 = insert_suspension(pw1, 1, DE, DELAY_SLOT); 1419 if (tmp1 < 0) 1420 goto _ndelay_err_; 1421 } 1422 if (err_code & (PDELAY_3 & PDELAY_MASK)) { 1423 pw1 = &DE[SUSP_GOAL].val.ptr[3]; 1424 Dereference_Pw(pw1) 1425 tmp1 = insert_suspension(pw1, 1, DE, DELAY_SLOT); 1426 if (tmp1 < 0) 1427 goto _ndelay_err_; 1428 } 1429 Import_Tg_Tt 1430 } 1431 else /* suspending_variables points to a list of */ 1432 { /* pointers to suspending variables */ 1433_ndelay_de_sv_: /* (proc,de,sv,args) */ 1434 pw2 = SV; 1435 Export_B_Sp_Tg_Tt_Eb_Gb 1436 while (pw2) 1437 { 1438 pw1 = pw2[0].val.ptr; 1439 Dereference_Pw(pw1) 1440 tmp1 = insert_suspension(pw1, 1441 err_code & PDELAY_BOUND ? DELAY_BOUND: DELAY_INST, 1442 DE, DELAY_SLOT); 1443 if (tmp1 < 0) { 1444_ndelay_err_: /* (tmp1,proc,DE) */ 1445 Import_Tg_Tt 1446 err_code = -tmp1; 1447 scratch_pw = DE[SUSP_GOAL]; 1448 Reset_DE; 1449 goto _nbip_err_goal_; 1450 } 1451 if (!IsList(pw2[1].tag)) 1452 break; 1453 pw2 = pw2[1].val.ptr; 1454 } 1455 Import_Tg_Tt 1456 SV = (pword *) 0; 1457 } 1458 if (Tracing && AnyPortWanted && !SuspDebugInvoc(DE)) 1459 { 1460 /* We don't currently have a way to trace re-delays */ 1461 Set_Susp_DebugInvoc(DE, NINVOC); 1462 ++NINVOC; 1463 /* only if the port is of interest, raise the debug event */ 1464 if (Tracing && PortWanted(DELAY_PORT) && OfInterest(PriFlags(((pri*)proc)), NINVOC-1, DLevel(TD)+1, 0)) { 1465 if (DBG_DELAY_INVOC == 0) { 1466 DBG_DELAY_INVOC = NINVOC-1; 1467 } 1468 err_code = -(DEBUG_SUSP_EVENT); 1469 scratch_pw = DE[SUSP_GOAL]; 1470 Reset_DE; 1471 goto _nbip_err_goal_; 1472 } 1473 } 1474 Reset_DE; 1475 Next_Pp; 1476 } 1477 else if (err_code == PTHROW) 1478 { 1479 Reset_DE; 1480 PP = (emu_code) do_exit_block_code_; /* Ball should be in A[1] */ 1481 Next_Pp; 1482 } 1483 else if (err_code > 0) 1484 { 1485 err_code = ILLEGAL_RETURN; 1486 } 1487 /* goto _nbip_err_; */ 1488 1489/******************************************************************* 1490 * Builtin returned an error code 1491 *******************************************************************/ 1492 1493_nbip_err_: /* (err_code, proc), args at *PP[-arity-1..-2] */ 1494 Mark_Prof(_nbip_err_) 1495 Kill_DE; 1496 err_code = -err_code; 1497 if (PriFlags(proc) & TOOL) 1498 { 1499 (void) ec_panic("Assertion Failed", "Emulator, nbip_error"); 1500 } 1501 1502 if (!(procb = error_handler_[err_code])) /* get the handler */ 1503 procb = error_handler_[0]; 1504 1505 if (procb->did == d_.true0 && procb->module_ref == d_.kernel_sepia) { 1506 Next_Pp; 1507 } 1508 else if (procb->did == d_.fail && procb->module_ref == d_.kernel_sepia) 1509 { 1510 Fail 1511 } 1512 else 1513 { 1514 1515 /* Build culprit goal (before saving argument registers!) */ 1516 val_did = PriDid(proc); 1517 if (DidArity(val_did) > 0) { 1518 Make_Struct(&scratch_pw, TG); 1519 Push_Bip_Goal(val_did, i, tmp1); 1520 } else { 1521 Make_Atom(&scratch_pw, val_did); 1522 } 1523 1524_nbip_err_goal_: /* (err_code, proc,scratch_pw) */ 1525 /* create an exception frame to be able to restore the machine 1526 * state partially on SUCCESSful return from error handler. 1527 * ( the handler call should behave like a builtin call, 1528 * i.e. being determinate, preserving arg regs and DET ) 1529 * If handler succeeds, restoring is done by Continue_after_exception. 1530 * If handler fails, Refail pops the frame and fails again. 1531 * MU is saved/restored and WP (priority) is set to 1 in order to 1532 * make the exception handler not interfere with waking. 1533 */ 1534 Push_Ret_Code(PP) 1535 pw1 = B.args; 1536 Exception(pw1)->sp = SP; 1537 Exception(pw1)->tg = TG; 1538 Exception(pw1)->tt = TT; 1539 Exception(pw1)->e = E; 1540 Exception(pw1)->ld = LD; 1541 Exception(pw1)->eb = EB; 1542 Exception(pw1)->gb = GB; 1543#define STRICT_EXCEPTION 1544#ifdef STRICT_EXCEPTION 1545 Exception(pw1)->mu = MU; 1546 MU = (pword *) 0; 1547 Exception(pw1)->wp = WP; 1548 Set_WP(1); /* depends on old value of GB! */ 1549#endif 1550 EB = SP; 1551 GB = TG; 1552 Push_Witness 1553 Check_Gc; 1554 Exception(pw1)->flags = emu_flags; 1555 Exception(pw1)->de = DE; 1556 Save_Tg_Soft_Lim(Exception(pw1)->tg_soft_lim); 1557 pw1 = (pword *) (Exception(pw1) + 1); 1558 pw2 = &A[1]; /* save arguments */ 1559 for(i = 1; i < NARGREGS; i++) { 1560 *pw1 = *pw2++; 1561 if((pw1++)->tag.kernel == TEND) 1562 break; 1563 } 1564 Top(pw1)->backtrack = exception_fail_code_; 1565 Top(pw1)->frame.exception = B.exception; 1566 B.top = Top(pw1) + 1; 1567 Check_Control_Overflow 1568 1569 /* Now call syserror(Err, Goal, ContextMod, LookupMod) */ 1570 Make_Integer(&A[1], err_code); /* error code */ 1571 A[2] = scratch_pw; /* culprit goal */ 1572 Make_Marked_Module(&A[3], PriModule(proc)); /* context module */ 1573 Make_Lookup_Module(&A[4], proc); /* lookup module */ 1574 A[5].tag.kernel = TEND; 1575 1576#ifdef SIMPLIFY 1577 Set_Det /* ? */ 1578 Push_Ret_Code(PP) 1579 Check_Local_Overflow; 1580 PP = (emu_code) PriCode(procb); 1581#else 1582 PP = (emu_code) bip_error_code_; 1583#endif 1584 Next_Pp; /* jump into syserror/4 */ 1585 } 1586 1587 1588 1589/*---------------------------------------------------------------------- 1590 * Externals with args in A[i] 1591 * Args are now dereferenced in A[i] 1592 * Apart from that, we are in a return state. 1593 * There may be events pending. 1594 * proc can't be a tool. 1595 *----------------------------------------------------------------------*/ 1596 1597_bip_res1_: /* (err_code,proc) */ 1598 Mark_Prof(_bip_res1_) 1599 Occur_Check_Boundary(0) 1600 if (err_code == PSUCCEED) 1601 { 1602 Reset_DE; /* demons are responsible to Kill_DE if appropriate */ 1603 Handle_Events_Return 1604 Next_Pp; 1605 } 1606 else if (err_code == PFAIL) 1607 { 1608 Fail; 1609 } 1610 else if ((err_code & ~PDELAY_MASK) == PDELAY) 1611 { 1612 if (!(GlobalFlags & CORTN)) 1613 { 1614 SV = (pword *) 0; 1615 err_code = INSTANTIATION_FAULT; 1616 goto _bip_err1_; 1617 } 1618 if (!DE) /* make a suspension structure */ 1619 { 1620 val_did = PriDid(proc); 1621 tmp1 = DidArity(val_did); 1622 DE = pw1 = TG; 1623 TG += SUSP_SIZE + 1 + tmp1; 1624 Init_Susp_Header(pw1, proc); 1625 Init_Susp_State(pw1, PriPriority(proc), PriRunPriority(proc)); 1626 pw1[SUSP_GOAL].val.ptr = pw1 + SUSP_SIZE; /* goal */ 1627 pw1[SUSP_GOAL].tag.kernel = TCOMP; 1628 pw1[SUSP_MODULE].tag.kernel = TDICT; 1629 pw1[SUSP_MODULE].val.did = PriModule(proc); 1630 1631 S = pw1 + SUSP_SIZE; /* build goal structure */ 1632 S->val.did = val_did; 1633 S++->tag.kernel = TDICT; 1634 for(i = 1; i <= tmp1; i++) 1635 { 1636 pw1 = &A[i]; 1637 Move_Pw_To_Global_Stack(pw1, S, ;) 1638 } 1639 Check_Gc 1640 } 1641 1642 /* 1643 * DE now points to the suspension 1644 * Link it to the suspending variables 1645 */ 1646 1647 if (err_code & PDELAY_MASK) /* delay on argument(s) 1-3 */ 1648 { 1649 Export_B_Sp_Tg_Tt_Eb_Gb 1650 if (err_code & (PDELAY_1 & PDELAY_MASK)) { 1651 pw1 = A[1].val.ptr; 1652 Dereference_Pw(pw1) 1653 tmp1 = insert_suspension(pw1, 1, DE, DELAY_SLOT); 1654 if (tmp1 < 0) { 1655 Import_Tg_Tt 1656 err_code = tmp1; 1657 goto _bip_err1_; 1658 } 1659 } 1660 if (err_code & (PDELAY_2 & PDELAY_MASK)) { 1661 pw1 = A[2].val.ptr; 1662 Dereference_Pw(pw1) 1663 tmp1 = insert_suspension(pw1, 1, DE, DELAY_SLOT); 1664 if (tmp1 < 0) { 1665 Import_Tg_Tt 1666 err_code = tmp1; 1667 goto _bip_err1_; 1668 } 1669 } 1670 if (err_code & (PDELAY_3 & PDELAY_MASK)) { 1671 pw1 = A[3].val.ptr; 1672 Dereference_Pw(pw1) 1673 tmp1 = insert_suspension(pw1, 1, DE, DELAY_SLOT); 1674 if (tmp1 < 0) { 1675 Import_Tg_Tt 1676 err_code = tmp1; 1677 goto _bip_err1_; 1678 } 1679 } 1680 Import_Tg_Tt 1681 } 1682 else /* suspending_variables points to a list of */ 1683 { /* pointers to suspending variables */ 1684 pw2 = SV; 1685 Export_B_Sp_Tg_Tt_Eb_Gb 1686 for (;;) 1687 { 1688 pw1 = pw2[0].val.ptr; 1689 Dereference_Pw(pw1) 1690 tmp1 = insert_suspension(pw1, 1691 err_code & PDELAY_BOUND ? DELAY_BOUND: DELAY_INST, 1692 DE, DELAY_SLOT); 1693 if (tmp1 < 0) { 1694 Import_Tg_Tt 1695 err_code = tmp1; 1696 goto _bip_err1_; 1697 } 1698 if (!IsList(pw2[1].tag)) 1699 break; 1700 pw2 = pw2[1].val.ptr; 1701 } 1702 Import_Tg_Tt 1703 SV = (pword *) 0; 1704 } 1705 Reset_DE; 1706 Handle_Events_Return 1707 Next_Pp; 1708 } 1709 else if (err_code == PTHROW) 1710 { 1711 Reset_DE; 1712 PP = (emu_code) do_exit_block_code_; /* Ball should be in A[1] */ 1713 Next_Pp; 1714 } 1715 else if (err_code > 0) 1716 { 1717 err_code = ILLEGAL_RETURN; 1718 } 1719 /* goto _bip_err1_; */ 1720 1721 1722/******************************************************************* 1723 * External returned an error code 1724 *******************************************************************/ 1725 1726_bip_err1_: /* (err_code, proc), args in A[] */ 1727 Mark_Prof(_bip_err1_) 1728 Kill_DE; 1729 err_code = -err_code; 1730 val_did = PriDid(proc); 1731 tmp1 = DidArity(val_did); 1732 1733 if (!(procb = error_handler_[err_code])) /* get the handler */ 1734 procb = error_handler_[0]; 1735 1736 if (procb->did == d_.true0 && procb->module_ref == d_.kernel_sepia) { 1737 Handle_Events_Return 1738 Next_Pp; 1739 } 1740 else if (procb->did == d_.fail && procb->module_ref == d_.kernel_sepia) 1741 { 1742 Fail 1743 } 1744 else 1745 { 1746 /* now setup call to syserror(Err, Goal, ContextMod, LookupMod) */ 1747 1748 pw1 = S = TG; /* build culprit goal structure */ 1749 TG += tmp1+1; 1750 S->val.did = val_did; 1751 S++->tag.kernel = TDICT; 1752 for(i = 1; i <= tmp1; i++) 1753 { 1754 pw2 = &A[i]; 1755 Move_Pw_To_Global_Stack(pw2, S, ;) 1756 } 1757 Check_Gc; 1758 1759 Make_Integer(&A[1], err_code); 1760 Make_Struct(&A[2], pw1); 1761 Make_Marked_Module(&A[3], PriModule(proc)); 1762 Make_Lookup_Module(&A[4], proc); 1763 1764 proc = procb; 1765 DBG_PORT = CALL_PORT; 1766 goto _handler_call_; /* (proc,DBG_PORT) */ 1767 } 1768 1769 1770 1771_local_control_overflow_: /* still in exported state */ 1772 Import_None; 1773 A[1].val.did = d_.local_control_overflow; 1774 A[1].tag.kernel = TDICT; 1775 PP = (emu_code) do_exit_block_code_; 1776 Next_Pp; 1777 1778_abort_: 1779 A[1].val.did = d_.abort; 1780 A[1].tag.kernel = TDICT; 1781 PP = (emu_code) do_exit_block_code_; 1782 Next_Pp; 1783 1784 1785/************************************************************ 1786 * Event handling 1787 * 1788 * - global stack overflow and garbage collection 1789 * - dictionary garbage collection 1790 * - synchronous interrupt handling 1791 * - waking 1792 * 1793 ************************************************************/ 1794 1795/* 1796Waking: 1797 1798In principle, it is enough to wake at Call, Chain and Jmp locations. 1799Waking at Rets and Exits causes some earlier waking, which is mainly 1800necessary for getting a reasonable debugger trace. 1801*/ 1802 1803/* 1804 * Entry point for the Call-type instructions: 1805 * - We are just at the end of a Call, Chain or Jmp instruction 1806 * - PP points to start of procedure (we get the arity from the code header) 1807 * - return address on top of local stack 1808 * - argument registers hold the call arguments 1809 * - in case of a debug event, proc holds the pri of the called procedure 1810 * 1811 * We push an environment to save the argument registers and the PP. 1812 * PP is normally the start address of a procedure, that's why we cannot treat 1813 * it like a return address. Instead, the procedure we are about to call is 1814 * virtually prefixed with a Continue_after_event instruction, which restores 1815 * the arguments and then continues into the procedure. 1816 */ 1817 1818_handle_events_at_call_: 1819 Mark_Prof(_handle_events_at_call_) 1820 tmp1 = CodeArity(PP); /* number of valid arguments */ 1821 1822/* 1823 * Entry point for the explicit resuming instructions Res/Ress: 1824 * - return address on top of local stack, points behind the Res 1825 * - number of valid argument registers in tmp1 1826 */ 1827_handle_events_at_res_: /* (tmp1) */ 1828 Push_Env /* allocate an environment */ 1829 1830 if (DBG_PRI) 1831 { 1832 PushDynEnvHdr(tmp1+DYNENVDBGSIZE, WAS_CALL, PP); /* save arity, PP, DE */ 1833 SP -= DYNENVDBGSIZE; 1834 DynEnvDE(e)->tag.kernel = DE?TSUSP:TNIL; 1835 DynEnvDE(e)->val.ptr = DE; 1836 DynEnvDbgPri(E)->tag.kernel = TPTR; /* ... and debug info */ 1837 DynEnvDbgPri(E)->val.wptr = (uword *) DBG_PRI; 1838 Make_Integer(DynEnvDbgPort(E), DBG_PORT); 1839 Make_Integer(DynEnvDbgInvoc(E), DBG_INVOC); 1840 DBG_PRI = 0; /* DBG_{PRI,PORT,INVOC} now invalid */ 1841 if (DBG_LINE) { 1842 Make_Atom(DynEnvDbgPath(E), DBG_PATH); 1843 Make_Integer(DynEnvDbgLine(E), DBG_LINE); 1844 Make_Integer(DynEnvDbgFrom(E), DBG_FROM); 1845 Make_Integer(DynEnvDbgTo(E), DBG_TO); 1846 DBG_LINE = 0; /* DBG_{PATH,LINE,FROM,TO} now invalid */ 1847 } else { 1848 Make_Atom(DynEnvDbgPath(E), d_.empty); 1849 Make_Integer(DynEnvDbgLine(E), 0); 1850 Make_Integer(DynEnvDbgFrom(E), 0); 1851 Make_Integer(DynEnvDbgTo(E), 0); 1852 } 1853 PP = (emu_code) &restore_debug_code_[1]; 1854 } 1855 else 1856 { 1857 PushDynEnvHdr(tmp1, 0, PP); /* save arity, PP */ 1858 PP = (emu_code) &restore_code_[1]; 1859 } 1860 1861 pw1 = &A[1]; /* save the argument registers */ 1862 for (; tmp1; --tmp1) 1863 *(--SP) = *pw1++; 1864 Check_Local_Overflow 1865 1866 /* goto _handle_events_at_return_; */ 1867 1868 1869/* 1870 * Entry point for the Return-type instructions: 1871 * - We are about to return to address PP 1872 * - No argument registers are valid 1873 * 1874 * Caution: it is possible that the FakedOverflow was caused by several 1875 * events. Since we can only call a single Prolog handler here, 1876 * we must not reset the FakedOverflow in this case. 1877 */ 1878 1879_handle_events_at_return_: 1880 Mark_Prof(_handle_events_at_return_) 1881 Reset_Faked_Overflow; 1882 Push_Ret_Code(PP) /* (Re)push a return address */ 1883 1884 if (GlobalOverflow) /* call the garbage collector */ 1885 { 1886 PP = (emu_code) auto_gc_code_; 1887 if (MU || EVENT_FLAGS) 1888 { Fake_Overflow; } /* postpone further */ 1889 Next_Pp; /* no call port */ 1890 } 1891 else if (MU) /* meta_term_unify */ 1892 { 1893 /* We assume that this handler is always Prolog, no tool, 1894 * and has arity 1 */ 1895 proc = error_handler_[-(META_TERM_UNIFY)]; 1896 PP = (emu_code) PriCode(proc); 1897 A[1].val.ptr = MU; 1898 A[1].tag.kernel = TLIST; 1899 Reset_Unify_Exceptions 1900 if (EVENT_FLAGS) 1901 { Fake_Overflow; } /* postpone it further */ 1902 } 1903 else if (EVENT_FLAGS && !PO) 1904 { 1905 if (EVENT_FLAGS & EVENT_POSTED) 1906 { 1907 if (VM_FLAGS & EVENTS_DEFERRED) 1908 { 1909 /* p_fprintf(log_output_,"event posted but handling deferred %08x\n",VM_FLAGS); ec_flush(log_output_); */ 1910 Pop_Ret_Code 1911 Next_Pp; /* goto Continue_after_event */ 1912 } 1913 else 1914 { 1915 /* NOTE: Sync events are only handled in nesting level 1! */ 1916 next_posted_event(&A[1]); /* may redo Fake_Overflow */ 1917 if (IsInteger(A[1].tag)) /* indicates delayed signal */ 1918 { 1919 PP = (emu_code) sync_it_code_; 1920 } 1921 else /* posted event */ 1922 { 1923 if (g_emu_.nesting_level > 1) /* don't handle now */ 1924 { 1925 ec_post_event(A[1]); /* re-post */ 1926 Pop_Ret_Code 1927 Next_Pp; 1928 } 1929 else /* handle posted event now */ 1930 { 1931 if (IsTag(A[1].tag.kernel, TPTR)) /* Heap copied event */ 1932 { 1933 extern t_ext_type heap_event_tid; 1934 t_heap_event *event = (t_heap_event *)A[1].val.ptr; 1935 A[2] = A[3] = event->module; 1936 if (event->enabled) { 1937 Export_B_Sp_Tg_Tt; 1938 get_heapterm(&event->goal, &A[1]); 1939 Import_Tg_Tt; 1940 if (event->defers) 1941 { 1942 /* p_fprintf(log_output_,"event defers others\n"); ec_flush(log_output_); */ 1943 VM_FLAGS |= EVENTS_DEFERRED; 1944 } 1945 } else { 1946 Make_Atom(&A[1], d_.true0); 1947 } 1948 heap_event_tid.free((t_ext_ptr)event); 1949 PP = (emu_code) do_call_code_; 1950 } 1951 else 1952 { 1953 A[2].tag.kernel = TNIL; 1954 Make_Atom(&A[3], d_.kernel_sepia); 1955 Make_Atom(&A[4], d_.kernel_sepia); 1956 PP = (emu_code) prolog_error_code_; 1957 } 1958 } 1959 } 1960 if (EVENT_FLAGS & ~EVENT_POSTED) 1961 { Fake_Overflow; } 1962 } 1963 } 1964 else if (g_emu_.nesting_level == 1) /* parallelism-related event */ 1965 { 1966 Pop_Ret_Code 1967 1968 if (LOAD < 0) /* countdown running? */ 1969 { 1970 if (++LOAD == 0) /* delay expired? */ 1971 { 1972 Stop_Countdown(); 1973 LOAD = 1; /* release load now */ 1974 if (LEAF) 1975 { 1976 Export_B_Sp_Tg_Tt 1977 sch_load_report(LEAF); 1978 Import_None 1979 } 1980 } 1981 else 1982 { 1983 Fake_Overflow; /* retrigger countdown */ 1984 } 1985 if (!(EVENT_FLAGS & ~COUNT_DOWN)) 1986 { Next_Pp; } /* countdown only, continue */ 1987 } 1988 Export_All 1989 eng_msg_loop(); 1990 Import_All 1991 Next_Pp; 1992 } 1993 else /* don't handle now */ 1994 { 1995 Pop_Ret_Code 1996 Next_Pp; /* goto Continue_after_event */ 1997 } 1998 } 1999 else /* no event, just return */ 2000 { 2001 Pop_Ret_Code 2002 Next_Pp; /* goto Continue_after_event */ 2003 } 2004 2005 Next_Pp; 2006 2007 2008 2009/******************************************************************* 2010 * THE EMULATOR LOOP 2011 *******************************************************************/ 2012 2013_loop_: 2014 2015 Mark_Prof(_loop_) 2016 Begin_Execution(PP) 2017 2018 switch((PP++)->inst) { 2019 2020 2021/***** Data Move Instructions *****/ 2022/************************************/ 2023 Case(MoveAM, I_MoveAM) 2024 Get_Argument(pw1) 2025 *(--SP) = *pw1; 2026 Check_Local_Overflow 2027 Case(Nop, I_Nop) 2028 Next_Pp; 2029 2030 Case(Move3AMAM, I_Move3AMAM) 2031 Get_Argument(pw1) 2032 Get_Argument(pw2) 2033 Move_Pw(pw1,pw2) 2034 /* falls through */ 2035 Case(Move2AMAM, I_Move2AMAM) 2036 Get_Argument(pw1) 2037 Get_Argument(pw2) 2038 Move_Pw(pw1,pw2) 2039 /* falls through */ 2040 Case(MoveAMAM, I_MoveAMAM) 2041 Get_Argument(pw1) 2042 Get_Argument(pw2) 2043 Move_Pw(pw1,pw2) 2044 Next_Pp; 2045 2046 Case(Move3LL, I_Move3LL) 2047 Get_Local(pw1) 2048 Get_Local(pw2) 2049 Move_Pw(pw1,pw2) 2050 /* falls through */ 2051 Case(Move2LL, I_Move2LL) 2052 Get_Local(pw1) 2053 Get_Local(pw2) 2054 Move_Pw(pw1,pw2) 2055 /* falls through */ 2056 Case(MoveLL, I_MoveLL) 2057 Get_Local(pw1) 2058 Get_Local(pw2) 2059 Move_Pw(pw1,pw2) 2060 Next_Pp; 2061 2062 2063/* 2064Possible additional combined instructions 2065 Swap A1<->A2 2066 Shift A1<-A2<-A3 (all different) 2067 Rotate A1<-A2<-A3(<-A1) 2068*/ 2069 Case(SwapAMAM, I_SwapAMAM) 2070 Get_Argument(pw1) 2071 Get_Argument(pw2) 2072 tmp1 = pw1->val.all; 2073 pw1->val.all = pw2->val.all; 2074 pw2->val.all = tmp1; 2075 tmp1 = pw1->tag.all; 2076 pw1->tag.all = pw2->tag.all; 2077 pw2->tag.all = tmp1; 2078 Next_Pp; 2079 2080 Case(ShiftAMAMAM, I_ShiftAMAMAM) 2081 Get_Argument(pw1) 2082 Get_Argument(pw2) 2083 *pw1 = *pw2; 2084 Get_Argument(pw1) 2085 *pw2 = *pw1; 2086 Next_Pp; 2087 2088 Case(ShiftAMAMAMAM, I_ShiftAMAMAMAM) 2089 Get_Argument(pw1) 2090 Get_Argument(pw2) 2091 *pw1 = *pw2; 2092 Get_Argument(pw1) 2093 *pw2 = *pw1; 2094 Get_Argument(pw2) 2095 *pw1 = *pw2; 2096 Next_Pp; 2097 2098 Case(ShiftAMAMAMAMAM, I_ShiftAMAMAMAMAM) 2099 Get_Argument(pw1) 2100 Get_Argument(pw2) 2101 *pw1 = *pw2; 2102 Get_Argument(pw1) 2103 *pw2 = *pw1; 2104 Get_Argument(pw2) 2105 *pw1 = *pw2; 2106 Get_Argument(pw1) 2107 *pw2 = *pw1; 2108 Next_Pp; 2109 2110 Case(RotAMAMAM, I_RotAMAMAM) 2111 Get_Argument(pw1) 2112 scratch_pw = *pw1, 2113 Get_Argument(pw2) 2114 *pw1 = *pw2; 2115 Get_Argument(pw1) 2116 *pw2 = *pw1; 2117 *pw1 = scratch_pw; 2118 Next_Pp; 2119 2120 Case(Get_variableNAML, I_Get_variableNAML) 2121 Alloc_Env 2122 Case(MoveAML, I_MoveAML) 2123 Get_Argument(pw1) 2124 Get_Local(pw2) 2125 Move_Pw(pw1,pw2) 2126 Next_Pp; 2127 2128 Case(MoveNAML, I_MoveNAML) 2129 i = PP++->nint; 2130 Get_Argument(pw1); 2131 Get_Local(pw2); 2132 do 2133 { 2134 Move_Pw(pw1, pw2) 2135 pw1++; 2136 pw2--; 2137 } while (--i > 0); 2138 Next_Pp; 2139 2140 Case(Move3AML, I_Move3AML) 2141 Get_Argument(pw1) 2142 Get_Local(pw2) 2143 Move_Pw(pw1,pw2) 2144 Case(Move2AML, I_Move2AML) 2145 Get_Argument(pw1) 2146 Get_Local(pw2) 2147 Move_Pw(pw1,pw2) 2148 Get_Argument(pw1) 2149 Get_Local(pw2) 2150 Move_Pw(pw1,pw2) 2151 Next_Pp; 2152 2153 Case(Move3LAM, I_Move3LAM) 2154 Get_Local(pw1) 2155 Get_Argument(pw2) 2156 Move_Pw(pw1,pw2) 2157 Case(Move2LAM, I_Move2LAM) 2158 Get_Local(pw1) 2159 Get_Argument(pw2) 2160 Move_Pw(pw1,pw2) 2161 Case(MoveLAM, I_MoveLAM) 2162 Get_Local(pw1) 2163 Get_Argument(pw2) 2164 Move_Pw(pw1,pw2) 2165 Next_Pp; 2166 2167 Case(MoveNLAM, I_MoveNLAM) 2168 i = PP++->nint; 2169 Get_Local(pw1); 2170 Get_Argument(pw2); 2171 do 2172 { 2173 Move_Pw(pw1, pw2) 2174 pw1--; 2175 pw2++; 2176 } while (--i > 0); 2177 Next_Pp; 2178 2179 Case(MoveTMAM, I_MoveTMAM) 2180 Get_Temporary(pw1) 2181 Get_Argument(pw2) 2182 Move_Pw(pw1,pw2) 2183 Next_Pp; 2184 2185 2186/***** Get_value?? instructions *****/ 2187/************************************/ 2188 2189 Case(Get_valueAMAM, I_Get_valueAMAM) 2190 Get_Argument(pw1) 2191 Get_Argument(pw2) 2192 goto _unify_; 2193 2194 Case(Get_valueAML, I_Get_valueAML) 2195 Get_Argument(pw1) 2196 Get_Local(pw2); 2197 goto _unify_; 2198 2199 Case(Get_valueAMTM, I_Get_valueAMTM) 2200 Get_Argument(pw1) 2201 Get_Temporary(pw2) 2202 goto _unify_; 2203 2204 Case(Get_valueLL, I_Get_valueLL) 2205 Get_Local(pw1) 2206 Get_Local(pw2); 2207 goto _unify_; 2208 2209 2210/**** 2211 Get_?constant??? 2212 ... unify the argument with a constant. 2213****/ 2214 2215 Case(Out_get_constantAM, I_Out_get_constantAM) 2216 Case(Get_constantAM, I_Get_constantAM) /* AM, val, tag */ 2217 Get_Argument(pw1); 2218_unify_const_: /* (pw1,pp) */ 2219 Dereference_Pw_Tag(pw1,tmp1); 2220 if (ISRef(tmp1)) { 2221 if (ISVar(tmp1)) { 2222 Trail_If_Needed(pw1); 2223 pw1->val.all = PP++->all; 2224 pw1->tag.all = PP++->all; 2225 Next_Pp; 2226 } else { 2227 pw2 = PP++->ptr; 2228 tmp1 = PP++->kernel; 2229 goto _bind_nonstandard_; 2230 } 2231 } 2232_compare_const_: /* (tmp1,pw1,pp) */ 2233 if (!IsTag(tmp1, PP[1].all)) { 2234 Fail 2235 } else if (ISSimple(tmp1)) { 2236 if (!SimpleEq(tmp1, pw1->val, PP->val)) { 2237 Fail 2238 } 2239 } else { 2240 Export_B_Sp_Tg_Tt 2241 err_code = tag_desc[TagTypeC(tmp1)].equal(pw1->val.ptr, PP->ptr); 2242 Import_None 2243 if (!err_code) { Fail } 2244 } 2245 PP += 2; 2246 Next_Pp; 2247 2248 2249 Case(Out_get_nilAM, I_Out_get_nilAM) 2250 Case(Get_nilAM, I_Get_nilAM) 2251 Get_Argument(pw1) 2252 Dereference_Pw_Tag(pw1,tmp1) 2253 if(ISVar(tmp1)) { 2254 Bind_Tag(pw1,TNIL) 2255 } else if(IsTag(tmp1,TNIL)) { 2256 Next_Pp; 2257 } else if(ISRef(tmp1)) { 2258 Bind_CRef_pw1_Tag(TNIL); 2259 } else 2260 { Fail } 2261 Next_Pp; 2262 2263 Case(Get_integer2AM, I_Get_integer2AM) 2264 Get_Argument(pw1) 2265 Unify_Simple_pw1(TINT, nint, tmp1) 2266 /* falls through */ 2267 Case(Out_get_integerAM, I_Out_get_integerAM) 2268 Case(Get_integerAM, I_Get_integerAM) 2269 Get_Argument(pw1) 2270 Unify_Simple_pw1(TINT, nint, tmp1) 2271 Next_Pp; 2272 2273#ifdef TFLOAT 2274 Case(Out_get_floatAM, I_Out_get_floatAM) 2275 Case(Get_floatAM, I_Get_floatAM) 2276 Get_Argument(pw1) 2277 Unify_Simple_pw1(TFLOAT, real, tmp1) 2278 Next_Pp; 2279#endif 2280 2281 Case(Get_atom2AM, I_Get_atom2AM) 2282 Get_Argument(pw1) 2283 Unify_Simple_pw1(TDICT, did, tmp1) 2284 /* falls through */ 2285 Case(Out_get_atomAM, I_Out_get_atomAM) 2286 Case(Get_atomAM, I_Get_atomAM) 2287 Get_Argument(pw1) 2288 Unify_Simple_pw1(TDICT, did, tmp1) 2289 Next_Pp; 2290 2291 Case(Out_get_stringAM, I_Out_get_stringAM) 2292 Case(Get_stringAM, I_Get_stringAM) 2293 Get_Argument(pw1) 2294 Dereference_Pw_Tag(pw1,tmp1) 2295 if(ISVar(tmp1)) { 2296 Bind_(pw1, PP++->all, TSTRG) 2297 } else if(IsTag(tmp1,TSTRG)) { 2298 pw1 = pw1->val.ptr; 2299 pw2 = PP++->ptr; 2300 Compare_Strings(pw1, pw2, err_code); 2301 if(err_code >= 0) { Fail } 2302 } else if(ISRef(tmp1)) { 2303 Bind_CRef_pw1(PP++->all,TSTRG) 2304 } else 2305 { Fail } 2306 Next_Pp; 2307 2308 Case(Get_atomintegerAMAM, I_Get_atomintegerAMAM) 2309 Get_Argument(pw1) 2310 Unify_Simple_pw1(TDICT, did, tmp1) 2311 Get_Argument(pw1) 2312 Unify_Simple_pw1(TINT, nint, tmp1) 2313 Next_Pp; 2314 2315 Case(Get_metaAM, I_Get_metaAM) 2316 Get_Argument(pw1) 2317 i = (uword) PP++->kernel; 2318_read_meta_: /* unify *pw1 with a new meta with tag i */ 2319 Dereference_Pw_Tag(pw1,tmp1) 2320 S = TG; 2321 TG += 2; 2322 if (ISVar(tmp1)) { 2323 if (IsLocal(pw1)) { 2324 Constructed_Structure(0) 2325 } else { 2326 Constructed_Structure(pw1) 2327 } 2328 S->val.ptr = S; 2329 S->tag.all = i; 2330 Bind_(pw1, (uword) S, TREF); 2331 } else if (ISRef(tmp1)) { /* this case could be optimized */ 2332 Constructed_Structure(pw1); 2333 S->val.ptr = S; 2334 S->tag.all = i; 2335 Export_B_Sp_Tg_Tt_Eb_Gb 2336 err_code = bind_c(pw1, S, &MU); 2337 Import_Tg_Tt 2338 if (err_code == PFAIL) { Fail; } 2339 } else { /* TMETA = nonvar */ 2340 S->val.all = pw1->val.all; 2341 S->tag.kernel = tmp1; 2342 Update_MU(S) 2343 } 2344 Next_Pp; 2345 2346 2347 Case(Get_listAM, I_Get_listAM) 2348 Get_Argument(pw1) 2349 Dereference_Pw_Tag(pw1,tmp1) 2350 if(ISVar(tmp1)) { 2351 if (IsLocal(pw1)) { 2352 Constructed_Structure(0) 2353 } else { 2354 Constructed_Structure(pw1) 2355 } 2356 S = TG; 2357 TG += 2; 2358 Bind_(pw1, (uword) S, TLIST) 2359 PP++; 2360 } else if (IsTag(tmp1,TLIST)) { 2361 S = (pw1->val).ptr; 2362 PP = PP->code; 2363 } else if (ISRef(tmp1)) { 2364 Constructed_Structure(pw1); 2365 S = TG; 2366 TG += 2; 2367 PP++; 2368 Bind_CRef_pw1((uword) S, TLIST) 2369 } else 2370 { Fail } 2371 Next_Pp; 2372 2373 Case(Get_structureAM, I_Get_structureAM) 2374 Get_Argument(pw1) 2375 Dereference_Pw_Tag(pw1,tmp1) 2376 if(ISVar(tmp1)) { 2377 if (IsLocal(pw1)) { 2378 Constructed_Structure(0) 2379 } else { 2380 Constructed_Structure(pw1) 2381 } 2382 val_did = PP++->did; 2383 S = TG; 2384 TG += DidArity(val_did) + 1; 2385 Bind_(pw1, (uword) S, TCOMP) 2386 S->val.did = val_did; 2387 ((S)++)->tag.kernel = TDICT; 2388 PP++; 2389 } else if (!IsTag(tmp1,TCOMP)) { 2390 if(ISRef(tmp1)) { 2391 Constructed_Structure(pw1); 2392 val_did = PP++->did; 2393 S = TG; 2394 TG += DidArity(val_did) + 1; 2395 pw2 = S; 2396 S->val.did = val_did; 2397 ((S)++)->tag.kernel = TDICT; 2398 PP++; 2399 tmp1 = TCOMP; 2400 goto _bind_nonstandard_; /* (pw1, pw2, tmp1) */ 2401 } else { Fail } 2402 } else if (pw1->val.ptr->val.did != PP++->did ) { 2403 Fail 2404 } else { 2405 S = pw1->val.ptr; 2406 S += 1; 2407 PP = PP->code; 2408 } 2409 Next_Pp; 2410 2411/*** output mode head arguments ***/ 2412 2413 Case(Out_get_listAM, I_Out_get_listAM) 2414 Get_Argument(pw1) 2415 Dereference_Pw_Tag(pw1, tmp1) 2416 S = TG; 2417 TG += 2; 2418 if(ISVar(tmp1)) { 2419 Bind_(pw1, (uword) S, TLIST); 2420 } else if(ISRef(tmp1)) { 2421 Bind_CRef_pw1((uword) S, TLIST); 2422 } else { Fail } /* in case the mode is violated */ 2423 Next_Pp; 2424 2425 Case(Out_get_structureAM, I_Out_get_structureAM) 2426 Get_Argument(pw1) 2427 Dereference_Pw_Tag(pw1, tmp1) 2428 val_did = PP++->did; 2429 S = TG; 2430 TG += DidArity(val_did) + 1; 2431 if(ISVar(tmp1)) { 2432 Bind_(pw1, (uword) S, TCOMP); 2433 S->val.did = val_did; 2434 ((S)++)->tag.kernel = TDICT; 2435 } else if(ISRef(tmp1)) { 2436 pw2 = S; 2437 S->val.did = val_did; 2438 ((S)++)->tag.kernel = TDICT; 2439 tmp1 = TCOMP; 2440 goto _bind_nonstandard_; /* (pw1, pw2, tmp1) */ 2441 } else { Fail } /* in case the mode is violated */ 2442 Next_Pp; 2443 2444 2445 2446/**** Head nested argument unification instructions ****/ 2447/*******************************************************/ 2448 2449/**** 2450 Read instructions 2451****/ 2452 2453/**** Read Variable ****/ 2454 2455 Case(Read_void, I_Read_void) 2456 S += 1; 2457 Next_Pp; 2458 2459 Case(Read_voidN, I_Read_voidN) 2460 S = ByteOffsetPlus(S, PP++->offset); 2461 Next_Pp; 2462 2463 Case(Read_variable, I_Read_variable) 2464 *(--SP) = *(S++); 2465 Check_Local_Overflow 2466 Next_Pp; 2467 2468 Case(Read_variable2AM, I_Read_variable2AM) 2469 Get_Argument(pw1) 2470 *pw1 = *(S++); 2471 /* falls through */ 2472 Case(Read_variableAM, I_Read_variableAM) 2473 Get_Argument(pw1) 2474 *pw1 = *(S++); 2475 Next_Pp; 2476 2477 Case(Read_variable2AML, I_Read_variable2AML) 2478 Get_Argument(pw1) 2479 *pw1 = *(S++); 2480 Get_Local(pw1) 2481 *pw1 = *(S++); 2482 Next_Pp; 2483 2484 Case(Read_variableNL, I_Read_variableNL) 2485 Alloc_Env 2486 2487 Case(Read_variableL, I_Read_variableL) 2488 Get_Local(pw1) 2489 *pw1 = *(S++); 2490 Next_Pp; 2491 2492 Case(Read_variable2L, I_Read_variable2L) 2493 Get_Local(pw1) 2494 *pw1 = *(S++); 2495 Get_Local(pw1) 2496 *pw1 = *(S++); 2497 Next_Pp; 2498 2499 2500/**** Read Reference ****/ 2501 2502 Case(Read_reference, I_Read_reference) 2503 (--SP)->tag.kernel = TREF; 2504 SP->val.ptr = S++; 2505 Check_Local_Overflow 2506 Next_Pp; 2507 2508 Case(Read_referenceAM, I_Read_referenceAM) 2509 Get_Argument(pw1) 2510 pw1->val.ptr = S++; 2511 pw1->tag.kernel = TREF; 2512 Next_Pp; 2513 2514 Case(Read_referenceNL, I_Read_referenceNL) 2515 Alloc_Env 2516 2517 Case(Read_referenceL, I_Read_referenceL) 2518 Get_Local(pw1) 2519 pw1->val.ptr = S++; 2520 pw1->tag.kernel = TREF; 2521 Next_Pp; 2522 2523 2524/**** Read value ****/ 2525 2526 Case(Read_valueAM, I_Read_valueAM) 2527 Get_Argument(pw1) 2528 pw2 = S++; 2529 goto _unify_; 2530 2531 Case(Read_valueL, I_Read_valueL) 2532 Get_Local(pw1) 2533 pw2 = S++; 2534 goto _unify_; 2535 2536 Case(Read_valueTM, I_Read_valueTM) 2537 Get_Temporary(pw1) 2538 pw2 = S++; 2539 goto _unify_; 2540 2541 2542/**** Read?constant?? ****/ 2543 2544 /* val, tag */ 2545 2546 Case(Read_constant, I_Read_constant) 2547 pw1 = S++; 2548 goto _unify_const_; 2549 2550 Case(Read_nil, I_Read_nil) 2551 pw1 = S++; 2552 Dereference_Pw_Tag(pw1,tmp1) 2553 if(ISVar(tmp1)) { 2554 Bind_Tag(pw1,TNIL) 2555 } else if((!IsTag(tmp1,TNIL))) { 2556 if(ISRef(tmp1)) { 2557 Bind_CRef_pw1_Tag(TNIL); 2558 } else { 2559 Fail 2560 } 2561 } 2562 Next_Pp; 2563 2564 Case(Read_integer2, I_Read_integer2) 2565 pw1 = S++; 2566 Unify_Simple_pw1(TINT, nint, tmp1) 2567 /* falls through */ 2568 Case(Read_integer, I_Read_integer) 2569 pw1 = S++; 2570 Unify_Simple_pw1(TINT, nint, tmp1) 2571 Next_Pp; 2572 2573#ifdef TFLOAT 2574 Case(Read_float, I_Read_float) 2575 pw1 = S++; 2576 Unify_Simple_pw1(TFLOAT, real, tmp1) 2577 Next_Pp; 2578#endif 2579 2580 Case(Read_atom2, I_Read_atom2) 2581 pw1 = S++; 2582 Unify_Simple_pw1(TDICT, did, tmp1) 2583 /* falls through */ 2584 Case(Read_atom, I_Read_atom) 2585 pw1 = S++; 2586 Unify_Simple_pw1(TDICT, did, tmp1) 2587 Next_Pp; 2588 2589 Case(Read_integeratom, I_Read_integeratom) 2590 pw1 = S++; 2591 Unify_Simple_pw1(TINT, nint, tmp1) 2592 pw1 = S++; 2593 Unify_Simple_pw1(TDICT, did, tmp1) 2594 Next_Pp; 2595 2596 Case(Read_atominteger, I_Read_atominteger) 2597 pw1 = S++; 2598 Unify_Simple_pw1(TDICT, did, tmp1) 2599 pw1 = S++; 2600 Unify_Simple_pw1(TINT, nint, tmp1) 2601 Next_Pp; 2602 2603 Case(Read_string, I_Read_string) 2604 pw1 = S++; 2605 Dereference_Pw_Tag(pw1,tmp1) 2606 if(ISVar(tmp1)) { 2607 Bind_(pw1, PP++->all, TSTRG) 2608 } else if(!IsTag(tmp1,TSTRG)) { 2609 if(ISRef(tmp1)) { 2610 Bind_CRef_pw1(PP++->all,TSTRG) 2611 } else { 2612 Fail 2613 } 2614 } else { 2615 pw1 = pw1->val.ptr; 2616 pw2 = PP++->ptr; 2617 Compare_Strings(pw1, pw2, err_code); 2618 if(err_code >= 0) { 2619 Fail 2620 } 2621 } 2622 Next_Pp; 2623 2624 2625 Case(Match_meta, I_Match_meta) /* first */ 2626 (--SP)->tag.kernel = MODE_READ; 2627 SP->val.ptr = S + 1; 2628 Check_Local_Overflow 2629 Case(Match_last_meta, I_Match_last_meta) /* last */ 2630_match_meta_: 2631 Dereference_Pw_Tag(S,tmp1) 2632 if (IsTag(tmp1,TMETA)) { 2633 S = S->val.ptr; 2634 } else 2635 { Fail } 2636 Next_Pp; 2637 2638 Case(Match_next_metaTM, I_Match_next_metaTM) /* next */ 2639 Get_Temporary(pw1) 2640 S = (pw1->val.ptr)++; 2641 goto _match_meta_; 2642 2643 Case(Match_metaTM, I_Match_metaTM) /* alone */ 2644 Get_Temporary(pw1) 2645 pw1->val.ptr = S + 1; 2646 goto _match_meta_; 2647 2648 2649 Case(Read_meta, I_Read_meta) /* first */ 2650 (--SP)->tag.kernel = MODE_READ; 2651 SP->val.ptr = S + 1; 2652 Check_Local_Overflow 2653 Case(Read_last_meta, I_Read_last_meta) /* last */ 2654 pw1 = S; 2655 i = (uword) PP++->kernel; 2656 PP = PP->code; 2657 goto _read_meta_; /* (pw1, i) */ 2658 2659 Case(Read_next_metaTM, I_Read_next_metaTM) /* next */ 2660 Get_Temporary(pw1) 2661 /* pw1 = (pw1->val.ptr)++; wrong in the C compiler */ 2662 S = pw1->val.ptr; 2663 pw1->val.ptr = S + 1; 2664 pw1 = S; 2665 i = (uword) PP++->kernel; 2666 PP = PP->code; 2667 goto _read_meta_; /* (pw1, i) */ 2668 2669 Case(Read_metaTM, I_Read_metaTM) /* alone */ 2670 Get_Temporary(pw1) 2671 pw1->val.ptr = S + 1; 2672 pw1 = S; 2673 i = (uword) PP++->kernel; 2674 PP = PP->code; 2675 goto _read_meta_; /* (pw1, i) */ 2676 2677 Case(Read_attribute, I_Read_attribute) 2678 Dereference_Pw(S) 2679 S = S->val.ptr; 2680 tmp1 = PP++->offset; 2681 if (tmp1 > DidArity(S->val.did) * sizeof(pword)) { 2682 Fail 2683 } 2684 S = ByteOffsetPlus(S, tmp1); 2685 Next_Pp; 2686 2687 Case(Read_list, I_Read_list) /* first */ 2688 (--SP)->tag.kernel = MODE_READ; 2689 SP->val.ptr = S + 1; 2690 Check_Local_Overflow 2691 Case(Read_last_list, I_Read_last_list) /* last */ 2692 Dereference_Pw_Tag(S,tmp1) 2693 if (ISRef(tmp1)) { 2694 Constructed_Structure(S); 2695 PP = PP->code; 2696 pw1 = S; 2697 S = TG; 2698 TG = S + 2; 2699 Bind_Ref_pw1(tmp1, (uword) S, TLIST) 2700 } else if (IsTag(tmp1,TLIST)) { 2701 S = S->val.ptr; 2702 PP++; 2703 } else 2704 { Fail } 2705 Next_Pp; 2706 2707 2708 Case(Read_listTM, I_Read_listTM) /* alone */ 2709 Get_Temporary(pw2) 2710 pw1 = S++; 2711 pw2->val.ptr = S; 2712 Dereference_Pw_Tag(pw1,tmp1) 2713 if (ISRef(tmp1)) { 2714 Constructed_Structure(pw1); 2715 pw2->tag.kernel = MODE_READ; 2716 PP = PP->code; 2717 S = TG; 2718 TG = S + 2; 2719 Bind_Ref_pw1(tmp1, (uword) S, TLIST) 2720 } else if (IsTag(tmp1,TLIST)) { 2721 S = pw1->val.ptr; 2722 PP++; 2723 } else 2724 { Fail } 2725 Next_Pp; 2726 2727 Case(Read_next_listTM, I_Read_next_listTM) /* next */ 2728 Get_Temporary(pw1) 2729 S = (pw1->val.ptr)++; 2730 Dereference_Pw_Tag(S,tmp1) 2731 if (ISRef(tmp1)) { 2732 Constructed_Structure(S); 2733 pw1->tag.kernel = MODE_READ; 2734 PP = PP->code; 2735 pw1 = S; 2736 S = TG; 2737 TG = S + 2; 2738 Bind_Ref_pw1(tmp1, (uword) S, TLIST) 2739 } else if (IsTag(tmp1,TLIST)) { 2740 S = S->val.ptr; 2741 PP++; 2742 } else 2743 { Fail } 2744 Next_Pp; 2745 2746 Case(Read_structure, I_Read_structure) /* did lab */ 2747 (--SP)->tag.kernel = MODE_READ; 2748 SP->val.ptr = S + 1; 2749 Check_Local_Overflow 2750 Case(Read_last_structure, I_Read_last_structure) /* did lab */ 2751 Dereference_Pw_Tag(S,tmp1) 2752 if(ISVar(tmp1)) { 2753 Constructed_Structure(S); 2754 val_did = PP++->did; 2755 pw1 = S; 2756 S = TG; 2757 TG += DidArity(val_did) + 1; 2758 Bind_(pw1, (uword) S,TCOMP); 2759 S->val.did = val_did; 2760 (S++)->tag.kernel = TDICT; 2761 PP = PP->code; 2762 } else if (!IsTag(tmp1,TCOMP)) { 2763 if(ISRef(tmp1)) { 2764 Constructed_Structure(S); 2765 val_did = PP++->did; 2766 pw1 = S; 2767 S = TG; 2768 TG += DidArity(val_did) + 1; 2769 pw2 = S; 2770 S->val.did = val_did; 2771 (S++)->tag.kernel = TDICT; 2772 PP = PP->code; 2773 tmp1 = TCOMP; 2774 goto _bind_nonstandard_; /* (pw1, pw2, tmp1) */ 2775 } else { Fail } 2776 } else if (S->val.ptr->val.did != PP->did ) { 2777 Fail 2778 } else { 2779 S = S->val.ptr + 1; 2780 PP += 2; 2781 } 2782 Next_Pp; 2783 2784 2785 Case(Read_structureTM, I_Read_structureTM) /* did TM lab */ 2786 Get_Temporary_Offs(1, pw2) 2787 pw1 = (S)++; 2788 pw2->val.ptr = S; 2789 Dereference_Pw_Tag(pw1,tmp1) 2790 if(ISVar(tmp1)) { 2791 Constructed_Structure(pw1); 2792 pw2->tag.kernel = MODE_READ; 2793 val_did = PP->did; 2794 S = TG; 2795 TG += DidArity(val_did) + 1; 2796 Bind_(pw1, (uword) S, TCOMP) 2797 S->val.did = val_did; 2798 (S++)->tag.kernel = TDICT; 2799 PP = (PP+2)->code; 2800 } else if (!IsTag(tmp1,TCOMP)) { 2801 if(ISRef(tmp1)) { 2802 Constructed_Structure(pw1); 2803 pw2->tag.kernel = MODE_READ; 2804 val_did = PP->did; 2805 S = TG; 2806 TG += DidArity(val_did) + 1; 2807 pw2 = S; 2808 S->val.did = val_did; 2809 (S++)->tag.kernel = TDICT; 2810 PP = (PP+2)->code; 2811 tmp1 = TCOMP; 2812 goto _bind_nonstandard_; /* (pw1, pw2, tmp1) */ 2813 } else { Fail } 2814 } else if (pw1->val.ptr->val.did != PP->did) { 2815 Fail 2816 } else { 2817 S = pw1->val.ptr + 1; 2818 PP += 3; 2819 } 2820 Next_Pp; 2821 2822 2823 Case(Read_next_structureTM, I_Read_next_structureTM) /* did TM lab */ 2824 Get_Temporary_Offs(1, pw2) 2825 S = (pw2->val.ptr)++; 2826 Dereference_Pw_Tag(S,tmp1) 2827 if(ISVar(tmp1)) { 2828 Constructed_Structure(S); 2829 pw2->tag.kernel = MODE_READ; 2830 val_did = PP->did; 2831 pw1 = S; 2832 S = TG; 2833 TG += DidArity(val_did) + 1; 2834 Bind_(pw1, (uword) S, TCOMP) 2835 S->val.did = val_did; 2836 (S++)->tag.kernel = TDICT; 2837 PP = (PP+2)->code; 2838 } else if (!IsTag(tmp1,TCOMP)) { 2839 if(ISRef(tmp1)) { 2840 Constructed_Structure(S); 2841 pw2->tag.kernel = MODE_READ; 2842 val_did = PP->did; 2843 pw1 = S; 2844 S = TG; 2845 TG += DidArity(val_did) + 1; 2846 pw2 = S; 2847 S->val.did = val_did; 2848 (S++)->tag.kernel = TDICT; 2849 PP = (PP+2)->code; 2850 tmp1 = TCOMP; 2851 goto _bind_nonstandard_; /* (pw1, pw2, tmp1) */ 2852 } else { Fail } 2853 } else if (S->val.ptr->val.did != PP->did) { 2854 Fail 2855 } else { 2856 S = S->val.ptr + 1; 2857 PP += 3; 2858 } 2859 Next_Pp; 2860 2861 2862 2863 2864/**** Write and Push instructions ****/ 2865 2866 Case(Write_variable, I_Write_variable) 2867 Case(Push_variable, I_Push_variable) 2868 (--SP)->tag.kernel = TREF; 2869 SP->val.ptr = S; 2870 Check_Local_Overflow 2871 /* fall through */ 2872 2873 Case(Write_void, I_Write_void) 2874 Case(Push_void, I_Push_void) 2875 S->val.ptr = S; 2876 ((S)++)->tag.kernel = TREF; 2877 Next_Pp; 2878 2879 Case(Push_voidN, I_Push_voidN) 2880 Case(Write_voidN, I_Write_voidN) 2881 pw1 = ByteOffsetPlus(S, PP++->offset); 2882 while (S < pw1) 2883 { 2884 S->val.ptr = S; 2885 ((S)++)->tag.kernel = TREF; 2886 } 2887 Next_Pp; 2888 2889 Case(Write_variable2AM, I_Write_variable2AM) 2890 Get_Argument(pw1) 2891 pw1->val.ptr = S; 2892 pw1->tag.kernel = TREF; 2893 S->val.ptr = S; 2894 ((S)++)->tag.kernel = TREF; 2895 /* falls through */ 2896 Case(Write_variableAM, I_Write_variableAM) 2897 Case(Push_variableAM, I_Push_variableAM) 2898 Get_Argument(pw1) 2899 pw1->val.ptr = S; 2900 pw1->tag.kernel = TREF; 2901 S->val.ptr = S; 2902 ((S)++)->tag.kernel = TREF; 2903 Next_Pp; 2904 2905 Case(Write_variable2AML, I_Write_variable2AML) 2906 Get_Argument(pw1) 2907 pw1->val.ptr = S; 2908 pw1->tag.kernel = TREF; 2909 S->val.ptr = S; 2910 ((S)++)->tag.kernel = TREF; 2911 Get_Local(pw1) 2912 pw1->val.ptr = S; 2913 pw1->tag.kernel = TREF; 2914 S->val.ptr = S; 2915 ((S)++)->tag.kernel = TREF; 2916 Next_Pp; 2917 2918 Case(Write_variableNL, I_Write_variableNL) 2919 Alloc_Env 2920 2921 Case(Write_variableL, I_Write_variableL) 2922 Case(Push_variableL, I_Push_variableL) 2923 Get_Local(pw1) 2924 pw1->val.ptr = S; 2925 pw1->tag.kernel = TREF; 2926 S->val.ptr = S; 2927 ((S)++)->tag.kernel = TREF; 2928 Next_Pp; 2929 2930 Case(Write_variable2L, I_Write_variable2L) 2931 Get_Local(pw1) 2932 pw1->val.ptr = S; 2933 pw1->tag.kernel = TREF; 2934 S->val.ptr = S; 2935 ((S)++)->tag.kernel = TREF; 2936 S->val.ptr = S; 2937 S->tag.kernel = TREF; 2938 Get_Local(pw1) 2939 pw1->val.ptr = (S)++; 2940 pw1->tag.kernel = TREF; 2941 Next_Pp; 2942 2943 Case(Push_init_variableL, I_Push_init_variableL) 2944 Get_Local(pw1) 2945 Trail_If_Needed_Eb(pw1) 2946 pw1->val.ptr = S; 2947 S->val.ptr = S; 2948 ((S)++)->tag.kernel = TREF; 2949 Next_Pp; 2950 2951 Case(Write_named_variable, I_Write_named_variable) 2952 (--SP)->tag.kernel = TREF; 2953 SP->val.ptr = S; 2954 Check_Local_Overflow 2955 /* fall through */ 2956 2957 Case(Write_named_void, I_Write_named_void) 2958 S->val.ptr = S; 2959 ((S)++)->tag.kernel = PP++->kernel; 2960 Next_Pp; 2961 2962 Case(Write_named_variableAM, I_Write_named_variableAM) 2963 Get_Argument(pw1) 2964 pw1->val.ptr = S; 2965 pw1->tag.kernel = TREF; 2966 S->val.ptr = S; 2967 ((S)++)->tag.kernel = PP++->kernel; 2968 Next_Pp; 2969 2970 Case(Write_named_variableNL, I_Write_named_variableNL) 2971 Alloc_Env 2972 Case(Write_named_variableL, I_Write_named_variableL) 2973 Get_Local(pw1) 2974 pw1->val.ptr = S; 2975 pw1->tag.kernel = TREF; 2976 S->val.ptr = S; 2977 ((S)++)->tag.kernel = PP++->kernel; 2978 Next_Pp; 2979 2980 Case(Push_self_reference, I_Push_self_reference) 2981 S->val.ptr = S; 2982 S++->tag.kernel = PP++->kernel; 2983 Next_Pp; 2984 2985 Case(Push_void_reference, I_Push_void_reference) 2986 S->tag.kernel = TREF; 2987 ((S)++)->val.ptr = TG; 2988 TG = ByteOffsetPlus(TG, PP++->offset); 2989 Next_Pp; 2990 2991 Case(Push_reference, I_Push_reference) 2992 (--SP)->tag.kernel = S->tag.kernel = TREF; 2993 SP->val.ptr = ((S)++)->val.ptr = TG; 2994 TG = ByteOffsetPlus(TG, PP++->offset); 2995 Check_Local_Overflow 2996 Next_Pp; 2997 2998 Case(Push_referenceAM, I_Push_referenceAM) 2999 Get_Argument(pw1) 3000 pw1->val.ptr = S->val.ptr = TG; 3001 pw1->tag.kernel = S++->tag.kernel = TREF; 3002 TG = ByteOffsetPlus(TG, PP++->offset); 3003 Next_Pp; 3004 3005 Case(Push_referenceL, I_Push_referenceL) 3006 Get_Local(pw1) 3007 pw1->val.ptr = S->val.ptr = TG; 3008 pw1->tag.kernel = S++->tag.kernel = TREF; 3009 TG = ByteOffsetPlus(TG, PP++->offset); 3010 Next_Pp; 3011 3012 Case(Push_init_referenceL, I_Push_init_referenceL) 3013 Get_Local(pw1) 3014 Trail_If_Needed_Eb(pw1) 3015 pw1->val.ptr = S->val.ptr = TG; 3016 S++->tag.kernel = TREF; 3017 TG = ByteOffsetPlus(TG, PP++->offset); 3018 Next_Pp; 3019 3020 Case(Write_valueAM, I_Write_valueAM) 3021 Case(Push_valueAM, I_Push_valueAM) 3022 Get_Argument(pw1) 3023 Occur_Check_Write(pw1, Fail) 3024 *(S++) = *pw1; 3025 Next_Pp; 3026 3027 Case(Write_valueL, I_Write_valueL) 3028 Case(Push_valueL, I_Push_valueL) 3029 Get_Local(pw1) 3030 Occur_Check_Write(pw1, Fail) 3031 *(S++) = *pw1; 3032 Next_Pp; 3033 3034 Case(Write_valueTM, I_Write_valueTM) 3035 Case(Push_valueTM, I_Push_valueTM) 3036 Get_Temporary(pw1) 3037 Occur_Check_Write(pw1, Fail) 3038 *(S++) = *pw1; 3039 Next_Pp; 3040 3041 Case(Push_valueG, I_Push_valueG) 3042 S->tag.all = TREF; 3043 S->val.ptr = ByteOffsetPlus(S, PP++->offset); 3044 S++; 3045 Next_Pp; 3046 3047 Case(Push_local_valueAM, I_Push_local_valueAM) 3048 Get_Argument(pw1) 3049_push_local_: 3050 Move_Pw_To_Global_Stack(pw1,S, ;) 3051 Next_Pp; 3052 3053 Case(Push_local_valueL, I_Push_local_valueL) 3054 Get_Local(pw1) 3055 goto _push_local_; 3056 3057 Case(Push_local_valueTM, I_Push_local_valueTM) 3058 Get_Temporary(pw1) 3059 goto _push_local_; 3060 3061 Case(Write_local_valueAM, I_Write_local_valueAM) 3062 Get_Argument(pw1) 3063_write_local_: 3064 Move_Pw_To_Global_Stack(pw1,S, Occur_Check_Write(pw1, Fail)) 3065 Occur_Check_Boundary(0); 3066 Next_Pp; 3067 3068 Case(Write_local_valueL, I_Write_local_valueL) 3069 Get_Local(pw1) 3070 goto _write_local_; 3071 3072 Case(Write_local_valueTM, I_Write_local_valueTM) 3073 Get_Temporary(pw1) 3074 goto _write_local_; 3075 3076 3077 Case(Push_local_value2AM, I_Push_local_value2AM) 3078 Get_Argument(pw1) 3079 Get_Argument(pw2) 3080_push_local2_: 3081 Move_Pw_To_Global_Stack(pw1,S, ;) 3082 Move_Pw_To_Global_Stack(pw2,S, ;) 3083 Next_Pp; 3084 3085 Case(Push_local_value2L, I_Push_local_value2L) 3086 Get_Local(pw1) 3087 Get_Local(pw2) 3088 goto _push_local2_; 3089 3090 Case(Write_local_value2AM, I_Write_local_value2AM) 3091 Get_Argument(pw1) 3092 Get_Argument(pw2) 3093_write_local2_: 3094 Move_Pw_To_Global_Stack(pw1,S, Occur_Check_Write(pw1, Fail)) 3095 Occur_Check_Boundary(0); 3096 Move_Pw_To_Global_Stack(pw2,S, Occur_Check_Write(pw2, Fail)) 3097 Occur_Check_Boundary(0); 3098 Next_Pp; 3099 3100 Case(Write_local_value2L, I_Write_local_value2L) 3101 Get_Local(pw1) 3102 Get_Local(pw2) 3103 goto _write_local2_; 3104 3105 /* val, tag !!!!!! */ 3106 3107 Case(Write_constant, I_Write_constant) 3108 Case(Push_constant, I_Push_constant) 3109 S->val.all = PP++ -> all; 3110 ((S)++)->tag.all = PP++ -> all; 3111 Next_Pp; 3112 3113 Case(Write_nil, I_Write_nil) 3114 Case(Push_nil, I_Push_nil) 3115 ((S)++)->tag.kernel = TNIL; 3116 Next_Pp; 3117 3118 Case(Write_integer2, I_Write_integer2) 3119 S->val.nint = PP++->nint; 3120 ((S)++)->tag.kernel = TINT; 3121 /* falls through */ 3122 Case(Write_integer, I_Write_integer) 3123 Case(Push_integer, I_Push_integer) 3124 S->val.nint = PP++->nint; 3125 ((S)++)->tag.kernel = TINT; 3126 Next_Pp; 3127 3128#ifdef TFLOAT 3129 Case(Write_float, I_Write_float) 3130 Case(Push_float, I_Push_float) 3131 S->val.real = PP++->real; 3132 ((S)++)->tag.kernel = TFLOAT; 3133 Next_Pp; 3134#endif 3135 3136 Case(Write_did2, I_Write_did2) 3137 S->val.did = PP++->did; 3138 ((S)++)->tag.kernel = TDICT; 3139 /* falls through */ 3140 Case(Write_did, I_Write_did) 3141 S->val.did = PP++->did; 3142 ((S)++)->tag.kernel = TDICT; 3143 Next_Pp; 3144 3145 Case(Write_integerdid, I_Write_integerdid) 3146 S->val.nint = PP++->nint; 3147 ((S)++)->tag.kernel = TINT; 3148 S->val.did = PP++->did; 3149 ((S)++)->tag.kernel = TDICT; 3150 Next_Pp; 3151 3152 Case(Write_didinteger, I_Write_didinteger) 3153 S->val.did = PP++->did; 3154 ((S)++)->tag.kernel = TDICT; 3155 S->val.nint = PP++->nint; 3156 ((S)++)->tag.kernel = TINT; 3157 Next_Pp; 3158 3159 Case(Write_string, I_Write_string) 3160 Case(Push_string, I_Push_string) 3161 S->val.str = PP++->str; 3162 ((S)++)->tag.kernel = TSTRG; 3163 Next_Pp; 3164 3165 Case(Write_meta, I_Write_meta) 3166 pw1 = S; 3167 S = TG; 3168 TG = S + 2; 3169 pw1->val.ptr = S; 3170 pw1->tag.kernel = TREF; 3171 S->val.ptr = S; 3172 S->tag.kernel = PP++->kernel; 3173 Next_Pp; 3174 3175 Case(Write_first_list, I_Write_first_list) 3176 (--SP)->tag.kernel = MODE_WRITE; 3177 SP->val.ptr = S + 1; 3178 Check_Local_Overflow 3179 /* falls through */ 3180 Case(Write_list, I_Write_list) 3181 pw1 = S; 3182 S = TG; 3183 TG = S + 2; 3184 pw1->val.ptr = S; 3185 pw1->tag.kernel = TLIST; 3186 Next_Pp; 3187 3188 Case(Write_next_listTM, I_Write_next_listTM) 3189 Get_Temporary(pw1); 3190 pw1->val.ptr = S + 1; 3191 pw1 = S; 3192 S = TG; 3193 TG = S + 2; 3194 pw1->val.ptr = S; 3195 pw1->tag.kernel = TLIST; 3196 Next_Pp; 3197 3198 Case(Write_next_listTMlab, I_Write_next_listTMlab) 3199 Get_Temporary(pw1) 3200 if(pw1->tag.kernel == MODE_READ) { 3201 PP = PP->code; 3202 } else { 3203 S = (pw1->val.ptr)++; 3204 PP++; 3205 pw1 = S; 3206 S = TG; 3207 TG = S + 2; 3208 pw1->val.ptr = S; 3209 pw1->tag.kernel = TLIST; 3210 } 3211 Next_Pp; 3212 3213 Case(Push_list, I_Push_list) 3214 S->val.ptr = TG; 3215 ((S)++)->tag.kernel = TLIST; 3216 TG += 2; 3217 Next_Pp; 3218 3219 Case(Write_first_structure, I_Write_first_structure) 3220 (--SP)->tag.kernel = MODE_WRITE; 3221 SP->val.ptr = S + 1; 3222 Check_Local_Overflow 3223 /* falls through */ 3224 Case(Write_structure, I_Write_structure) 3225 S->val.ptr = TG; 3226 S->tag.kernel = TCOMP; 3227 S = TG; 3228 val_did = PP++->did; 3229 TG += DidArity(val_did) + 1; 3230 S->val.did = val_did; 3231 ((S)++)->tag.kernel = TDICT; 3232 Next_Pp; 3233 3234 Case(Write_next_structureTM, I_Write_next_structureTM) 3235 val_did = PP++->did; 3236 Get_Temporary(pw1); 3237 pw1->val.ptr = S + 1; 3238 S->val.ptr = TG; 3239 S->tag.kernel = TCOMP; 3240 S = TG; 3241 TG += DidArity(val_did) + 1; 3242 S->val.did = val_did; 3243 ((S)++)->tag.kernel = TDICT; 3244 Next_Pp; 3245 3246 Case(Write_next_structureTMlab, I_Write_next_structureTMlab) 3247 Get_Temporary_Offs(1, pw1) 3248 if(pw1->tag.kernel == MODE_READ) { 3249 PP = (PP+2)->code; 3250 } else { 3251 S = (pw1->val.ptr)++; 3252 S->val.ptr = TG; 3253 S->tag.kernel = TCOMP; 3254 S = TG; 3255 val_did = PP->did; 3256 TG += DidArity(val_did) + 1; 3257 S->val.did = val_did; 3258 ((S)++)->tag.kernel = TDICT; 3259 PP+=3; 3260 } 3261 Next_Pp; 3262 3263 Case(Push_structure, I_Push_structure) 3264 S->val.ptr = TG; 3265 ((S)++)->tag.kernel = TCOMP; 3266 TG = ByteOffsetPlus(TG, PP++->offset); 3267 Next_Pp; 3268 3269 Case(First, I_First) 3270 (--SP)->tag.kernel = MODE_WRITE; 3271 SP->val.ptr = S + 1; 3272 Check_Local_Overflow 3273 Next_Pp; 3274 3275 Case(NextTM, I_NextTM) 3276 Get_Temporary(pw1); 3277 pw1->val.ptr = S + 1; 3278 Next_Pp; 3279 3280 Case(ModeTM, I_ModeTM) 3281 Get_Temporary(pw1) 3282 S = pw1->val.ptr; 3283 Next_Pp; 3284 3285 Case(NextTMlab, I_NextTMlab) 3286 Get_Temporary(pw1) 3287 if(pw1->tag.kernel == MODE_READ) { 3288 PP = PP->code; 3289 } else { 3290 S = (pw1->val.ptr)++; 3291 PP++; 3292 } 3293 Next_Pp; 3294 3295 Case(ModeTMlab, I_ModeTMlab) 3296 Get_Temporary(pw1) 3297 S = pw1->val.ptr; 3298 if(pw1->tag.kernel == MODE_READ) { 3299 PP = PP->code; 3300 } else { 3301 PP++; 3302 } 3303 Next_Pp; 3304 3305 3306/**** Regular subgoal arguments instructions ****/ 3307 3308 Case(Put_variableAML, I_Put_variableAML) 3309 Get_Argument(pw2) 3310 Get_Local(pw1) 3311 pw1->val.ptr = pw1; 3312 pw1->tag.kernel = TREF; 3313 pw2->val.ptr = pw1; 3314 pw2->tag.kernel = TREF; 3315 Next_Pp; 3316 3317 Case(Put_variable2AM, I_Put_variable2AM) 3318 Get_Argument(pw1) 3319 pw1->val.ptr = TG; 3320 pw1->tag.kernel = TREF; 3321 pw1 = TG++; 3322 pw1->val.ptr = pw1; 3323 pw1->tag.kernel = TREF; 3324 /* falls through */ 3325 Case(Put_global_variableAM, I_Put_global_variableAM) 3326 Case(Put_variableAM, I_Put_variableAM) 3327 Get_Argument(pw1) 3328 pw1->val.ptr = TG; 3329 pw1->tag.kernel = TREF; 3330 pw1 = TG++; 3331 pw1->val.ptr = pw1; 3332 pw1->tag.kernel = TREF; 3333 Next_Pp; 3334 3335 Case(Put_global_variable2AML, I_Put_global_variable2AML) 3336 Get_Argument(pw1) 3337 Get_Local(pw2) 3338 pw1->val.ptr = pw2->val.ptr = TG; 3339 pw1->tag.kernel = pw2->tag.kernel = TREF; 3340 pw1 = TG++; 3341 pw1->val.ptr = pw1; 3342 pw1->tag.kernel = TREF; 3343 /* falls through */ 3344 Case(Put_global_variableAML, I_Put_global_variableAML) 3345 Get_Argument(pw1) 3346 Get_Local(pw2) 3347 pw1->val.ptr = pw2->val.ptr = TG; 3348 pw1->tag.kernel = pw2->tag.kernel = TREF; 3349 pw1 = TG++; 3350 pw1->val.ptr = pw1; 3351 pw1->tag.kernel = TREF; 3352 Next_Pp; 3353 3354 Case(Put_global_variableL, I_Put_global_variableL) 3355 Get_Local(pw1) 3356 pw1->val.ptr = TG; 3357 pw1->tag.kernel = TREF; 3358 pw1 = TG++; 3359 pw1->val.ptr = pw1; 3360 pw1->tag.kernel = TREF; 3361 Next_Pp; 3362 3363 Case(Put_named_variableAM, I_Put_named_variableAM) 3364 Get_Argument(pw1) 3365 pw1->val.ptr = TG; 3366 pw1->tag.kernel = TREF; 3367 pw1 = TG++; 3368 pw1->val.ptr = pw1; 3369 pw1->tag.kernel = PP++->kernel; 3370 Next_Pp; 3371 3372 Case(Put_named_variableAML, I_Put_named_variableAML) 3373 Get_Argument(pw1) 3374 Get_Local(pw2) 3375 pw1->val.ptr = pw2->val.ptr = TG; 3376 pw1->tag.kernel = pw2->tag.kernel = TREF; 3377 pw1 = TG++; 3378 pw1->val.ptr = pw1; 3379 pw1->tag.kernel = PP++->kernel; 3380 Next_Pp; 3381 3382 Case(Put_named_variableL, I_Put_named_variableL) 3383 Get_Local(pw1) 3384 pw1->val.ptr = TG; 3385 pw1->tag.kernel = TREF; 3386 pw1 = TG++; 3387 pw1->val.ptr = pw1; 3388 pw1->tag.kernel = PP++->kernel; 3389 Next_Pp; 3390 3391 Case(Put_referenceAM, I_Put_referenceAM) 3392 Get_Argument(pw1) 3393 S = TG; 3394 TG = ByteOffsetPlus(TG, PP++->offset); 3395 pw1->val.ptr = S; 3396 pw1->tag.kernel = TREF; 3397 S->val.ptr = S; 3398 S->tag.kernel = PP++->kernel; 3399 Next_Pp; 3400 3401 /* temporary */ 3402 Case(Put_referenceAML, I_Put_referenceAML) 3403 Get_Argument(pw2) 3404 Get_Local(pw1) 3405 S = TG; 3406 TG = ByteOffsetPlus(TG, PP++->offset); 3407 pw1->val.ptr = S; 3408 pw1->tag.kernel = TREF; 3409 pw2->val.ptr = S; 3410 pw2->tag.kernel = TREF; 3411 S->val.ptr = S; 3412 S++->tag.kernel = PP++->kernel; 3413 Next_Pp; 3414 3415 Case(Put_unsafe_valueAMTM, I_Put_unsafe_valueAMTM) 3416 Get_Argument(pw2) 3417 Get_Temporary(pw1) 3418 /* temporaries are always popped, no matter if nondet or not */ 3419 goto _globalize_if_needed_; 3420 3421 Case(Put_unsafe_valueAML, I_Put_unsafe_valueAML) 3422 Get_Argument(pw2) 3423 Get_Local(pw1) 3424 if(E < EB) { 3425_globalize_if_needed_: 3426 Dereference_Pw_Tag(pw1,tmp1) 3427 if(ISVar(tmp1)) { 3428 if (pw1 < E && pw1 >= SP && pw1 < EB) { 3429 pw1->val.ptr = pw2->val.ptr = TG; 3430 /* pw1->tag.kernel = TREF; */ 3431 pw2->tag.kernel = TREF; 3432 pw1 = TG++; 3433 pw1->val.ptr = pw1; 3434 pw1->tag.kernel = TREF; 3435 } else { 3436 pw2->val.ptr = pw1; 3437 pw2->tag.kernel = TREF; 3438 } 3439 } else { 3440 pw2->val.all = pw1->val.all; 3441 pw2->tag.kernel = tmp1; 3442 } 3443 } else { 3444 *pw2 = *pw1; 3445 } 3446 Next_Pp; 3447 3448 /* AM, tag, val */ 3449 3450 Case(Put_constantAM, I_Put_constantAM) 3451 Get_Argument(pw1); 3452 pw1 -> tag.all = PP++ -> all; 3453 pw1 -> val.all = PP++ -> all; 3454 Next_Pp; 3455 3456 Case(Put_nilAM, I_Put_nilAM) 3457 Get_Argument(pw1) 3458 pw1->tag.kernel = TNIL; 3459 Next_Pp; 3460 3461 Case(Put_integerAM, I_Put_integerAM) 3462 Get_Argument(pw1); 3463 pw1->val.nint = PP++->nint; 3464 pw1->tag.kernel = TINT; 3465 Next_Pp; 3466 3467#ifdef TFLOAT 3468 Case(Put_floatAM, I_Put_floatAM) 3469 Get_Argument(pw1); 3470 pw1->val.real = PP++->real; 3471 pw1->tag.kernel = TFLOAT; 3472 Next_Pp; 3473#endif 3474 3475 Case(Put_atomAM, I_Put_atomAM) 3476 Get_Argument(pw1); 3477 pw1->val.did = PP++->did; 3478 pw1->tag.kernel = TDICT; 3479 Next_Pp; 3480 3481 Case(Put_moduleAM, I_Put_moduleAM) 3482 Get_Argument(pw1); 3483 Make_Marked_Module(pw1, PP->did); 3484 ++PP; 3485 Next_Pp; 3486 3487 Case(Put_stringAM, I_Put_stringAM) 3488 Get_Argument(pw1); 3489 pw1->val.str = PP++->str; 3490 pw1->tag.kernel = TSTRG; 3491 Next_Pp; 3492 3493 Case(Put_listAM, I_Put_listAM) 3494 Get_Argument(pw1) 3495 S = TG; 3496 TG = S + 2; 3497 pw1->val.ptr = S; 3498 pw1->tag.kernel = TLIST; 3499 Next_Pp; 3500 3501 Case(Put_structureAM, I_Put_structureAM) 3502 Get_Argument(pw1) 3503 S = TG; 3504 pw1->val.ptr = S; 3505 pw1->tag.kernel = TCOMP; 3506 val_did = PP++->did; 3507 TG += DidArity(val_did) + 1; 3508 S->val.did = val_did; 3509 ((S)++)->tag.kernel = TDICT; 3510 Next_Pp; 3511 3512 Case(Puts_variable, I_Puts_variable) 3513 (--SP)->tag.kernel = TREF; 3514 SP->val.ptr = SP; 3515 Check_Local_Overflow 3516 Next_Pp; 3517 3518 Case(Puts_variableL, I_Puts_variableL) 3519 Get_Local(pw1) 3520 (--SP)->tag.kernel = TREF; 3521 SP->val.ptr = pw1; 3522 Check_Local_Overflow 3523 pw1->val.ptr = pw1; 3524 pw1->tag.kernel = TREF; 3525 Next_Pp; 3526 3527 Case(Puts_reference, I_Puts_reference) 3528 S = TG; 3529 TG = ByteOffsetPlus(TG, PP++->offset); 3530 (--SP)->val.ptr = S; 3531 SP->tag.kernel = TREF; 3532 Check_Local_Overflow 3533 S->val.ptr = S; 3534 S->tag.kernel = PP++->kernel; 3535 Next_Pp; 3536 3537 Case(Puts_referenceL, I_Puts_referenceL) 3538 Get_Local(pw1) 3539 S = TG; 3540 TG = ByteOffsetPlus(TG, PP++->offset); 3541 (--SP)->val.ptr = S; 3542 SP->tag.kernel = TREF; 3543 Check_Local_Overflow 3544 pw1->val.ptr = S; 3545 pw1->tag.kernel = TREF; 3546 S->val.ptr = S; 3547 S++->tag.kernel = PP++->kernel; 3548 Next_Pp; 3549 3550 Case(Puts_valueAM, I_Puts_valueAM) 3551 Get_Argument(pw1) 3552 Dereference_Pw(pw1) 3553 *(--SP) = *pw1; 3554 Check_Local_Overflow 3555 Next_Pp; 3556 3557 Case(Puts_valueL, I_Puts_valueL) 3558 Get_Local(pw1) 3559 Dereference_Pw(pw1) 3560 *(--SP) = *pw1; 3561 Check_Local_Overflow 3562 Next_Pp; 3563 3564 Case(Puts_valueTM, I_Puts_valueTM) 3565 Get_Temporary(pw1) 3566 Dereference_Pw(pw1) 3567 *(--SP) = *pw1; 3568 Check_Local_Overflow 3569 Next_Pp; 3570 3571 Case(Puts_valueG, I_Puts_valueG) 3572 (--SP)->tag.all = TREF; 3573 SP->val.ptr = ByteOffsetPlus(S, PP++->offset); 3574 Check_Local_Overflow 3575 Next_Pp; 3576 3577 /* tag, val */ 3578 3579 Case(Puts_constant, I_Puts_constant) 3580 (--SP) -> tag.all = PP++ -> all; 3581 SP -> val.all = PP++ -> all; 3582 Next_Pp; 3583 3584 Case(Puts_nil, I_Puts_nil) 3585 (--SP)->tag.kernel = TNIL; 3586 Check_Local_Overflow 3587 Next_Pp; 3588 3589 Case(Puts_integer, I_Puts_integer) 3590 (--SP)->tag.kernel = TINT; 3591 SP->val.nint = PP++->nint; 3592 Check_Local_Overflow 3593 Next_Pp; 3594 3595#ifdef TFLOAT 3596 Case(Puts_float, I_Puts_float) 3597 (--SP)->tag.kernel = TFLOAT; 3598 SP->val.real = PP++->real; 3599 Check_Local_Overflow 3600 Next_Pp; 3601#endif 3602 3603 Case(Puts_atom, I_Puts_atom) 3604 (--SP)->tag.kernel = TDICT; 3605 SP->val.did = PP++->did; 3606 Check_Local_Overflow 3607 Next_Pp; 3608 3609 Case(Puts_string, I_Puts_string) 3610 (--SP)->tag.kernel = TSTRG; 3611 SP->val.str = PP++->str; 3612 Check_Local_Overflow 3613 Next_Pp; 3614 3615 Case(Puts_list, I_Puts_list) 3616 S = TG; 3617 TG += 2; 3618 (--SP)->tag.kernel = TLIST; 3619 SP->val.ptr = S; 3620 Check_Local_Overflow 3621 Next_Pp; 3622 3623 Case(Puts_structure, I_Puts_structure) 3624 S = TG; 3625 (--SP)->tag.kernel = TCOMP; 3626 SP->val.ptr = S; 3627 Check_Local_Overflow 3628 val_did = PP++->did; 3629 TG += DidArity(val_did) + 1; 3630 S->val.did = val_did; 3631 ((S)++)->tag.kernel = TDICT; 3632 Next_Pp; 3633 3634 /* this is really the same as Puts_integer, but the parameter type 3635 * is different (important for disasm/fcompile). We cannot share the 3636 * code because then threaded code disassembles to the same instruction 3637 */ 3638 Case(Puts_proc, I_Puts_proc) 3639 (--SP)->tag.kernel = TINT; 3640 SP->val.nint = PP++->nint; 3641 Check_Local_Overflow 3642 Next_Pp; 3643 3644 3645/*********************************************** 3646 * OR-level instructions 3647 3648 ECLiPSe 5.X compiler: 3649 3650 Main sequence for clause choicepoints: 3651 Try_me_else debug arity elselabel 3652 <clause1> 3653 Retry_me_else debug elselabel 3654 <clause2> 3655 Trust_me debug 3656 <clause3> 3657 3658 Sub-sequences: 3659 Try debug arity melabel 3660 Retry debug melabel 3661 Trust debug melabel 3662 3663 Sub-sequence can share tails via: 3664 Trylab debug arity melabel elselabel 3665 3666 Retrylab debug melabel elselabel 3667 3668 Trust debug melabel 3669 3670 Inline disjunctions (no subsequences used): 3671 Try_me_else debug arity elselabel 3672 <branch1> 3673 Retry_me_inline debug elselabel EAM 3674 <branch2> 3675 Trust_me_inline debug EAM 3676 <branch3> 3677 3678 3679 ECLiPSe 6.X compiler: 3680 3681 Main sequences: 3682 Try_me_else debug arity elselabel 3683 <branch1> 3684 Retry_me_inline debug elselabel EAM 3685 <branch2> 3686 Trust_me_inline debug EAM 3687 <branch3> 3688 3689 Sub-sequences: 3690 Try debug arity melabel 3691 Retry_inline debug melabel EAM 3692 Trust_inline debug melabel EAM 3693 3694 ***********************************************/ 3695 3696#define BChpParArgs(top) ((pword *) (ChpPar(BPrev(top)) + 1)) 3697#define BChpArgs(top) ((pword *) (Chp(BPrev(top)) + 1)) 3698#define BLastArg(top) ((pword *) BTop(top) - 1) 3699 3700 3701 Case(Trust, I_Trust) /* debug,alt */ 3702 back_code = PP; 3703 DBG_PORT = PP->nint; 3704 PP = PP[1].code; 3705 goto _trust_me_; 3706 3707 Case(Trust_me_inline, I_Trust_me_inline) /* debug,envsize */ 3708 back_code = PP; 3709 DBG_PORT = PP->nint; 3710 PP += 2; 3711 goto _trust_me_; 3712 3713 /* Operationally the same as Trust, but points to a branch of an 3714 * inline disjunction rather than a clause. 3715 * We must make sure that the C compiler does not merge Trust and 3716 * Trust_inline, because the opcodes must remain distinguishable! */ 3717 Case(Trust_inline, I_Trust_inline) /* debug,alt,envsize */ 3718 back_code = PP; 3719 /* next line has redundant | to make code different from Trust */ 3720 DBG_PORT = PP->nint | INLINE_PORT; 3721 PP = PP[1].code; 3722 goto _trust_me_; 3723 3724 Case(Trust_me, I_Trust_me) /* debug */ 3725 back_code = PP; 3726 DBG_PORT = PP++->nint; 3727_trust_me_: /* (back_code,PP,DBG_PORT) */ 3728#ifdef NEW_ORACLE 3729 if (FO && NTRY==0) 3730 goto _recomp_err_; 3731#endif 3732 pw2 = BChpArgs(B.args); 3733 Record_Next_Alternative; 3734_pop_choice_point_: /* (pw2 points to arguments,DBG_PORT) */ 3735 /* Tracer hook before failure: save debug stack data to FTRACE */ 3736 if (TD) /* find out how deep we fail */ 3737 { 3738 FDROP = 0; 3739 if (!OldStamp(&TD[TF_CHP_STAMP])) 3740 FCULPRIT = DInvoc(TD); 3741 for (pw1 = TD; pw1 && !OldStamp(&pw1[TF_CHP_STAMP]); pw1 = DAncestor(pw1), ++FDROP) 3742 { 3743 /*p_fprintf(log_output_, "\n(%d) %d fail", DInvoc(pw1), DLevel(pw1));*/ 3744 if (FDROP < MAX_FAILTRACE) 3745 { 3746 FTRACE[FDROP].invoc = DInvoc(pw1); 3747 FTRACE[FDROP].proc = DProc(pw1); 3748 FTRACE[FDROP].source_pos.file = DPath(pw1); 3749 FTRACE[FDROP].source_pos.line = DLine(pw1); 3750 FTRACE[FDROP].source_pos.from = DFrom(pw1); 3751 FTRACE[FDROP].source_pos.to = DTo(pw1); 3752 } 3753 } 3754 RLEVEL = pw1 ? DLevel(pw1) : -1; 3755 DBG_DELAY_INVOC = 0; /* if set for DEBUG_DELAY_EVENT */ 3756 } 3757 else { RLEVEL = -1; FDROP = 0; } 3758 3759 b_aux.top = BTop(B.args); 3760 tmp1 = b_aux.args-pw2; /* arity */ 3761 pw1 = &A[1]; 3762 while (pw2 < b_aux.args) { 3763 *pw1++ = *pw2++; 3764 } 3765 pw2 = BPrev(B.args); 3766 /* note the order: untrail, then reset stack pointers */ 3767 Untrail_Variables(Chp(pw2)->tt, i, pw1); 3768 SP = Chp(pw2)->sp; 3769 E = Chp(pw2)->e; 3770 LD = Chp(pw2)->ld; 3771 Wipe(Chp(pw2)->tg,TG); 3772 TG = Chp(pw2)->tg; 3773 Adjust_GcTg_and_TgSl(TG); 3774 Reset_Unify_Exceptions 3775 Set_Det 3776 Reset_DE; 3777 Debug_Check_Global 3778 3779 /* Tracer hook after failure: 3780 * Here we trace one or more FAIL, one or more REDO, and a single 3781 * NEXT or ELSE (modulo some of these ports being filtered out). 3782 * At this point the true debugger stack may already be empty, 3783 * but we still may have to trace some FAIL ports (FDROP>0). 3784 * We exploit the choicepoint for state-saving across the call to 3785 * the DEBUG_REDO_EVENT handler (which must fail): we keep the 3786 * choicepoint around, and arrange for the same Trust* instruction 3787 * to be executed once more after handler return. To suppress the 3788 * debug handler to be called again, we set the TF_REDO flag in 3789 * the top trace frame. 3790 */ 3791 if (FDROP > 0 && PortWanted(FAIL_PORT)) 3792 goto _trace_trust_; 3793 if (TD) 3794 { 3795 if (RLEVEL != DLevel(TD) && PortWanted(PREDO_PORT)) 3796 goto _trace_trust_; /* not 2nd time */ 3797 if (Unskipped(TD)) 3798 { 3799 if (!(TfFlags(TD) & TF_REDO) && (DBG_PORT&PORT_MASK) && PortWanted(DBG_PORT&PORT_MASK)) 3800 goto _trace_trust_; 3801 Clr_Tf_Flag(TD, TF_REDO); 3802 } 3803 } 3804 EB = BChp(pw2)->sp; /* finish resetting state */ 3805 GB = BChp(pw2)->tg; 3806 B.args = pw2; /* and pop the choicepoint */ 3807 Next_Pp; 3808 3809_trace_trust_: /* (DBG_PORT,FDROP,RLEVEL,tmp1) */ 3810 /* Make it look as if retrying the Trust instructions. Note that 3811 * setting the BP field is necessary in exotic cases like notnot, 3812 * where the trust instruction is not reached via a failure! */ 3813 BBp(B.args) = (vmcode *) back_code-1; 3814 EB = SP; GB = TG; 3815 Push_Witness; 3816_trace_redo_: /* (DBG_PORT,FDROP,RLEVEL,tmp1) */ 3817 if (TD) 3818 Set_Tf_Flag(TD, TF_REDO); 3819 /* After a clause choicepoint we must push an auxiliary 3820 * empty environment to be able to make the handler call. 3821 * In case of an inline choicepoint we can insert a call directly. 3822 * Note that the environment size in front of the Failure 3823 * continuation is zero, but the environment will still get 3824 * marked correctly because the choicepoints still points to 3825 * this alternative and has a correct environment map. 3826 */ 3827 if (!(DBG_PORT & INLINE_PORT)) 3828 { 3829 Push_Env 3830 } 3831 Push_Ret_Code((emu_code)&fail_return_env_0_[1]) 3832 Check_Local_Overflow 3833 Set_Det 3834 proc = error_handler_[-(DEBUG_REDO_EVENT)]; 3835 PP = (emu_code) PriCode(proc); 3836 A[1] = TAGGED_TD; 3837 Make_Integer(&A[2], FDROP); 3838 Make_Integer(&A[3], RLEVEL); 3839 Make_Integer(&A[4], FAIL_PORT); 3840 Make_Integer(&A[5], DBG_PORT&PORT_MASK); /* NO/NEXT/ELSE_PORT */ 3841 Next_Pp; 3842 3843 3844 3845 /* 3846 * We assume that Try_parallel, Retry_seq, and Retry_par 3847 * appear always in sequence. 3848 * 3849 * Note about LOAD register: 3850 * LOAD == 0 No unpublished parallel choicepoints 3851 * LOAD > 0 At most LOAD unpublished parallel choicepoints 3852 * (not precise because it is not updated at cuts) 3853 * LOAD < 0 Delayed load release phase 3854 */ 3855/*-----------------------------------------------------------------------*/ 3856 Case(Try_parallel, I_Try_parallel) /* nalt arity table */ 3857/*-----------------------------------------------------------------------*/ 3858 tmp1 = PP[1].nint; /* arity */ 3859 back_code = PP + 3; /* &Retry_seq */ 3860#ifdef NEW_ORACLE 3861 err_code = 0; 3862 if (FO) /* we are following */ 3863 { 3864 if (NTRY > 1) { /* old counter not expired */ 3865 NTRY--; 3866 } else if (FoIsStop(i=FoHeader(FO))) { /* end of oracle */ 3867 goto _recomp_err_; 3868 } else if (FoIsCount(i)) { /* new counter */ 3869 NTRY = FoCount(FO,i); 3870 } else if (!FoIsPar(i)) { 3871 goto _recomp_err_; 3872 } else { /* follow given alternative */ 3873 NTRY = 0; 3874 err_code = FoIsCreate(i) ? O_FROM_ORACLE 3875 : O_FROM_ORACLE|O_NOCREATE; 3876 i = FoAlt(FO,i); 3877 if (PP[2].code) { /* static par chp */ 3878 PP = PP[2].code[i].code; 3879 } else { 3880 A[1].val.nint = i; 3881 A[1].tag.kernel = TINT; 3882 PP = (emu_code) fork_unify_code_; 3883 } 3884 goto _try_par_1_; 3885 } 3886 } 3887#endif 3888 if (PP[2].code) /* static par chp */ 3889 { 3890 i = PP[0].nint; /* nalt */ 3891 PP = PP[2].code[i].code; 3892 } 3893 else 3894 { 3895 pw2 = pw1 = &A[1]; /* fork/2 */ 3896 Dereference_Pw(pw1) 3897 /* assume argument is already checked for integer > 1 */ 3898 /* store deref value in chp, otherwise gc/copy problem */ 3899 i = pw2->val.nint = pw1->val.nint; 3900 pw2->tag.kernel = TINT; 3901 PP = (emu_code) fork_unify_code_; 3902 } 3903#ifdef NEW_ORACLE 3904_try_par_1_: /* (i:alt, tmp1:arity, back_code, err_code) */ 3905 Record_Alternative(i, O_PAR_ORACLE|(err_code & O_FROM_ORACLE? 0: O_SHALLOW)); 3906 if (err_code & O_NOCREATE) { Next_Pp; } 3907#endif 3908 /* create the choicepoint */ 3909 Clr_Det; 3910 pw1 = B.args; 3911 ChpPar(pw1)->sp = EB = SP; 3912 ChpPar(pw1)->tg = GB = TG; 3913 Push_Witness 3914 Adjust_GcTg_and_TgSl(TG); 3915 ChpPar(pw1)->tt = TT; 3916 ChpPar(pw1)->e = E; 3917 ChpPar(pw1)->ld = LD; 3918 ChpPar(pw1)->alt = i; 3919#ifdef PB_MAINTAINED 3920 ChpPar(pw1)->ppb = PB; 3921#else 3922 ChpPar(pw1)->ppb = (pword *) 0; 3923#endif 3924#ifdef NEW_ORACLE 3925 if (err_code & O_FROM_ORACLE) 3926 { 3927 Fo_Node(FO, &ChpPar(pw1)->node); 3928 } 3929#endif 3930 pw1 = (pword *) (ChpPar(pw1) + 1); 3931 for (pw2 = &A[1]; tmp1 > 0; tmp1--) 3932 *pw1++ = *pw2++; 3933 Top(pw1)->backtrack = (vmcode *) back_code; /* &Retry_seq */ 3934 Top(pw1)->frame = B.any_frame; 3935 B.top = Top(pw1) + 1; 3936#ifdef PB_MAINTAINED 3937 PB = B.args; 3938#endif 3939 /* Clr_Det (moved up) */ 3940 Check_Control_Overflow 3941#ifdef NEW_ORACLE 3942 if (FO && FoEnd(FO)) /* end of oracle following */ 3943 { 3944 Export_All 3945 end_of_oracle(); 3946 Import_All 3947 Next_Pp; 3948 } 3949#endif 3950 if (LEAF && i > 1 && !PO) 3951 { 3952 if (LOAD == 0) 3953 { 3954 if ((LOAD = LoadReleaseDelay) < 0) /* init countdown */ 3955 { 3956 Start_Countdown(); 3957 Fake_Overflow; 3958 } 3959 else 3960 { 3961 /* LOAD = 1; */ 3962 Export_B_Sp_Tg_Tt 3963 sch_load_report(LEAF); 3964 Import_None 3965 } 3966 } 3967 else if (LOAD < 0) 3968 { 3969 /* We have two Try_parallel in quick succession: 3970 * Abort countdown, report the load immediately */ 3971 Stop_Countdown(); 3972 LOAD = 2; 3973 Export_B_Sp_Tg_Tt 3974 sch_load_report(LEAF); 3975 Import_None 3976 } 3977 else 3978 ++LOAD; /* count chp */ 3979 } 3980 Next_Pp; 3981 3982/*-----------------------------------------------------------------------*/ 3983 Case(Retry_seq, I_Retry_seq) /* table */ 3984/*-----------------------------------------------------------------------*/ 3985#ifdef NEW_ORACLE 3986 if (FO && NTRY==0) 3987 goto _recomp_err_; 3988#endif 3989 pw1 = BPrev(B.args); 3990 tmp1 = ChpPar(pw1)->alt - 1; /* next alternative number */ 3991 pw2 = BChpParArgs(B.args); 3992 if (PP[0].code) 3993 PP = PP[0].code[tmp1].code; /* clause address */ 3994 else 3995 { 3996 PP = (emu_code) fork_unify_code_; /* it's a fork/2 chp */ 3997 pw2->tag.kernel = TINT; 3998 pw2->val.nint = tmp1; 3999 } 4000 Update_Recorded_Alternative(tmp1); 4001 if (tmp1 > 1) { 4002 ChpPar(pw1)->alt = tmp1; 4003 DBG_PORT = NO_PORT; 4004 if (LOAD < 0) 4005 LOAD = LoadReleaseDelay; /* reinit countdown */ 4006 back_code = (emu_code) BBp(B.args); /* backtrack to same point */ 4007 goto _read_choice_point_; /* (pw2,err_code,back_code) */ 4008 } else { 4009#ifdef PB_MAINTAINED 4010 PB = ChpPar(pw1)->ppb; 4011#endif 4012 DBG_PORT = NO_PORT; 4013 if (LOAD < 0) 4014 { 4015 Stop_Countdown(); /* exhausted before released */ 4016 LOAD = 0; 4017 } 4018 else if (LOAD > 0) 4019 { 4020 --LOAD; /* keep load updated */ 4021 } 4022 goto _pop_choice_point_; /* (pw2,DBG_PORT) */ 4023 } 4024 4025 /* Retry_par &table 4026 * is split into two instructions while the handler is in Prolog: 4027 * Fail_clause 2 4028 * Try_clause &table 4029 */ 4030/*-----------------------------------------------------------------------*/ 4031 Case(Fail_clause, I_Fail_clause) /* envsize(=2) */ 4032/*-----------------------------------------------------------------------*/ 4033#ifdef NEW_ORACLE 4034 if (FO && NTRY==0) 4035 goto _recomp_err_; 4036#endif 4037#ifdef PROLOG_SCHED 4038 proc = error_handler_[-(FAIL_TO_PAR_CHP)]; 4039 pw2 = (B.top - 1)->frame.args; /* partially restore state */ 4040 Untrail_Variables(ChpPar(pw2)->tt, i, pw1); 4041 SP = EB = ChpPar(pw2)->sp; 4042 Wipe(ChpPar(pw2)->tg,TG); 4043 TG = GB = ChpPar(pw2)->tg; 4044 Adjust_GcTg_and_TgSl(TG); 4045 LD = ChpPar(pw2)->ld; 4046 E = ChpPar(pw2)->e; 4047 /* no need to restore arguments */ 4048 Reset_Unify_Exceptions 4049 Reset_DE; 4050 /* don't reset Det flag */ 4051 4052 /* Call the handler */ 4053 4054 Push_Env /* Allocate 1 */ 4055 (--SP)->tag.kernel = TCUT; /* Y1 = cut */ 4056 SP->val.ptr = B.args; 4057 (--SP)->tag.kernel = TREF; /* Y2 = Alt */ 4058 SP->val.ptr = SP; 4059 A[3].val.ptr = SP; 4060 A[3].tag.kernel = TREF; 4061 (--SP)->tag.kernel = TREF; /* Y3 = FailCnt */ 4062 SP->val.ptr = SP; 4063 A[2].val.ptr = SP; 4064 A[2].tag.kernel = TREF; 4065 Push_Ret_Code(PP + 1) /* Try_clause */ 4066 Check_Local_Overflow 4067 4068 A[1].val.ptr = B.args; 4069 A[1].tag.kernel = TCUT; 4070 4071 Set_Det 4072 PP = (emu_code) PriCode(proc); 4073#else /* if !PROLOG_SCHED */ 4074 PP++; /* skip environment size */ 4075 if (LOAD < 0) { 4076 Stop_Countdown(); 4077 } 4078 LOAD = 0; 4079 Export_All 4080 get_job(); 4081 Import_All 4082#endif /* PROLOG_SCHED */ 4083 Next_Pp; 4084 4085 4086/*-----------------------------------------------------------------------*/ 4087 Case(Try_clause, I_Try_clause) /* table */ 4088/*-----------------------------------------------------------------------*/ 4089#ifdef PROLOG_SCHED 4090 BAlt(B.args) = (E - 2)->val.nint; /* scheduled alternative */ 4091 pw1 = (E - 1)->val.ptr; /* cut the handler */ 4092 Cut_To(pw1) 4093 for (tmp1 = (E - 3)->val.nint; tmp1; --tmp1) 4094 { 4095 PPB = BPar(PPB)->ppb; /* pop */ 4096 } 4097#ifdef PB_MAINTAINED 4098 PB = 4099#endif 4100 B.args = PPB; 4101 Pop_Env 4102#endif /* PROLOG_SCHED */ 4103 /* get alternative from oracle or choicepoint */ 4104 tmp1 = BAlt(B.args); 4105 4106 if (tmp1) 4107 { 4108 pw2 = BChpParArgs(B.args); 4109 if (PP[0].code) 4110 PP = PP[0].code[tmp1].code; /* clause address */ 4111 else 4112 { 4113 PP = (emu_code) fork_unify_code_; /* it's a fork/2 chp */ 4114 pw2->tag.kernel = TINT; 4115 pw2->val.nint = tmp1; 4116 } 4117 DBG_PORT = NO_PORT; 4118 if (PPB < B.args) { 4119 goto _pop_choice_point_; /* (pw2,DBG_PORT) */ 4120 } else { 4121 back_code = (emu_code) BBp(B.args); /* leave unchanged */ 4122 goto _read_choice_point_; /* (pw2,DBG_PORT,back_code) */ 4123 } 4124 } 4125 else /* fail through */ 4126 { 4127 PPB = (B.top-1)->frame.chp_par->ppb; 4128 goto _do_refail_; 4129 } 4130 4131 4132/*-----------------------------------------------------------------------*/ 4133 Case(Try_me_else, I_Try_me_else) /* debug arity alt */ 4134/*-----------------------------------------------------------------------*/ 4135 tmp1 = PP[1].nint; 4136 back_code = PP[2].code; 4137 PP += 3; 4138_make_choice_point_: /* (arity in tmp1, back_code) */ 4139#ifdef NEW_ORACLE 4140 err_code = 0; 4141 if (FO) /* we are following */ 4142 { 4143 if (NTRY > 1) { /* old counter not expired */ 4144 NTRY--; 4145 } else if (FoIsStop(i=FoHeader(FO))) { /* end of oracle */ 4146 goto _recomp_err_; 4147 } else if (FoIsCount(i)) { /* new counter */ 4148 NTRY = FoCount(FO,i); 4149 } else if (FoIsPar(i)) { 4150 goto _recomp_err_; 4151 } else { /* follow given alternative */ 4152 NTRY = 0; 4153 err_code = FoIsCreate(i) ? O_FROM_ORACLE 4154 : O_FROM_ORACLE|O_NOCREATE; 4155 i = FoAlt(FO,i); 4156 Find_Alternative(i); /* update PP and back_code */ 4157 goto _try_1_; 4158 } 4159 } 4160 i=1; 4161_try_1_: 4162 Record_Alternative(i, err_code & O_FROM_ORACLE? 0 : O_SHALLOW); 4163 if (err_code & O_NOCREATE) { Next_Pp; } 4164#endif 4165 if (!Deterministic) { 4166 Repush_Ret_Code; /* multiple try's in a first chunk */ 4167 } 4168 Clr_Det 4169 pw1 = B.args; 4170 Chp(pw1)->sp = EB = SP; 4171 Chp(pw1)->tg = GB = TG; 4172 Push_Witness 4173 Chp(pw1)->tt = TT; 4174 Chp(pw1)->e = E; 4175 Chp(pw1)->ld = LD; 4176 pw1 = (pword *) (Chp(pw1) + 1); 4177 for (pw2 = &A[1]; tmp1 > 0; tmp1--) 4178 *pw1++ = *pw2++; 4179 Top(pw1)->backtrack = (vmcode *) back_code; 4180 Top(pw1)->frame = B.any_frame; 4181 B.top = Top(pw1) + 1; 4182 Check_Control_Overflow 4183 Next_Pp; 4184 4185 Case(Try, I_Try) /* debug arity clause */ 4186 tmp1 = PP[1].nint; 4187 back_code = PP + 3; 4188 PP = PP[2].code; 4189 goto _make_choice_point_; 4190 4191 Case(Trylab, I_Trylab) /* debug arity clause alt */ 4192 tmp1 = PP[1].nint; 4193 back_code = PP[3].code; 4194 PP = PP[2].code; 4195 goto _make_choice_point_; 4196 4197 Case(Retry_me_inline, I_Retry_me_inline) /* debug alt envsize */ 4198 DBG_PORT = PP->nint; 4199 back_code = PP[1].code; 4200 PP += 3; /* skip debug-flag, label and env size */ 4201 goto _retry_me_; /* (DBG_PORT,back_code) */ 4202 4203 Case(Retry_me_else, I_Retry_me_else) /* debug alt */ 4204 DBG_PORT = PP->nint; 4205 back_code = PP[1].code; 4206 PP += 2; 4207_retry_me_: /* (PP,DBG_PORT,back_code) */ 4208 pw2 = BChpArgs(B.args); 4209 Record_Next_Alternative; 4210#ifdef NEW_ORACLE 4211 if (FO && NTRY==0) 4212 goto _recomp_err_; 4213#endif 4214_read_choice_point_: /* (pw2 points to args, DBG_PORT,back_code) */ 4215 /* Tracer hook before failure: save debug stack data to FTRACE */ 4216 if (TD) /* find out how deep we fail */ 4217 { 4218 FDROP = 0; 4219 if (!OldStamp(&TD[TF_CHP_STAMP])) 4220 FCULPRIT = DInvoc(TD); 4221 for (pw1 = TD; pw1 && !OldStamp(&pw1[TF_CHP_STAMP]); pw1 = DAncestor(pw1), ++FDROP) 4222 { 4223 /*p_fprintf(log_output_, "\n(%d) %d fail", DInvoc(pw1), DLevel(pw1));*/ 4224 if (FDROP < MAX_FAILTRACE) 4225 { 4226 FTRACE[FDROP].invoc = DInvoc(pw1); 4227 FTRACE[FDROP].proc = DProc(pw1); 4228 FTRACE[FDROP].source_pos.file = DPath(pw1); 4229 FTRACE[FDROP].source_pos.line = DLine(pw1); 4230 FTRACE[FDROP].source_pos.from = DFrom(pw1); 4231 FTRACE[FDROP].source_pos.to = DTo(pw1); 4232 } 4233 } 4234 RLEVEL = pw1 ? DLevel(pw1) : -1; 4235 DBG_DELAY_INVOC = 0; /* if set for DEBUG_DELAY_EVENT */ 4236 } 4237 else { RLEVEL = -1; FDROP = 0; } 4238 4239 b_aux.top = BTop(B.args); 4240 tmp1 = b_aux.args-pw2; /* arity */ 4241 pw1 = &A[1]; 4242 while (pw2 < b_aux.args) { 4243 *pw1++ = *pw2++; 4244 } 4245 pw2 = BPrev(B.args); 4246 Untrail_Variables(Chp(pw2)->tt, i, pw1); 4247 SP = EB = Chp(pw2)->sp; 4248 Wipe(Chp(pw2)->tg,TG); 4249 TG = GB = Chp(pw2)->tg; 4250 Push_Witness 4251 Adjust_GcTg_and_TgSl(TG); 4252 LD = Chp(pw2)->ld; 4253 E = Chp(pw2)->e; 4254 Reset_Unify_Exceptions 4255 Clr_Det 4256 Reset_DE; 4257 Debug_Check_Global 4258 4259 /* Tracer hook after failure: call DEBUG_REDO_EVENT handler. 4260 * Don't update the alternative if calling the trace handler 4261 * vecause the retry instruction will be executed again! */ 4262 if (FDROP > 0 && PortWanted(FAIL_PORT)) 4263 goto _trace_redo_; 4264 if (TD) 4265 { 4266 if (RLEVEL != DLevel(TD) && PortWanted(PREDO_PORT)) 4267 goto _trace_redo_; 4268 if (Unskipped(TD)) 4269 { 4270 if (!(TfFlags(TD) & TF_REDO) && (DBG_PORT&PORT_MASK) && PortWanted(DBG_PORT&PORT_MASK)) 4271 goto _trace_redo_; 4272 Clr_Tf_Flag(TD, TF_REDO); 4273 } 4274 } 4275 /* not debugging, update the alternative */ 4276 BBp(B.args) = (vmcode *) back_code; 4277 Next_Pp; 4278 4279 Case(Retry, I_Retry) /* debug clause */ 4280 DBG_PORT = PP->nint; 4281 back_code = (PP + 2); 4282 PP = PP[1].code; 4283 goto _retry_me_; /* (DBG_PORT,back_code) */ 4284 4285 Case(Retrylab, I_Retrylab) /* debug clause alt */ 4286 DBG_PORT = PP->nint; 4287 back_code = PP[2].code; 4288 PP = PP[1].code; 4289 goto _retry_me_; /* (DBG_PORT,back_code) */ 4290 4291 /* Operationally the same as Retry, but points to a branch of an 4292 * inline disjunction rather than a clause, and has envsize. */ 4293 Case(Retry_inline, I_Retry_inline) /* debug branch envsize */ 4294 DBG_PORT = PP->nint; 4295 back_code = PP + 3; 4296 PP = PP[1].code; 4297 goto _retry_me_; /* (DBG_PORT,back_code) */ 4298 4299 4300/* 4301 * super-shallow backtracking instructions 4302 * for if-then-else with simple condition 4303 */ 4304 Case(Set_bp, I_Set_bp) 4305 pw1 = B.args; 4306 Top(pw1)->backtrack = (vmcode *) PP++->code; 4307 Top(pw1)->frame.args = pw1; 4308 B.top = Top(pw1) + 1; 4309 Next_Pp; 4310 4311 Case(New_bp, I_New_bp) 4312 (B.top - 1)->backtrack = (vmcode *) PP++->code; 4313 Next_Pp; 4314 4315 Case(Restore_bp, I_Restore_bp) 4316 B.top -= 1; 4317 Next_Pp; 4318 4319 4320#ifdef OLD_DYNAMIC 4321/* 4322 * Instructions for the dynamic predicates 4323 * 4324 * (Re)Try_me_dynamic birth, death, next, arity, gc/source 4325 * 4326 * We only make a choicepoint if there is a living alternative. 4327 * Hence all executed Retry_me_dynamic's belong to living clauses. 4328 */ 4329 4330 Case(Try_me_dynamic, I_Try_me_dynamic) 4331 i = DynGlobalClock; /* the current clock */ 4332 while (Dead((PP-1), i)) 4333 { 4334 PP = (PP+2)->code; /* skip dead clauses */ 4335 if (PP == FAIL) Fail; /* all dead -> fail */ 4336 PP += 1; 4337 } 4338 back_code = (PP+2)->code; 4339 tmp1 = (PP+3)->nint & SRC_CLAUSE_ARITY_MASK; 4340 PP += DYNAMIC_INSTR_SIZE - 1; /* start of first living clause */ 4341 4342 while (back_code != FAIL) /* look for living alternative */ 4343 { 4344 if (!Dead(back_code, i)) 4345 { 4346 A[++tmp1].val.nint = i; /* add call clock argument */ 4347 A[tmp1].tag.kernel = TINT; 4348 goto _make_choice_point_; /* (arity in tmp1, back_code) */ 4349 } 4350 back_code = (back_code+3)->code; 4351 } 4352 Next_Pp; /* single clause */ 4353 4354 4355 Case(Retry_me_dynamic, I_Retry_me_dynamic) 4356 /* get the call clock (the last argument) */ 4357 i = ((pword *)(B.top - 1) - 1)->val.nint; 4358 back_code = (PP+2)->code; 4359 while (back_code != FAIL) /* look for living alternative */ 4360 { 4361 if (!Dead(back_code, i)) 4362 { 4363 DBG_PORT = NEXT_PORT; 4364 PP += DYNAMIC_INSTR_SIZE - 1; 4365 goto _retry_me_; /* (DBG_PORT,back_code) */ 4366 } 4367 back_code = (back_code+3)->code; 4368 } 4369 /* the last living clause */ 4370 back_code = PP; 4371 PP += DYNAMIC_INSTR_SIZE - 1; 4372 DBG_PORT = NEXT_PORT; 4373 goto _trust_me_; /* (back_code,PP,DBG_PORT) */ 4374#endif 4375 4376 4377/*********************************************** 4378 * Indexing instructions 4379 ***********************************************/ 4380 4381 Case(Get_list_argumentsAM, I_Get_list_argumentsAM) 4382 Get_Argument(pw1) 4383 Dereference_Pw(pw1) 4384 S = pw1->val.ptr; 4385 Next_Pp; 4386 4387 Case(Get_structure_argumentsAM, I_Get_structure_argumentsAM) 4388 Get_Argument(pw1) 4389 Dereference_Pw(pw1) 4390 S = pw1->val.ptr + 1; 4391 Next_Pp; 4392 4393 4394 Case(List_switchL, I_List_switchL) 4395 Get_Local(pw1) 4396 goto _list_switch_; 4397 4398 Case(List_switchAM, I_List_switchAM) 4399 Get_Argument(pw1) 4400_list_switch_: 4401 Dereference_Pw_Tag(pw1,tmp1) 4402 if(IsTag(tmp1,TLIST)) { 4403 PP = PP->code; 4404 S = pw1->val.ptr; 4405 } else if(IsTag(tmp1,TNIL)) 4406 PP = (PP + 1)->code; 4407 else if(ISRef(tmp1)) 4408 PP += 3; /* skip the various labels */ 4409 else 4410 PP = (PP + 2)->code; 4411 Next_Pp; 4412 4413 4414 Case(Atom_switchL, I_Atom_switchL) 4415 Get_Local(pw1) 4416 goto _atom_switch_; 4417 4418 Case(Atom_switchAM, I_Atom_switchAM) 4419 Get_Argument(pw1) 4420_atom_switch_: 4421 Dereference_Pw_Tag(pw1,tmp1) 4422 if (!IsTag(tmp1, TDICT)) { 4423 if (ISRef(tmp1)) 4424 PP += 3; 4425 else 4426 PP = (PP + 2)->code; 4427 Next_Pp; 4428 } 4429_fast_search_: /* binary search (pw1, PP) */ 4430 Mark_Prof(_fast_search_) 4431 i = pw1->val.nint; /* i is unsigned! */ 4432 pw1 = (PP++)->ptr; /* table start */ 4433_fast_search1_: /* i:value, pw1:table start, PP points to table size */ 4434 { 4435 int l,u; 4436 4437 l = 0; 4438 u = PP->offset; 4439 do 4440 { 4441 tmp1 = (l+u)>>1; 4442 if ((word)i < (word) pw1[tmp1].val.nint) 4443 u = tmp1; 4444 else if ((word)i > (word) pw1[tmp1].val.nint) 4445 l = tmp1+1; 4446 else 4447 { 4448 PP = (emu_code) pw1[tmp1].tag.all; 4449 Next_Pp; 4450 } 4451 } while (u > l); 4452 PP = (PP + 1)->code; /* default */ 4453 Next_Pp; 4454 } 4455 4456 4457 Case(Integer_switchL, I_Integer_switchL) 4458 Get_Local(pw1) 4459 goto _integer_switch_; 4460 4461 Case(Integer_switchAM, I_Integer_switchAM) 4462 Get_Argument(pw1) 4463_integer_switch_: 4464 Dereference_Pw_Tag(pw1,tmp1) 4465 if (IsTag(tmp1, TINT)) 4466 goto _fast_search_; 4467 else if (ISRef(tmp1)) 4468 PP += 3; 4469 else 4470 PP = (PP + 2)->code; 4471 Next_Pp; 4472 4473 4474 Case(Functor_switchL, I_Functor_switchL) 4475 Get_Local(pw1) 4476 goto _functor_switch_; 4477 4478 Case(Functor_switchAM, I_Functor_switchAM) 4479 Get_Argument(pw1) 4480_functor_switch_: 4481 Dereference_Pw_Tag(pw1,tmp1) 4482 if (IsTag(tmp1, TCOMP)) { 4483 pw1 = pw1->val.ptr; /* get the functor */ 4484 S = pw1 + 1; 4485 goto _fast_search_; 4486 } else if (ISRef(tmp1)) 4487 PP += 3; 4488 else 4489 PP = (PP + 2)->code; 4490 Next_Pp; 4491 4492 4493 Case(Integer_range_switchL, I_Integer_range_switchL) 4494 Get_Local(pw1) 4495 goto _integer_range_switch_; 4496 4497 Case(Integer_range_switchAM, I_Integer_range_switchAM) 4498 Get_Argument(pw1) 4499_integer_range_switch_: 4500 Dereference_Pw_Tag(pw1,tmp1) 4501 if (IsTag(tmp1, TINT)) 4502 { 4503 Mark_Prof(_range_search_) 4504 { 4505 i = pw1->val.nint; 4506 pw1 = (PP++)->ptr; 4507 if ((word) i < pw1->val.nint) 4508 PP = (emu_code) (pw1->tag.all); 4509 else if ((word) i > (++pw1)->val.nint) 4510 PP = (emu_code) (pw1->tag.all); 4511 else if (PP->nint == 0) /* no further table */ 4512 PP = (PP + 1)->code; 4513 else { 4514 ++pw1; 4515 goto _fast_search1_; /* i,pw1,PP */ 4516 } 4517 Next_Pp; 4518 } 4519 } 4520 else if (ISRef(tmp1)) 4521 PP += 4; 4522 else if (IsTag(tmp1,TBIG)) 4523 PP = (emu_code) PP->ptr[BigNegative(pw1->val.ptr)?0:1].tag.all; 4524 else 4525 PP = (PP + 3)->code; 4526 Next_Pp; 4527 4528 4529 Case(Switch_on_typeL, I_Switch_on_typeL) 4530 Get_Local(pw1); 4531 Dereference_Pw_Tag(pw1,tmp1) 4532 if (ISRef(tmp1)) { 4533 if (IsTag(tmp1, TMETA)) { 4534 S = pw1->val.ptr; /* so we can skip In_get_metaAM */ 4535 PP = (PP + TPTR)->code; 4536 } else 4537 PP += NTYPES; 4538 } else { 4539 PP = (PP + TagTypeC(tmp1))->code; 4540 } 4541 Next_Pp; 4542 4543 Case(Switch_on_typeAM, I_Switch_on_typeAM) 4544 Get_Argument(pw1) 4545_switch_on_type_: 4546 pw2 = pw1; 4547 Dereference_Pw_Tag(pw1,tmp1) 4548 if (ISRef(tmp1)) { 4549 if (IsTag(tmp1, TMETA)) { 4550 S = pw1->val.ptr; /* so we can skip In_get_metaAM */ 4551 PP = (PP + TPTR)->code; 4552 } else 4553 PP += NTYPES; 4554 } else { 4555 pw2->val.all = pw1->val.all; /* store dereferenced value */ 4556 pw2->tag.kernel = tmp1; 4557 PP = (PP + TagTypeC(tmp1))->code; 4558 } 4559 Next_Pp; 4560 4561 4562/*********************************************** 4563 * Control instructions 4564 ***********************************************/ 4565 4566 Case(Allocate, I_Allocate) 4567 Alloc_Env 4568 Next_Pp; 4569 4570 Case(Deallocate, I_Deallocate) 4571 if(E < EB) 4572 { 4573 Pop_Env 4574 if(EB == SP) 4575 { 4576 Repush_Ret_Code; 4577 } 4578 } 4579 else 4580 { 4581 Push_Ret_Code_To_Eb(ERetCode) 4582 Check_Local_Overflow 4583 E = ERetEnv; 4584 } 4585 Set_Det 4586 Next_Pp; 4587 4588 Case(Occur_check_next, I_Occur_check_next) 4589 Occur_Check_Boundary(TG) 4590 Next_Pp; 4591 4592 Case(MoveLAMCallfA, I_MoveLAMCallfA) 4593 Get_Local(pw1) 4594 Get_Argument(pw2) 4595 Move_Pw(pw1,pw2) 4596 /* falls through */ 4597 Case(CallfA, I_CallfA) 4598 Set_Det 4599 Case(CallA, I_CallA) 4600 Push_Ret_Code(PP + 2) 4601 Check_Local_Overflow 4602 Case(JmpdA, I_JmpdA) 4603 PP = PP->code; 4604 Handle_Events_Call 4605 Next_Pp; 4606 4607 Case(Put_global_variableAMLCallfA, I_Put_global_variableAMLCallfA) 4608 Get_Argument(pw1) 4609 Get_Local(pw2) 4610 pw1->val.ptr = pw2->val.ptr = TG; 4611 pw1->tag.kernel = pw2->tag.kernel = TREF; 4612 pw1 = TG++; 4613 pw1->val.ptr = pw1; 4614 pw1->tag.kernel = TREF; 4615 Set_Det 4616 Push_Ret_Code(PP + 2) 4617 Check_Local_Overflow 4618 PP = PP->code; 4619 Handle_Events_Call 4620 Next_Pp; 4621 4622 Case(JmpdAs, I_JmpdAs) 4623 SP = ByteOffsetMinus(SP, PP++->offset); 4624 PP = PP->code; 4625 Handle_Events_Call 4626 Next_Pp; 4627 4628 Case(Branchs, I_Branchs) 4629 SP = ByteOffsetMinus(SP, PP++->offset); 4630 Case(Branch, I_Branch) 4631 PP = PP->code; 4632 Next_Pp; 4633 4634 Case(MoveLAMCallfP, I_MoveLAMCallfP) 4635 Get_Local(pw1) 4636 Get_Argument(pw2) 4637 Move_Pw(pw1,pw2) 4638 /* falls through */ 4639 Case(CallfP, I_CallfP) 4640 Set_Det 4641 Case(CallP, I_CallP) 4642 Push_Ret_Code(PP + 2) 4643 Check_Local_Overflow 4644 Case(JmpdP, I_JmpdP) 4645 PP = (emu_code) PriCode(PP->proc_entry); 4646 Handle_Events_Call 4647 Next_Pp; 4648 4649 Case(Put_global_variableAMLCallfP, I_Put_global_variableAMLCallfP) 4650 Get_Argument(pw1) 4651 Get_Local(pw2) 4652 pw1->val.ptr = pw2->val.ptr = TG; 4653 pw1->tag.kernel = pw2->tag.kernel = TREF; 4654 pw1 = TG++; 4655 pw1->val.ptr = pw1; 4656 pw1->tag.kernel = TREF; 4657 Set_Det 4658 Push_Ret_Code(PP + 2) 4659 Check_Local_Overflow 4660 PP = (emu_code) PriCode(PP->proc_entry); 4661 Handle_Events_Call 4662 Next_Pp; 4663 4664 Case(MoveLAMChainP, I_MoveLAMChainP) 4665 Get_Local(pw1) 4666 Get_Argument(pw2) 4667 Move_Pw(pw1,pw2) 4668 /* falls through */ 4669 Case(ChainP, I_ChainP) 4670 if(E < EB) { 4671 Pop_Env 4672 if(EB == SP) {Repush_Ret_Code} 4673 } else { 4674 Push_Ret_Code_To_Eb(ERetCode) 4675 Check_Local_Overflow 4676 E = ERetEnv; 4677 } 4678 PP = (emu_code) PriCode(PP->proc_entry); 4679 Set_Det 4680 Handle_Events_Call 4681 Next_Pp; 4682 4683 Case(MoveLAMChainA, I_MoveLAMChainA) 4684 Get_Local(pw1) 4685 Get_Argument(pw2) 4686 Move_Pw(pw1,pw2) 4687 /* falls through */ 4688 Case(ChainA, I_ChainA) 4689 if(E < EB) { 4690 Pop_Env 4691 if(EB == SP) {Repush_Ret_Code} 4692 } else { 4693 Push_Ret_Code_To_Eb(ERetCode) 4694 Check_Local_Overflow 4695 E = ERetEnv; 4696 } 4697 PP = PP->code; 4698 Set_Det 4699 Handle_Events_Call 4700 Next_Pp; 4701 4702 /* 4703 * We used to trigger GCs here, but that was felt to be too 4704 * risky since we are not so sure about the machine state. 4705 * Now we just expand the global stack if necessary. 4706 */ 4707 Case(Gc_test, I_Gc_test) /* bytes_needed */ 4708 tmp1 = PP++->offset; 4709 TG = ByteOffsetPlus(TG, tmp1); 4710 Check_Gc 4711 TG = ByteOffsetMinus(TG, tmp1); 4712 Next_Pp; 4713 4714 Case(Gc_testA, I_Gc_testA) /* bytes_needed, arity */ 4715 tmp1 = PP->offset; 4716 PP += 2; /* arity is obsolete */ 4717 TG = ByteOffsetPlus(TG, tmp1); 4718 Check_Gc 4719 TG = ByteOffsetMinus(TG, tmp1); 4720 Next_Pp; 4721 4722 Case(Space, I_Space) 4723/* CAUTION: if Space is to be used to grab space, add an overflow check */ 4724 SP = ByteOffsetMinus(SP, PP++->offset); 4725 Next_Pp; 4726 4727 Case(Initialize, I_Initialize) /* Initialize firstY, mask */ 4728 Get_Local(pw1) 4729 i = (uword) PP++->nint; 4730 pw1->val.ptr = pw1; 4731 pw1->tag.kernel = TREF; 4732 while (i != 0) 4733 { 4734 --pw1; 4735 if (i & 1) 4736 { 4737 pw1->val.ptr = pw1; 4738 pw1->tag.kernel = TREF; 4739 } 4740 i = i >> 1; /* important: i must be unsigned ! */ 4741 } 4742 Next_Pp; 4743 4744 Case(Initialize_named, I_Initialize_named) 4745 /* Initialize firstY, mask, nam1, name2, ... */ 4746 Check_Gc /* cause compiler doesn't generate appropriate Gc_test! */ 4747 Get_Local(pw1) 4748 i = (uword) PP++->nint; 4749 S = TG++; 4750 pw1->val.ptr = S; 4751 pw1->tag.kernel = TREF; 4752 S->val.ptr = S; 4753 S->tag.kernel = PP++->kernel; 4754 while (i != 0) 4755 { 4756 --pw1; 4757 if (i & 1) 4758 { 4759 S = TG++; 4760 pw1->val.ptr = S; 4761 pw1->tag.kernel = TREF; 4762 S->val.ptr = S; 4763 S->tag.kernel = PP++->kernel; 4764 } 4765 i = i >> 1; /* important: i must be unsigned ! */ 4766 } 4767 Next_Pp; 4768 4769 Case(JmpA, I_JmpA) 4770 if (!Deterministic) { 4771 Repush_Ret_Code 4772 Check_Local_Overflow 4773 Set_Det 4774 } 4775 PP = PP->code; 4776 Handle_Events_Call 4777 Next_Pp; 4778 4779 Case(JmpP, I_JmpP) 4780 if (!Deterministic) { 4781 Repush_Ret_Code 4782 Check_Local_Overflow 4783 Set_Det 4784 } 4785 PP = (emu_code) PriCode(PP->proc_entry); 4786 Handle_Events_Call 4787 Next_Pp; 4788 4789 Case(Retd_nowake, I_Retd_nowake) 4790 Pop_Ret_Code 4791 Next_Pp; 4792 4793 Case(Retd, I_Retd) 4794 Pop_Ret_Code 4795 Handle_Events_Return 4796 Next_Pp; 4797 4798 Case(Ret, I_Ret) 4799 if (Deterministic) { 4800 Pop_Ret_Code 4801 Handle_Events_Return 4802 Next_Pp; 4803 } 4804 /* else fall through */ 4805 Case(Retn, I_Retn) 4806 Set_Det 4807 Read_Ret_Code; 4808 Handle_Events_Return 4809 Next_Pp; 4810 4811 Case(Ret_nowake, I_Ret_nowake) 4812 if (Deterministic) { 4813 Pop_Ret_Code 4814 Next_Pp; 4815 } 4816 Set_Det 4817 Read_Ret_Code; 4818 Next_Pp; 4819 4820 Case(ChaincA, I_ChaincA) 4821 pw1 = (E - 1)->val.ptr; 4822 Cut_To(pw1) 4823 Set_Det 4824 /* fall through */ 4825 Case(ChaindA, I_ChaindA) 4826 Pop_Env 4827 PP = PP->code; 4828 Handle_Events_Call 4829 Next_Pp; 4830 4831 Case(ChaincP, I_ChaincP) 4832 pw1 = (E - 1)->val.ptr; 4833 Cut_To(pw1) 4834 Set_Det 4835 /* fall through */ 4836 Case(ChaindP, I_ChaindP) 4837 Pop_Env 4838 PP = (emu_code) PriCode(PP->proc_entry); 4839 Handle_Events_Call 4840 Next_Pp; 4841 4842 Case(Exits, I_Exits) 4843/* CAUTION: if Space is to be used to grab space, add an overflow check */ 4844 SP = ByteOffsetMinus(SP, PP++->offset); 4845 /* falls through */ 4846 Case(Exit, I_Exit) 4847 Set_Det 4848 if(E < EB) { 4849 Pop_Env 4850 if(EB == SP) { 4851 Read_Ret_Code 4852 } else { 4853 Pop_Ret_Code 4854 } 4855 } else { 4856 SP = EB; 4857 PP = (emu_code) ERetCode; 4858 E = ERetEnv; 4859 } 4860 Handle_Events_Return 4861 Next_Pp; 4862 4863 Case(Exitc, I_Exitc) 4864 pw1 = (E - 1)->val.ptr; 4865 Cut_To(pw1) 4866 Set_Det 4867 /* fall through */ 4868 Case(Exitd, I_Exitd) 4869 Pop_Env 4870 Pop_Ret_Code 4871 Handle_Events_Return 4872 Next_Pp; 4873 4874 Case(Exitd_nowake, I_Exitd_nowake) 4875 Pop_Env 4876 Pop_Ret_Code 4877 Next_Pp; 4878 4879 Case(Savecut, I_Savecut) 4880 pw1 = E - 1; 4881 /* CAUTION: this works only if there is at most 1 choicepoint! */ 4882 pw1->val.ptr = Deterministic ? B.args : BPrev(B.args); 4883 pw1->tag.kernel = TCUT; 4884 Next_Pp; 4885 4886 Case(SavecutL, I_SavecutL) 4887 Get_Local(pw1) 4888 pw1->val.ptr = B.args; 4889 pw1->tag.kernel = TCUT; 4890 Next_Pp; 4891 4892 Case(SavecutAM, I_SavecutAM) 4893 Get_Argument(pw1) 4894 pw1->val.ptr = B.args; 4895 pw1->tag.kernel = TCUT; 4896 Next_Pp; 4897 4898 Case(Cut_single, I_Cut_single) 4899 if ((B.top - 1)->frame.args != (E - 1)->val.ptr) { 4900 PP += 1; 4901 Next_Pp; 4902 } 4903 /* else fall through to Cut */ 4904 4905 Case(Cut, I_Cut) /* EnvTrimSize (env. definitely exposed) */ 4906 pw1 = (E - 1)->val.ptr; 4907 Cut_To(pw1) 4908 Set_Det 4909 SP = ByteOffsetMinus(E, PP++->offset); 4910 Next_Pp; 4911 4912 Case(CutAMN, I_CutAMN) /* Ai EnvTrimSize */ 4913 Get_Argument(pw1) 4914 goto _cut_and_trim_if_environment_exposed_; 4915 4916 Case(CutL, I_CutL) /* Yi EnvTrimSize */ 4917 Get_Local(pw1) 4918_cut_and_trim_if_environment_exposed_: 4919 pw1 = pw1->val.ptr; 4920 Cut_To(pw1) 4921 Set_Det /* needed if instruction gets used in first chunk */ 4922 pw1 = ByteOffsetMinus(E, PP++->offset); 4923 if (pw1 > EB) 4924 SP = EB; 4925 else 4926 SP = pw1; 4927 Next_Pp; 4928 4929 Case(CutAM, I_CutAM) /* Ai */ 4930 Get_Argument(pw1); 4931 Dereference_Pw(pw1) 4932 pw1 = pw1->val.ptr; 4933 Cut_To(pw1) 4934 Set_Det /* CAUTION: assumes we cut at least one chpt! */ 4935 Next_Pp; 4936 4937 Case(SoftcutL, I_SoftcutL) 4938 Get_Local(pw1) 4939 pw1 = pw1->val.ptr; 4940 if (B.args == pw1) { 4941 Cut_Last(pw1) 4942 Next_Pp; 4943 } 4944 (Top(pw1) - 1)->backtrack = soft_cut_code_; 4945 Next_Pp; 4946 4947 Case(GuardL, I_GuardL) /* Yi, DelayLabel */ 4948 { 4949 pword **aux_tt = TT; 4950 Get_Local(pw1) 4951 pw1 = pw1->val.ptr; 4952 EB = Chp(pw1)->sp; 4953 GB = Chp(pw1)->tg; 4954 while (aux_tt < Chp(pw1)->tt) /* something was trailed */ 4955 { 4956 S = TrailedLocation(aux_tt); 4957 if (S < GB || S >= EB) /* significant trail ? */ 4958 { 4959 PP = PP->code; 4960 Next_Pp; 4961 } 4962 End_Of_Frame(aux_tt, aux_tt) 4963 } 4964 PP++; 4965 Next_Pp; 4966 } 4967 4968#ifdef DFID 4969 Case(Dfid_testL, I_Dfid_testL) 4970 if ((i = DfidDepth->val.nint + 1) > MaxDepth) { 4971 if (i > DepthLimit) { 4972 DepthOV = 1; 4973 Fail; 4974 } 4975 else { 4976 Trail_Word(&MaxDepth, 0, TRAILED_WORD32); 4977 MaxDepth = i; 4978 } 4979 } 4980 Get_Local(pw1) 4981 pw1->tag.kernel = TINT; 4982 pw1->val.nint = i; 4983 if (DfidDepth < GB) { 4984 Trail_Pointer(&DfidDepth); 4985 S = TG++; 4986 S->tag.kernel = TINT; 4987 S->val.nint = i; 4988 DfidDepth = S; 4989 } 4990 else 4991 DfidDepth->val.nint = i; 4992 Next_Pp; 4993 4994 Case(Dfid_test, I_Dfid_test) 4995 if ((i = DfidDepth->val.nint + 1) > MaxDepth) { 4996 if (i > DepthLimit) { 4997 DepthOV = 1; 4998 Fail; 4999 } 5000 else { 5001 Trail_Word(&MaxDepth, 0, TRAILED_WORD32); 5002 MaxDepth = i; 5003 } 5004 } 5005 if (DfidDepth < GB) { 5006 Trail_Pointer(&DfidDepth); 5007 S = TG++; 5008 S->tag.kernel = TINT; 5009 S->val.nint = i; 5010 DfidDepth = S; 5011 } 5012 else 5013 DfidDepth->val.nint = i; 5014 Next_Pp; 5015 5016 Case(Depth, I_Depth) 5017 Get_Local(pw1) 5018 if (DfidDepth < GB) { 5019 Trail_Pointer(&DfidDepth); 5020 S = TG++; 5021 S->tag.kernel = TINT; 5022 S->val.nint = pw1->val.nint; 5023 DfidDepth = S; 5024 } 5025 else 5026 DfidDepth->val.nint = pw1->val.nint; 5027 Next_Pp; 5028#endif 5029 5030 5031/***** In_get_.... ******/ 5032 5033 Case(In_get_constantAM, I_In_get_constantAM) 5034 Get_Argument(pw1); 5035 Dereference_Pw_Tag(pw1,tmp1); 5036 goto _compare_const_; /* (tmp1,pw1,pp) */ 5037 5038 Case(In_get_nilAM, I_In_get_nilAM) 5039 Get_Argument(pw1); 5040 Dereference_Pw_Tag(pw1,tmp1); 5041 if (!IsTag(tmp1,TNIL)) 5042 { Fail; } 5043 Next_Pp; 5044 5045 Case(In_get_integerAM, I_In_get_integerAM) 5046 Get_Argument(pw1); 5047 Dereference_Pw_Tag(pw1,tmp1); 5048 if (!IsTag(tmp1,TINT) || (pw1->val.nint != PP++->nint)) 5049 { Fail; } 5050 Next_Pp; 5051 5052#ifdef TFLOAT 5053 Case(In_get_floatAM, I_In_get_floatAM) 5054 Get_Argument(pw1); 5055 Dereference_Pw_Tag(pw1,tmp1); 5056 if (!IsTag(tmp1,TFLOAT) || (pw1->val.real != PP++->real)) 5057 { Fail; } 5058 Next_Pp; 5059#endif 5060 5061 Case(In_get_atomAM, I_In_get_atomAM) 5062 Get_Argument(pw1); 5063 Dereference_Pw_Tag(pw1,tmp1); 5064 if (!IsTag(tmp1,TDICT) || (pw1->val.did != PP++->did)) 5065 { Fail; } 5066 Next_Pp; 5067 5068 Case(In_get_stringAM, I_In_get_stringAM) 5069 Get_Argument(pw1); 5070 Dereference_Pw_Tag(pw1,tmp1); 5071 if (!IsTag(tmp1,TSTRG)) 5072 { 5073 Fail; 5074 } 5075 else 5076 { 5077 pw1 = pw1->val.ptr; 5078 pw2 = PP++->ptr; 5079 Compare_Strings(pw1, pw2, err_code); 5080 if (err_code >= 0) 5081 { 5082 Fail; 5083 } 5084 } 5085 Next_Pp; 5086 5087 Case(In_get_metaAM, I_In_get_metaAM) 5088 Get_Argument(pw1); 5089 Dereference_Pw_Tag(pw1,tmp1); 5090 if (!IsTag(tmp1, TMETA)) { 5091 Fail; 5092 } else { 5093 S = pw1->val.ptr; 5094 PP++; 5095 } 5096 Next_Pp; 5097 5098 Case(In_get_listAM, I_In_get_listAM) 5099 Get_Argument(pw1); 5100 Dereference_Pw_Tag(pw1,tmp1); 5101 if (!IsTag(tmp1,TLIST)) 5102 { 5103 Fail; 5104 } 5105 else 5106 { 5107 S = pw1->val.ptr; 5108 PP = PP->code; 5109 } 5110 Next_Pp; 5111 5112 Case(In_get_structureAM, I_In_get_structureAM) 5113 Get_Argument(pw1); 5114 Dereference_Pw_Tag(pw1,tmp1); 5115 if (!IsTag(tmp1,TCOMP)) 5116 { 5117 Fail; 5118 } 5119 else 5120 { 5121 pw1 = pw1->val.ptr; 5122 if (pw1->val.did == (PP++)->did) 5123 { 5124 S = pw1 + 1; 5125 PP = PP->code; 5126 } 5127 else 5128 { 5129 Fail; 5130 } 5131 } 5132 Next_Pp; 5133 5134 Case(Get_matched_valueAMAM, I_Get_matched_valueAMAM) 5135 Get_Argument(pw1); 5136 Get_Argument(pw2); 5137 goto _match_values_; 5138 5139 Case(Get_matched_valueAMTM, I_Get_matched_valueAMTM) 5140 Get_Argument(pw1); 5141 Get_Temporary(pw2); 5142 goto _match_values_; 5143 5144 Case(Read_matched_valueAM, I_Read_matched_valueAM) 5145 Get_Argument(pw1); 5146 pw2 = S++; 5147 goto _match_values_; 5148 5149 Case(Read_matched_valueTM, I_Read_matched_valueTM) 5150 Get_Temporary(pw1); 5151 pw2 = S++; 5152 goto _match_values_; 5153 5154 Case(Read_matched_valueL, I_Read_matched_valueL) 5155 Get_Local(pw1); 5156 pw2 = S++; 5157 goto _match_values_; 5158 5159 Case(Get_matched_valueAML, I_Get_matched_valueAML) 5160 Get_Argument(pw1); 5161 Get_Local(pw2); 5162_match_values_: 5163 Dereference_Pw(pw1); 5164 Dereference_Pw(pw2); 5165 proc = identical_proc_; 5166 goto _diff_; /* (proc, pw1, pw2) */ 5167 5168 /* 5169 * the next instruction can be prefixed to ordinary 5170 * Read_... instructions to simulate the corresponding 5171 * Read_matched_... instructions 5172 */ 5173 Case(Read_test_var, I_Read_test_var) 5174 pw1 = S; /* do not increment S ! */ 5175 Dereference_Pw_Tag(pw1,tmp1) 5176 if (ISRef(tmp1)) 5177 { 5178 Fail; 5179 } 5180 Next_Pp; 5181 5182 5183/*********************************************** 5184 * Coroutining instructions 5185 ***********************************************/ 5186 5187 /* Explicit resume instruction. When events are pending, 5188 * it has the same effects as a call, so there must be an 5189 * environment, temporaries popped, etc. Also, the woken 5190 * goal (or the GC) may leave choicepoints. 5191 */ 5192 Case(Ress, I_Ress) /* space arity envsize */ 5193 SP = ByteOffsetMinus(SP, PP++->offset); 5194 Case(Res, I_Res) /* arity envsize */ 5195 if (EventPending) { 5196 tmp1 = PP[0].nint; 5197 Push_Ret_Code(PP+2) /* make it look like a call */ 5198 PP = (emu_code) return_code_; 5199 goto _handle_events_at_res_; /* (tmp1) */ 5200 } 5201 PP += 2; 5202 Next_Pp; 5203 5204 Case(Wake_init, I_Wake_init) /* no args */ 5205 Push_Env 5206 (--SP)->tag.all = TINT; 5207 SP->val.nint = WP; 5208 Check_Local_Overflow 5209 PP += 1; /* skip envsize */ 5210 Next_Pp; 5211 5212 Case(Wake, I_Wake) /* no args, Y1 = savedWP */ 5213 tmp1 = (E-1)->val.nint; /* saved WP */ 5214#ifdef PRINTAM 5215 if (!WL || tmp1 > WLMaxPrio(WL) || DE) 5216 { 5217 (void) ec_panic("Assertion Failed", "Emulator"); 5218 } 5219#endif 5220 /* 5221 * first_woken(tmp1 -> pw2) 5222 * find the first woken suspension with priority higher than tmp1 5223 * and remove it from its list. Note that these lists have been 5224 * created by schedule_suspensions, so we know we don't have 5225 * references in certain places (but beware of timestamps!) 5226 */ 5227 pw2 = 0; 5228 S = WLFirst(WL) - 1; 5229 for (i=1; i<tmp1; i++) 5230 { 5231 pw1 = ++S; /* no references allowed */ 5232 if (IsList(pw1->tag)) 5233 { 5234 for (;;) { 5235 pw1 = pw1->val.ptr; /* list element */ 5236 pw2 = (pw1++)->val.ptr; /* TSUSP pword */ 5237 Dereference_(pw1); /* list tail */ 5238 if (!SuspDead(pw2)) 5239 { 5240 if (SuspScheduled(pw2)) 5241 break; /* found one to execute! */ 5242 5243 /* An 'unscheduled' demon, re-delay */ 5244#ifdef PRINTAM 5245 if (!SuspDemon(pw2)) 5246 (void) ec_panic("Assertion Failed", "unscheduled non-demon"); 5247#endif 5248 Set_Susp_Delayed(pw2); 5249 } 5250 if (IsNil(pw1->tag)) { 5251 pw2 = 0; /* end of this list */ 5252 break; 5253 } 5254 } 5255 /* 5256 * Replace the list head: remove dead suspensions 5257 * plus possibly the one we are about to wake 5258 */ 5259 if (S->val.ptr < GB) { 5260 Trail_Pword(S); 5261 } 5262 if (IsList(pw1->tag)) { 5263 S->val.ptr = pw1->val.ptr; 5264 } else { 5265 /* Use a timestamp (which happens to look like a []) 5266 * to terminate the list */ 5267 Make_Stamp(S); 5268 } 5269 if (pw2) 5270 { 5271 /* We did find a suspension to wake: set priority and call it! */ 5272 Set_WP(SuspRunPrio(pw2)); 5273 PP -= 1; /* wake loop */ 5274 if(E >= EB) { 5275 Push_Ret_Code_To_Eb(ERetCode) 5276 E = ERetEnv; 5277 Push_Env 5278 (--SP)->tag.all = TINT; 5279 SP->val.nint = tmp1; 5280 Check_Local_Overflow 5281 } 5282 goto _susp_wake_; /* (pw2) */ 5283 } 5284 } 5285 } 5286 /* no woken goal found, continue */ 5287 Set_WP(tmp1); 5288 Next_Pp; 5289 5290 5291 Case(Continue_after_event, I_Continue_after_event) 5292 PP = (emu_code) DynEnvVal(E); /* get continuation */ 5293 if (DynEnvFlags(E) & WAS_NONDET) {Clr_Det;} else {Set_Det;} 5294 5295 if (DynEnvFlags(E) & WAS_CALL) { /* debug event frame */ 5296 if (DynEnvDE(E)->tag.kernel == TSUSP) DE = DynEnvDE(E)->val.ptr; 5297 err_code = DynEnvDbgPort(E)->val.nint; /* port */ 5298 pw1 = E-DYNENVDBGSIZE-1; 5299 tmp1 = DynEnvSize(E)-DYNENVDBGSIZE-1; 5300 } else { 5301 pw1 = E-1; 5302 tmp1 = DynEnvSize(E) - 1; 5303 err_code = 0; 5304 } 5305 5306 pw2 = &A[1]; /* restore args */ 5307 for (; tmp1 > 0; tmp1--) 5308 *pw2++ = *--pw1; 5309 5310 if (E < EB) /* pop aux environment */ 5311 { 5312 Pop_Env 5313 } 5314 else 5315 { 5316 SP = EB; 5317 Push_Ret_Code(ERetCode) 5318 E = ERetEnv; 5319 } 5320 5321 /* insert hook to trace the exit port */ 5322 if (err_code & LAST_CALL) 5323 { 5324 Push_Env 5325 Push_Ret_Code((emu_code) &trace_exit_code_[1]); 5326 } 5327 Next_Pp; 5328 5329 Case(Continue_after_event_debug, I_Continue_after_event_debug) 5330 if (DynEnvFlags(E) & WAS_NONDET) {Clr_Det;} else {Set_Det;} 5331 if ((emu_code) DynEnvVal(E) == (emu_code) return_code_) 5332 { 5333 (void) ec_panic("Debug Assertion Failed", "Emulator"); 5334 /* can't handle the port, it's inlined */ 5335 DynEnvDbgPort(E)->val.nint &= ~LAST_CALL; /* port */ 5336 PP = (emu_code) &restore_code_[1]; 5337 Next_Pp; 5338 } 5339 proc = (pri *) DynEnvDbgPri(E)->val.wptr; /* pri */ 5340 err_code = DynEnvDbgPort(E)->val.nint; /* port */ 5341#ifndef USE_LAST_FLAG 5342 DynEnvDbgPort(E)->val.nint |= LAST_CALL; 5343#endif 5344 /* 5345 print_port(current_err_, err_code); 5346 newline(current_err_); 5347 */ 5348 DBG_INVOC = DynEnvDbgInvoc(E)->val.nint; /* invoc */ 5349 if (!DBG_INVOC) 5350 DBG_INVOC = NINVOC++; 5351 val_did = PriDid(proc); 5352 tmp1 = DidArity(val_did); 5353 5354 if (tmp1 == 0) { /* build goal */ 5355 scratch_pw.val.did = val_did; 5356 scratch_pw.tag.kernel = (val_did == d_.nil) ? TNIL : TDICT; 5357 } else { 5358 scratch_pw.val.ptr = TG; 5359 if (val_did == d_.list) { 5360 scratch_pw.tag.kernel = TLIST; 5361 } else { 5362 scratch_pw.tag.kernel = TCOMP; 5363 TG->val.did = val_did; 5364 (TG++)->tag.kernel = TDICT; 5365 } 5366 pw1 = E - DYNENVDBGSIZE - 1; 5367 for(; tmp1 > 0; tmp1--) 5368 { 5369 pw2 = --pw1; 5370 Move_Pw_To_Global_Stack(pw2, TG, ;); 5371 } 5372 } 5373 5374 A[1] = TAGGED_TD; /* Old call stack */ 5375 if (TD < GB) { Trail_Pword(&TAGGED_TD); } 5376#ifdef USE_FIRST_FLAG 5377 if (!(err_code & FIRST_CALL)) 5378 { 5379 tmp1 = DLevel(TD); /* depth */ 5380 TAGGED_TD = TD[TF_ANCESTOR]; /* pop exited frame */ 5381 } 5382 else 5383#endif 5384 { 5385 tmp1 = TD ? DLevel(TD)+1 : 0; /* depth */ 5386 } 5387 val_did = PriModule(proc); 5388 if (val_did == D_UNKNOWN) val_did = proc->module_ref; 5389 Push_Dbg_Frame(pw1, DBG_INVOC, scratch_pw.val, scratch_pw.tag, 5390 tmp1, WP, proc, DynEnvDbgPath(E)->val.did, 5391 DynEnvDbgLine(E)->val.nint, 5392 DynEnvDbgFrom(E)->val.nint, 5393 DynEnvDbgTo(E)->val.nint, val_did) 5394#if (TF_BREAK != BREAKPOINT) 5395Please make sure that TF_BREAK == BREAKPOINT 5396#endif 5397 tmp1 = err_code&BREAKPOINT; /* == TF_BREAK */ 5398 Set_Tf_Flag(TD, tmp1) 5399 if (OfInterest(PriFlags(proc), DBG_INVOC, tmp1, tmp1)) 5400 { 5401 A[2] = TAGGED_TD; /* New call stack */ 5402 5403 /* if stop point: 5404 * call debug event(OldStack,NewStack) 5405 */ 5406 proc = error_handler_[(err_code&PORT_MASK) == WAKE_PORT ? -(DEBUG_WAKE_EVENT) : -(DEBUG_CALL_EVENT)]; 5407 PP = (emu_code) PriCode(proc); 5408 Push_Ret_Code((emu_code) &restore_code_[1]); 5409 Check_Local_Overflow 5410 } 5411 else 5412 { 5413 PP = (emu_code) &restore_code_[1]; 5414 } 5415 Next_Pp; 5416 5417 5418 /* 5419 * Refail is really a cut, but can be somewhat simpler because 5420 * it is always followed by a fail. Resetting of EB/GB proved 5421 * necessary because debugger and garbage collector rely on GB 5422 * to cache the current topmost choicepoint's TG field. 5423 */ 5424 Case(Refail, I_Refail) 5425_do_refail_: 5426 B.any_frame = (B.top-1)->frame; 5427 EB = BChp(B.args)->sp; 5428 GB = BChp(B.args)->tg; 5429#ifdef PB_MAINTAINED 5430 while (PB > B.args) 5431 PB = BPar(PB)->ppb; 5432#endif 5433 Case(Failure, I_Failure) 5434_do_fail_: 5435 PP = (emu_code) (B.top - 1)->backtrack; 5436 Next_Pp; 5437 5438 5439/*********************************************** 5440 * Metacall instructions 5441 ***********************************************/ 5442 5443 Case(Explicit_jmp, I_Explicit_jmp) /* (LookupM,Goal,CallerM,Cut) */ 5444 if (Deterministic) { 5445 Pop_Ret_Code 5446 } else { 5447 Read_Ret_Code 5448 Set_Det 5449 } 5450 scratch_pw = A[1]; 5451 A[1] = A[2]; 5452 A[2] = A[3]; 5453 A[3] = scratch_pw; 5454 DBG_PORT = CALL_PORT|LAST_CALL; 5455 err_code = PRI_EXPORTEDONLY; 5456 i = 0; 5457 goto _anycall_; 5458 5459 Case(Meta_jmp, I_Meta_jmp) /* tail-recursive metacall */ 5460 i = PP->nint; /* # of additional arguments */ 5461 if (Deterministic) { 5462 Pop_Ret_Code 5463 } else { 5464 Read_Ret_Code 5465 Set_Det 5466 } 5467 DBG_PORT = CALL_PORT|LAST_CALL; 5468 err_code = 0; 5469 goto _anycall_; 5470 5471 Case(Metacall, I_Metacall) /* (Goal, CallerMod, LookupMod, Cut) */ 5472 PP++; /* skip environment size */ 5473 DBG_PORT = CALL_PORT; 5474 Set_Det 5475 err_code = 0; 5476 i = 0; 5477_anycall_: /* (pw1,DBG_PORT,err_code,i) */ 5478#ifdef USE_LAST_FLAG 5479 DBG_PORT |= FIRST_CALL; 5480#else 5481 DBG_PORT |= FIRST_CALL|LAST_CALL; 5482#endif 5483 pw1 = &A[3+i]; /* lookup module */ 5484 tmp1 = pw1->tag.kernel; /* check lookup module */ 5485 if (ISRef(tmp1)) { 5486 Dereference_Pw_Tag(pw1,tmp1) /* rare case! */ 5487 if (ISRef(tmp1)) { 5488 err_code = INSTANTIATION_FAULT; 5489 goto _metacall_err_in_goal_; 5490 } 5491 } 5492 if (!IsTag(tmp1,TDICT)) { 5493 if (IsTag(tmp1,TNIL)) 5494 pw1->val.did = d_.nil; /***/ 5495 else { 5496 err_code = TYPE_ERROR; 5497 goto _metacall_err_in_goal_; 5498 } 5499 } 5500 pw2 = pw1; /* dereferenced lookup module */ 5501 5502 pw1 = &A[1]; /* check goal */ 5503_metacall_check_goal_: 5504 Dereference_Pw_Tag(pw1,tmp1) 5505 if (IsTag(tmp1,TCOMP)) { 5506 pw1 = pw1->val.ptr; 5507 val_did = pw1->val.did; 5508 if (i && val_did == d_.colon) { 5509 pw2 = ++pw1; 5510 Dereference_Pw_Tag(pw2,tmp1) 5511 if (ISRef(tmp1)) { 5512 err_code = INSTANTIATION_FAULT; 5513 goto _metacall_err_in_goal_; 5514 } else if (!IsTag(tmp1,TDICT)) { 5515 err_code = TYPE_ERROR; 5516 goto _metacall_err_in_goal_; 5517 } 5518 err_code = PRI_EXPORTEDONLY; 5519 ++pw1; 5520 goto _metacall_check_goal_; 5521 } 5522 } else if (IsTag(tmp1,TDICT)) { 5523 val_did = pw1->val.did; 5524 if (DidArity(val_did) > 0) { 5525 err_code = TYPE_ERROR; 5526 goto _metacall_err_in_goal_; 5527 } 5528 } else if (IsTag(tmp1,TLIST)) { 5529 pw1 = pw1->val.ptr - 1; 5530 val_did = d_.list; 5531 } else if (IsTag(tmp1,TNIL)) { 5532 val_did = d_.nil; 5533 } else { 5534 if (ISRef(tmp1)) 5535 err_code = INSTANTIATION_FAULT; 5536 else 5537 err_code = TYPE_ERROR; 5538 goto _metacall_err_in_goal_; 5539 } 5540 /* correct val_did for call/2..N */ 5541 tmp1 = DidArity(val_did); 5542 if (i > 0) { 5543 val_did = add_dict(val_did, tmp1+i); 5544 } 5545 if (!IsModule(pw2->val.did)) { 5546 err_code = NO_LOOKUP_MODULE; 5547 goto _metacall_err_call_; /* (err_code,val_did,tmp1,i,pw1) */ 5548 } 5549 Export_B_Sp_Tg_Tt 5550 proc = visible_procedure(val_did, pw2->val.did, pw2->tag, err_code); 5551 Import_None 5552 if( proc == (pri*) 0) { 5553 Get_Bip_Error(err_code); 5554 if (err_code == NOENTRY) 5555 err_code = CALLING_AUTOLOAD; 5556 goto _metacall_err_call_; /* (err_code,val_did,tmp1,i,pw1) */ 5557 } 5558 DBG_INVOC = 0; 5559 5560 /* first check for control constructs ,/2 ;/2 ->/2 !/0 */ 5561 if (proc->module_ref == d_.kernel_sepia) 5562 { 5563 if(val_did == d_.comma) { 5564 Push_Ret_Code(PP) 5565 Check_Local_Overflow; 5566 PP = (emu_code) CodeStart(comma_body_code_); 5567_move_control_args_: 5568 /* make ','(Goal1, Goal2, CM, Cut) */ 5569 if (i==0) { 5570 /* from call(','(Goal1, Goal2), CM, LM, Cut) */ 5571 A[3] = A[2]; /* CM */ 5572 A[1] = pw1[1]; /* Goal1 */ 5573 A[2] = pw1[2]; /* Goal2 */ 5574 } else if (i==1) { 5575 /* from call(','(Goal1), Goal2, CM, LM, Cut) */ 5576 A[1] = pw1[1]; /* Goal1 */ 5577 A[4] = A[5]; /* Cut */ 5578 } else { 5579 /* from call(',', Goal1, Goal2, CM, LM, Cut) */ 5580 A[1] = A[2]; /* Goal1 */ 5581 A[2] = A[3]; /* Goal2 */ 5582 A[3] = A[4]; /* CM */ 5583 A[4] = A[6]; /* Cut */ 5584 } 5585 DBG_PORT = NO_PORT; /* don't trace, treat as inlined */ 5586 goto _exec_prolog_; 5587 5588 } else if(val_did == d_.semicolon) { 5589 Push_Ret_Code(PP) 5590 Check_Local_Overflow; 5591 pw2 = i<2? &pw1[1]: &A[2]; /* lhs */ 5592 Dereference_Pw(pw2) 5593 if (IsStructure(pw2->tag) && ( 5594 ( pw2->val.ptr->val.did == d_.cond 5595 && (PP = (emu_code) CodeStart(cond3_body_code_))) 5596 || 5597 ( pw2->val.ptr->val.did == d_.softcut 5598 && (PP = (emu_code) CodeStart(softcut5_body_code_))))) 5599 { 5600 /* 5601 * Map call((G1->G2;G3), CM, LM, Cut) 5602 * into ';'(G1, G2, CM, Cut, G3) 5603 * or call((G1*->G2;G3), CM, LM, Cut) 5604 * into softcut(G1, G2, CM, Cut, G3) 5605 */ 5606 if (i==0) { 5607 /* from call((G1->G2;G3), CM, LM, Cut) */ 5608 A[3] = A[2]; /* CM */ 5609 /* Cut in place */ 5610 A[5] = pw1[2]; /* G3 */ 5611 } else if (i==1) { 5612 /* from call(;(G1->G2), G3, CM, LM, Cut) */ 5613 /* CM in place */ 5614 A[4] = A[5]; /* Cut */ 5615 A[5] = A[2]; /* G3 */ 5616 } else { 5617 /* from call(;, (G1->G2), G3, CM, LM, Cut) */ 5618 A[5] = A[3]; /* G3 */ 5619 A[3] = A[4]; /* CM */ 5620 A[4] = A[6]; /* Cut */ 5621 } 5622 A[1] = pw2->val.ptr[1]; /* G1 */ 5623 A[2] = pw2->val.ptr[2]; /* G2 */ 5624 DBG_PORT = NO_PORT; /* don't trace, treat as inlined */ 5625 goto _exec_prolog_; 5626 } 5627 /* simple disjunction */ 5628 PP = (emu_code) CodeStart(semic_body_code_); 5629 goto _move_control_args_; 5630 5631 } else if(val_did == d_.cond) { /* simple ->/2 */ 5632 Push_Ret_Code(PP) 5633 Check_Local_Overflow; 5634 PP = (emu_code) CodeStart(cond_body_code_); 5635 goto _move_control_args_; 5636 5637 } else if(val_did == d_.cut) { /* !/0 ==> cut_to(Cut) */ 5638 pw2 = &A[4]; 5639 A[1] = *pw2; 5640 Push_Ret_Code(PP) 5641 Check_Local_Overflow; 5642 PP = (emu_code) CodeStart(cut_to_code_); 5643 goto _exec_prolog_; 5644 } 5645 } 5646 5647 /* 5648 * general goal (val_did,tmp1=orig_arity,i=extra_args,pw1=struct) 5649 * PriArgPassing(proc) is ARGFIXEDWAM or ARGFLEXWAM 5650 */ 5651 { 5652_call_structure_reg_: /* (DBG_PORT, DBG_INVOC, proc, tmp1, pw1, A[2](module)) */ 5653 Mark_Prof(_call_structure_reg_) 5654 5655 /* Shift the extra args of call/2+ and caller module */ 5656 if (PriFlags(proc) & TOOL) ++i; 5657 if (tmp1 > 1) { 5658 5659 /* move extra arguments last-to-first */ 5660 pw2 = &A[0]; 5661 for(; i>0; --i) pw2[tmp1+i] = pw2[1+i]; 5662 5663 /* get the arguments from the goal structure */ 5664 switch((unsigned) tmp1) { 5665 default: 5666 do pw2[tmp1] = pw1[tmp1]; 5667 while (--tmp1 > 6); 5668 case 6: pw2[6] = pw1[6]; 5669 case 5: pw2[5] = pw1[5]; 5670 case 4: pw2[4] = pw1[4]; 5671 case 3: pw2[3] = pw1[3]; 5672 case 2: pw2[2] = pw1[2]; 5673 case 1: pw2[1] = pw1[1]; 5674 } 5675 } else if (tmp1 == 1) { 5676 /* extra args are already in the right place */ 5677 A[1] = pw1[1]; 5678 } else { /* tmp1==0 */ 5679 /* move extra arguments first-to-last */ 5680 for(pw2=&A[1]; i>0; --i,++pw2) pw2[0] = pw2[1]; 5681 } 5682 5683_call_prolog_: /* (DBG_INVOC, DBG_PORT, proc) */ 5684 Push_Ret_Code(PP) 5685 Check_Local_Overflow; 5686 PP = (emu_code) PriCode(proc); 5687_exec_prolog_: /* (DBG_INVOC, DBG_PORT, proc, PP) */ 5688 5689 if ((TD || (PriFlags(proc) & DEBUG_ST)) && DBG_PORT) { 5690 if (TD) { 5691 if (((DBG_PORT&PORT_MASK) == WAKE_PORT ? TracingWakes(DBG_INVOC) : TracingMetacalls(DBG_PORT)) 5692 && AnyPortWanted && !InvisibleProc(proc)) { 5693 goto _metacall_port_; /* (proc,DBG_XXX) */ 5694 } 5695 } else /* if (PriFlags(proc) & DEBUG_ST) */ { 5696 if (TRACEMODE & TR_STARTED) { 5697 /* we abuse the DEBUG_SP bit to init creep/leap mode */ 5698 TRACEMODE |= (PriFlags(proc) & DEBUG_SP) ? 5699 TR_TRACING : TR_LEAPING; 5700 } 5701 if (AnyPortWanted) { 5702 goto _metacall_port_; /* (procDBG_XXX) */ 5703 } 5704 } 5705 } 5706 if (PriArgPassing(proc) != ARGFLEXWAM) { 5707 Handle_Events_Call 5708 } 5709 Next_Pp; 5710 } 5711 5712 5713_metacall_port_: /* (proc) */ 5714 tmp1 = CodeArity(PP); /* number of valid arguments */ 5715 Push_Env /* allocate an environment */ 5716 PushDynEnvHdr(tmp1+DYNENVDBGSIZE, WAS_CALL, PP); /* save arity, PP */ 5717 SP -= DYNENVDBGSIZE; 5718 DynEnvDE(e)->tag.kernel = DE?TSUSP:TNIL; 5719 DynEnvDE(e)->val.ptr = DE; 5720 DynEnvDbgPri(E)->tag.kernel = TPTR; /* ... and debug info */ 5721 DynEnvDbgPri(E)->val.wptr = (uword *) proc; 5722 Make_Integer(DynEnvDbgPort(E), DBG_PORT); 5723 Make_Integer(DynEnvDbgInvoc(E), DBG_INVOC); 5724 /* If we have source info in the DBG_ fields from a preceding 5725 * Debug_esc instruction, use it */ 5726 if (DBG_LINE) { 5727 Make_Atom(DynEnvDbgPath(E), DBG_PATH); 5728 Make_Integer(DynEnvDbgLine(E), DBG_LINE); 5729 Make_Integer(DynEnvDbgFrom(E), DBG_FROM); 5730 Make_Integer(DynEnvDbgTo(E), DBG_TO); 5731 DBG_LINE = 0; /* DBG_{PATH,LINE,FROM,TO} now invalid */ 5732 } else { 5733 Make_Atom(DynEnvDbgPath(E), d_.empty); 5734 Make_Integer(DynEnvDbgLine(E), 0); 5735 Make_Integer(DynEnvDbgFrom(E), 0); 5736 Make_Integer(DynEnvDbgTo(E), 0); 5737 } 5738 PP = (emu_code) &restore_debug_code_[1]; 5739 pw1 = &A[1]; /* save the argument registers */ 5740 for (; tmp1; --tmp1) 5741 *(--SP) = *pw1++; 5742 Check_Local_Overflow 5743 if (PriArgPassing(proc) != ARGFLEXWAM) { 5744 goto _handle_events_at_return_; 5745 } 5746 Next_Pp; 5747 5748_metacall_err_in_goal_: /* (err_code, goal in A1, i, caller in A2+i, lookup in A3+i,i) */ 5749 pw2 = TG; 5750 TG += 2+i; 5751 pw2[0].val.did = in_dict("call",1+i); 5752 pw2[0].tag.kernel = TDICT; 5753 pw2[1] = A[1]; /* copy Goal */ 5754 A[1].val.ptr = pw2; 5755 A[1].tag.kernel = TCOMP; 5756 pw2 += 2; 5757 goto _metacall_err_2_; 5758 5759_metacall_err_call_: /* (err_code,val_did,i,pw1=&args[0..tmp1]) */ 5760 if (DidArity(val_did) == 0) { 5761 A[1].val.did = val_did; 5762 A[1].tag.kernel = TDICT; 5763 } else { 5764 pw2 = TG; 5765 TG += 1+tmp1+i; 5766 A[1].val.ptr = pw2; 5767 A[1].tag.kernel = TCOMP; 5768 pw2->val.did = val_did; 5769 pw2++->tag.kernel = TDICT; 5770 for(; tmp1>0; --tmp1) *pw2++ = *++pw1; 5771 } 5772_metacall_err_2_: /* (err_code,i,pw2,A[1,2,3]) */ 5773 pw1 = &A[2]; 5774 for(; i>0; --i) *pw2++ = *pw1++; /* extra args */ 5775 if (pw1 >= &A[3]) { 5776 A[3] = pw1[0]; /* caller module */ 5777 A[4] = pw1[1]; /* lookup module */ 5778 } else { 5779 A[4] = pw1[1]; /* lookup module */ 5780 A[3] = pw1[0]; /* caller module */ 5781 } 5782 A[2] = A[1]; /* call(...) */ 5783 goto _regular_err_2_; /* (err_code, A2, A3, A4) */ 5784 5785 5786 Case(Suspension_jmp, I_Suspension_jmp) /* suspension in A[1] */ 5787 Pop_Ret_Code 5788 goto _susp_call_; 5789 5790 Case(Suspension_call, I_Suspension_call) /* suspension in A[1] */ 5791 PP += 1; /* skip environment size */ 5792_susp_call_: 5793 pw2 = &A[1]; 5794 Dereference_Pw_Tag(pw2, tmp1) 5795 if (!IsTag(tmp1, TSUSP)) { 5796 Fail; 5797 } 5798 pw2 = pw2->val.ptr; /* point to suspension structure */ 5799 if (SuspDead(pw2)) { 5800 Next_Pp; /* ok, already woken */ 5801 } 5802_susp_wake_: /* suspension in pw2 */ 5803 A[2] = pw2[SUSP_MODULE]; 5804 proc = (pri*) pw2[SUSP_PRI].val.wptr; 5805 pw1 = &pw2[SUSP_GOAL]; /* find the arguments */ 5806 Dereference_Pw_Tag(pw1, tmp1) 5807 if (IsTag(tmp1,TCOMP)) { 5808 pw1 = pw1->val.ptr; 5809 tmp1 = DidArity(pw1->val.did); 5810 } else if (IsTag(tmp1,TDICT)) { 5811 tmp1 = 0; 5812 } else if (IsTag(tmp1,TLIST)) { 5813 pw1 = pw1->val.ptr - 1; 5814 tmp1 = 2; 5815 } else if (IsTag(tmp1,TNIL)) { 5816 tmp1 = 0; 5817 } 5818 Set_Det 5819 DBG_PORT = WAKE_PORT; 5820 DBG_INVOC = SuspDebugInvoc(pw2); 5821 if (SuspDemon(pw2)) { 5822 Set_Susp_Delayed(pw2); 5823 if (PriFlags(proc) & EXTERN) /* set DE for C externals */ 5824 DE = pw2; 5825 } else { 5826 Set_Susp_Dead(pw2); 5827 } 5828 /* PriArgPassing(proc) is ARGFIXEDWAM or ARGFLEXWAM */ 5829 i=0; 5830 goto _call_structure_reg_; /* (DBG_PORT,DBG_INVOC,proc,tmp1,pw1,A[2],i) */ 5831 5832 5833 Case(Handler_call, I_Handler_call) /* A[1] signal number */ 5834 pw1 = &A[1]; 5835 Dereference_Pw(pw1) /* checks omitted */ 5836 i = pw1->val.nint; 5837 switch(interrupt_handler_flags_[i]) { 5838 case IH_ABORT: 5839 Make_Atom(&A[1], d_.abort); 5840 PP = (emu_code) do_exit_block_code_; 5841 Next_Pp; 5842 case IH_THROW: 5843 Make_Atom(&A[1], interrupt_name_[i]); 5844 PP = (emu_code) do_exit_block_code_; 5845 Next_Pp; 5846 case IH_HANDLE_ASYNC: 5847 proc = interrupt_handler_[i]; 5848 break; 5849 default: /* should not happen */ 5850 proc = true_proc_; 5851 break; 5852 } 5853 PP++; /* skip environment size */ 5854 DBG_PORT = CALL_PORT; 5855 goto _handler_call_; /* (proc,DBG_PORT) */ 5856 5857 5858 Case(Fastcall, I_Fastcall) /* (port envsize) */ 5859 pw1 = &A[1]; /* A[1] error number or event name */ 5860 Dereference_Pw(pw1); 5861 if (IsInteger(pw1->tag)) 5862 { 5863 err_code = pw1->val.nint; 5864 if (err_code < 0) 5865 { 5866 proc = -err_code >= MAX_ERRORS ? 0 : default_error_handler_[-err_code]; 5867 A[1].val.nint = -err_code; 5868 A[1].tag.kernel = TINT; 5869 } 5870 else 5871 proc = err_code >= MAX_ERRORS ? 0 : error_handler_[err_code]; 5872 } 5873 else if (IsAtom(pw1->tag) && PSUCCEED == 5874 get_simple_property(pw1->val.did, EVENT_PROP, &scratch_pw)) 5875 { 5876 if (scratch_pw.tag.kernel & EVENT_DEFERS) 5877 VM_FLAGS |= EVENTS_DEFERRED; 5878 proc = (pri*) scratch_pw.val.ptr; 5879 } 5880 else 5881 { 5882 A[2] = A[1]; 5883 A[1].val.nint = -(EVENT_IGNORED); 5884 A[1].tag.kernel = TINT; 5885 proc = error_handler_[-(EVENT_IGNORED)]; 5886 } 5887 if (!proc) 5888 proc = error_handler_[0]; 5889 if(proc->did == d_.fail && proc->module_ref == d_.kernel_sepia) 5890 { 5891 Fail 5892 } 5893 DBG_PORT = PP++->nint; /* NO_PORT or CALL_PORT */ 5894 PP++; /* skip environment size */ 5895 5896_handler_call_: /* (proc,DBG_PORT) */ 5897 DBG_INVOC = 0; 5898 val_did = PriDid(proc); 5899 tmp1 = DidArity(val_did); 5900 Set_Det 5901 /* PriArgPassing(proc) is ARGFIXEDWAM or ARGFLEXWAM */ 5902 if(PriFlags(proc) & TOOL) { 5903 pw1 = &A[tmp1+1]; 5904 pw1->val.did = PriModule(proc); 5905 pw1->tag.kernel = ModuleTag(PriModule(proc)); 5906 } 5907 goto _call_prolog_; /* (DBG_INVOC, DBG_PORT, proc) */ 5908 5909 5910 Case(Meta_jmpA, I_Meta_jmpA) /* used to call source of dynamic facts 5911 * memory args like clause/3: 5912 * 1 - Goal 5913 * 2, 3 - Body, Ref 5914 */ 5915 pw1 = &A[1]; /* get arg ptr & arity */ 5916 Dereference_Pw_Tag(pw1,tmp1) 5917 if (IsTag(tmp1,TCOMP)) { 5918 pw1 = pw1->val.ptr; 5919 val_did = pw1->val.did; 5920 } else if (IsTag(tmp1,TLIST)) { 5921 pw1 = pw1->val.ptr - 1; 5922 val_did = d_.list; 5923 } 5924 tmp1 = DidArity(val_did); /* fetch args */ 5925 pw2 = &A[1]; 5926 for(; tmp1 > 0; tmp1--) 5927 *(pw2++) = *(++pw1); 5928 PP = PP->code; 5929 Next_Pp; 5930 5931 5932 5933/* The first instruction of block/4: 5934 * It is similar to a Try, but it only saves arguments 2, 3, and 4. 5935 */ 5936 5937 Case(Catch, I_Catch) 5938 Record_Alternative(1, 0); 5939 pw1 = B.args; 5940 Chp(pw1)->sp = EB = SP; 5941 Chp(pw1)->tg = GB = TG; 5942 Push_Witness 5943 Chp(pw1)->tt = TT; 5944 Chp(pw1)->e = E; 5945 Chp(pw1)->ld = LD; 5946 pw1 = (pword *) (Chp(pw1) + 1); 5947 pw2 = &A[2]; 5948 *pw1++ = *pw2++; /* Tag, Recovery, Module */ 5949 *pw1++ = *pw2++; 5950 *pw1++ = *pw2; 5951 Top(pw1)->backtrack = 5952 !(PP++)->nint ? catch_fail_code_ : catch_unint_fail_code_; 5953 Top(pw1)->frame = B.any_frame; 5954 B.top = Top(pw1) + 1; 5955 Clr_Det 5956 Check_Control_Overflow 5957 A[2] = A[4]; 5958 Next_Pp; 5959 5960 5961 /* 5962 * instructions for calling C builtins and externals 5963 */ 5964 5965 Case(ExtCall, I_ExtCall) 5966 proc = (PP++)->proc_entry; 5967 /* save for the profiler and in case an error is raised */ 5968 Export_B_Sp_Tg_Tt_Eb_Gb 5969 (void) (* PriFunc(proc))( A ); 5970 Import_Tg_Tt 5971 Check_Gc 5972 Pop_Ret_Code 5973 Handle_Events_Return 5974 Next_Pp; 5975 5976 5977 /* 5978 * C externals with ARGFIXEDWAM calling convention 5979 */ 5980 5981 Case(External0, I_External0) /* (proc,address) arity 0 */ 5982 proc = PP++->proc_entry; 5983 Export_B_Sp_Tg_Tt_Eb_Gb 5984 err_code = (*(PP->func)) (); 5985 goto _end_external_; 5986 5987 Case(External1, I_External1) /* (proc,address) arity 1 */ 5988 proc = PP++->proc_entry; 5989 pw1 = &A[1]; Dereference_Pw(pw1); 5990 Export_B_Sp_Tg_Tt_Eb_Gb 5991 err_code = (*(PP->func)) (pw1->val, pw1->tag); 5992 goto _end_external_; 5993 5994 Case(External2, I_External2) /* (proc,address) arity 2 */ 5995 proc = PP++->proc_entry; 5996 pw1 = &A[1]; Dereference_Pw(pw1); 5997 pw2 = &A[2]; Dereference_Pw(pw2); 5998 Export_B_Sp_Tg_Tt_Eb_Gb 5999 err_code = (*(PP->func)) ( 6000 pw1->val, pw1->tag, 6001 pw2->val, pw2->tag); 6002 goto _end_external_; 6003 6004 Case(External3, I_External3) /* (proc,address) arity 3 */ 6005 proc = PP++->proc_entry; 6006 pw1 = &A[1]; Dereference_Pw(pw1); 6007 pw2 = &A[2]; Dereference_Pw(pw2); 6008 S = &A[3]; Dereference_Pw(S); 6009 Export_B_Sp_Tg_Tt_Eb_Gb 6010 err_code = (*(PP->func)) ( 6011 pw1->val, pw1->tag, 6012 pw2->val, pw2->tag, 6013 S->val, S->tag); 6014 goto _end_external_; 6015 6016 Case(External, I_External) /* (proc, address) arity 4..16 */ 6017 proc = PP++->proc_entry; 6018 for (tmp1 = DidArity(PriDid(proc)); tmp1 > 4; --tmp1) 6019 { 6020 S = &A[tmp1]; Dereference_Pw(S); A[tmp1] = *S; 6021 } 6022 S = &A[4]; Dereference_Pw(S); A[4] = *S; 6023 S = &A[3]; Dereference_Pw(S); 6024 pw2 = &A[2]; Dereference_Pw(pw2); 6025 pw1 = &A[1]; Dereference_Pw(pw1); 6026 tmp1 = DidArity(PriDid(proc)); 6027 Export_B_Sp_Tg_Tt_Eb_Gb 6028 switch(tmp1) { 6029 case 4: 6030 err_code = (*(PP->func)) ( 6031 pw1->val, pw1->tag, 6032 pw2->val, pw2->tag, 6033 S->val, S->tag, 6034 A[4].val, A[4].tag); 6035 break; 6036 case 5: 6037 err_code = (*(PP->func)) ( 6038 pw1->val, pw1->tag, 6039 pw2->val, pw2->tag, 6040 S->val, S->tag, 6041 A[4].val, A[4].tag, 6042 A[5].val, A[5].tag); 6043 break; 6044 case 6: 6045 err_code = (*(PP->func)) ( 6046 pw1->val, pw1->tag, 6047 pw2->val, pw2->tag, 6048 S->val, S->tag, 6049 A[4].val, A[4].tag, 6050 A[5].val, A[5].tag, 6051 A[6].val, A[6].tag); 6052 break; 6053 case 7: 6054 err_code = (*(PP->func)) ( 6055 pw1->val, pw1->tag, 6056 pw2->val, pw2->tag, 6057 S->val, S->tag, 6058 A[4].val, A[4].tag, 6059 A[5].val, A[5].tag, 6060 A[6].val, A[6].tag, 6061 A[7].val, A[7].tag); 6062 break; 6063 case 8: 6064 err_code = (*(PP->func)) ( 6065 pw1->val, pw1->tag, 6066 pw2->val, pw2->tag, 6067 S->val, S->tag, 6068 A[4].val, A[4].tag, 6069 A[5].val, A[5].tag, 6070 A[6].val, A[6].tag, 6071 A[7].val, A[7].tag, 6072 A[8].val, A[8].tag); 6073 break; 6074 case 9: 6075 err_code = (*(PP->func)) ( 6076 pw1->val, pw1->tag, 6077 pw2->val, pw2->tag, 6078 S->val, S->tag, 6079 A[4].val, A[4].tag, 6080 A[5].val, A[5].tag, 6081 A[6].val, A[6].tag, 6082 A[7].val, A[7].tag, 6083 A[8].val, A[8].tag, 6084 A[9].val, A[9].tag); 6085 break; 6086 case 10: 6087 err_code = (*(PP->func)) ( 6088 pw1->val, pw1->tag, 6089 pw2->val, pw2->tag, 6090 S->val, S->tag, 6091 A[4].val, A[4].tag, 6092 A[5].val, A[5].tag, 6093 A[6].val, A[6].tag, 6094 A[7].val, A[7].tag, 6095 A[8].val, A[8].tag, 6096 A[9].val, A[9].tag, 6097 A[10].val, A[10].tag); 6098 break; 6099 case 11: 6100 err_code = (*(PP->func)) ( 6101 pw1->val, pw1->tag, 6102 pw2->val, pw2->tag, 6103 S->val, S->tag, 6104 A[4].val, A[4].tag, 6105 A[5].val, A[5].tag, 6106 A[6].val, A[6].tag, 6107 A[7].val, A[7].tag, 6108 A[8].val, A[8].tag, 6109 A[9].val, A[9].tag, 6110 A[10].val, A[10].tag, 6111 A[11].val, A[11].tag); 6112 break; 6113 case 12: 6114 err_code = (*(PP->func)) ( 6115 pw1->val, pw1->tag, 6116 pw2->val, pw2->tag, 6117 S->val, S->tag, 6118 A[4].val, A[4].tag, 6119 A[5].val, A[5].tag, 6120 A[6].val, A[6].tag, 6121 A[7].val, A[7].tag, 6122 A[8].val, A[8].tag, 6123 A[9].val, A[9].tag, 6124 A[10].val, A[10].tag, 6125 A[11].val, A[11].tag, 6126 A[12].val, A[12].tag); 6127 break; 6128 case 13: 6129 err_code = (*(PP->func)) ( 6130 pw1->val, pw1->tag, 6131 pw2->val, pw2->tag, 6132 S->val, S->tag, 6133 A[4].val, A[4].tag, 6134 A[5].val, A[5].tag, 6135 A[6].val, A[6].tag, 6136 A[7].val, A[7].tag, 6137 A[8].val, A[8].tag, 6138 A[9].val, A[9].tag, 6139 A[10].val, A[10].tag, 6140 A[11].val, A[11].tag, 6141 A[12].val, A[12].tag, 6142 A[13].val, A[13].tag); 6143 break; 6144 case 14: 6145 err_code = (*(PP->func)) ( 6146 pw1->val, pw1->tag, 6147 pw2->val, pw2->tag, 6148 S->val, S->tag, 6149 A[4].val, A[4].tag, 6150 A[5].val, A[5].tag, 6151 A[6].val, A[6].tag, 6152 A[7].val, A[7].tag, 6153 A[8].val, A[8].tag, 6154 A[9].val, A[9].tag, 6155 A[10].val, A[10].tag, 6156 A[11].val, A[11].tag, 6157 A[12].val, A[12].tag, 6158 A[13].val, A[13].tag, 6159 A[14].val, A[14].tag); 6160 break; 6161 case 15: 6162 err_code = (*(PP->func)) ( 6163 pw1->val, pw1->tag, 6164 pw2->val, pw2->tag, 6165 S->val, S->tag, 6166 A[4].val, A[4].tag, 6167 A[5].val, A[5].tag, 6168 A[6].val, A[6].tag, 6169 A[7].val, A[7].tag, 6170 A[8].val, A[8].tag, 6171 A[9].val, A[9].tag, 6172 A[10].val, A[10].tag, 6173 A[11].val, A[11].tag, 6174 A[12].val, A[12].tag, 6175 A[13].val, A[13].tag, 6176 A[14].val, A[14].tag, 6177 A[15].val, A[15].tag); 6178 break; 6179 case 16: 6180 err_code = (*(PP->func)) ( 6181 pw1->val, pw1->tag, 6182 pw2->val, pw2->tag, 6183 S->val, S->tag, 6184 A[4].val, A[4].tag, 6185 A[5].val, A[5].tag, 6186 A[6].val, A[6].tag, 6187 A[7].val, A[7].tag, 6188 A[8].val, A[8].tag, 6189 A[9].val, A[9].tag, 6190 A[10].val, A[10].tag, 6191 A[11].val, A[11].tag, 6192 A[12].val, A[12].tag, 6193 A[13].val, A[13].tag, 6194 A[14].val, A[14].tag, 6195 A[15].val, A[15].tag, 6196 A[16].val, A[16].tag); 6197 break; 6198 default: 6199 err_code = ARITY_LIMIT; 6200 } 6201_end_external_: 6202 Import_Tg_Tt 6203 if (Deterministic) 6204 { 6205 Pop_Ret_Code /* Retd */ 6206 } 6207 else if ((B.top - 1)->backtrack == external_fail_code_) 6208 { 6209 Set_Det /* Neckcut */ 6210 Cut_Last(pw1) 6211 Pop_Ret_Code /* Retd */ 6212 } 6213 else 6214 { 6215 Set_Det /* Retn */ 6216 Read_Ret_Code; 6217 } 6218 goto _bip_res1_; /* (err_code,proc) */ 6219 6220 6221#ifdef SPLIT_SWITCH 6222 6223 default: 6224 break; /* continue into the second switch */ 6225 6226 } /* end first switch */ 6227 6228 switch ((PP-1)->inst) 6229 { 6230 6231#endif /* SPLIT_SWITCH */ 6232 6233 6234/*---------------------------------------------------------------------- 6235 * Debug instructions 6236 *----------------------------------------------------------------------*/ 6237 6238/* 6239 * Raise a debug-event, i.e. trigger a debugger call 6240 * in the subsequent Call/Jmp/Chain instruction. Source 6241 * information may be supplied as quadruple (file,line,from,to) 6242 * The breakpoint manipulation mechanism relies on the exact 6243 * order of the [port, file, line, from, to] parameter group! 6244 */ 6245 6246 Case(Debug_call, I_Debug_call) /* proc, port, file, line, from, to */ 6247 if (TD || (PriFlags(PP[0].proc_entry) & DEBUG_ST)) { 6248 if (TD) { 6249#ifdef UNTESTED_FIX 6250 if (PriFlags(PP[0].proc_entry) & DEBUG_ST) 6251 { 6252 /* we abuse the DEBUG_SP bit to reinit creep/leap mode */ 6253 if (PriFlags(PP[0].proc_entry) & DEBUG_SP) 6254 TRACEMODE &= ~TR_LEAPING; 6255 } 6256#endif 6257 if (Tracing && AnyPortWanted && !InvisibleProc(PP[0].proc_entry)) { 6258 DBG_PRI = PP[0].proc_entry; 6259 DBG_PORT = PP[1].nint; 6260 DBG_PATH = PP[2].did; 6261 DBG_LINE = PP[3].nint; 6262 DBG_FROM = PP[4].nint; 6263 DBG_TO = PP[5].nint; 6264 DBG_INVOC = 0; 6265 Fake_Overflow; 6266 } 6267 } else /* if (PriFlags(proc) & DEBUG_ST) */ { 6268 if (TRACEMODE & TR_STARTED) { 6269 /* we abuse the DEBUG_SP bit to init creep/leap mode */ 6270 TRACEMODE |= (PriFlags(PP[0].proc_entry) & DEBUG_SP) ? 6271 TR_TRACING : TR_LEAPING; 6272 } 6273 if (AnyPortWanted) { 6274 DBG_PRI = PP[0].proc_entry; 6275 DBG_PORT = PP[1].nint; 6276 DBG_PATH = PP[2].did; 6277 DBG_LINE = PP[3].nint; 6278 DBG_FROM = PP[4].nint; 6279 DBG_TO = PP[5].nint; 6280 DBG_INVOC = 0; 6281 Fake_Overflow; 6282 } 6283 } 6284 } 6285 PP += 2 + SOURCE_POS_SZ; 6286 Next_Pp; 6287 6288 6289 Case(Debug_exit, I_Debug_exit) 6290 if(E < EB) { /* like Chain */ 6291 Pop_Env 6292 if(EB == SP) {Repush_Ret_Code} 6293 } else { 6294 Push_Ret_Code_To_Eb(ERetCode) 6295 Check_Local_Overflow 6296 E = ERetEnv; 6297 } 6298 A[1] = TAGGED_TD; /* Old call stack */ 6299 Pop_Dbg_Frame(); 6300 pw1 = A[1].val.ptr; 6301 if (ExitPortWanted && OfInterest(PriFlags(DProc(pw1)), DInvoc(pw1), DLevel(pw1), 0)) 6302 { 6303 /* call debug event(OldStack) */ 6304 proc = error_handler_[-(DEBUG_EXIT_EVENT)]; 6305 PP = (emu_code) PriCode(proc); 6306 } else { 6307 PP = (emu_code) return_code_; 6308 } 6309 Set_Det 6310 Next_Pp; 6311 6312 6313/* 6314 * Tracing of simple (i.e. implemented via instructions) builtins. 6315 * They have explicit EXIT_PORT instructions, and all shallow 6316 * if-then-elses have explicit FAIL_PORT instructions to catch 6317 * their failures. The problem is to establish whether an EXIT 6318 * or FAIL belongs to the current topmost trace frame because: 6319 * - the EXIT/FAIL port instruction may be inside an exception 6320 * handler raised by the builtin: this is checked using the 6321 * trace frame timestamp 6322 * - the CALL port may decide not to push a frame: this is 6323 * checked by looking whether the frame has the TF_SIMPLE flag 6324 * (we can't have nested TF_SIMPLEs without exception frame between) 6325 * The breakpoint manipulation mechanism relies on the exact 6326 * order of the [port, file, line, from, to] parameter group! 6327 */ 6328 6329#define Push_Bip_Debug_Goal(_pp,_did,_i,_mask) { \ 6330 (_i) = DidArity(_did);\ 6331 TG->val.did = (_did);\ 6332 TG++->tag.kernel = TDICT;\ 6333 do {\ 6334 switch((_mask) & 3) {\ 6335 case 0:\ 6336 *TG = *(_pp[-(_i)].ptr);\ 6337 break;\ 6338 case 1:\ 6339 Make_Atom(TG,d_.ellipsis);\ 6340 break;\ 6341 case 2:\ 6342 TG->val.nint = _pp[-(_i)].nint; TG->tag.kernel=TINT;\ 6343 break;\ 6344 case 3:\ 6345 Make_Atom(TG, _pp[-(_i)].did);\ 6346 break;\ 6347 }\ 6348 ++TG; (_mask) >>= 2;\ 6349 } while (--(_i)>0);\ 6350} 6351 6352#define Update_Bip_Debug_Goal(_pp,_i,_mask,_pgoal) { \ 6353 (_i) = DidArity(_pgoal[0].val.did);\ 6354 while (_mask) {\ 6355 ++(_pgoal);\ 6356 switch((_mask) & 3) {\ 6357 case 1:\ 6358 *(_pgoal) = *(_pp[-(_i)].ptr);\ 6359 break;\ 6360 }\ 6361 --(_i); (_mask) >>= 2;\ 6362 }\ 6363} 6364 6365 Case(Debug_call_simple, I_Debug_call_simple) /* proc, port, file, line, from, to, argdesc, argref */ 6366 if (!Tracing || !AnyPortWanted 6367 || (PP[1].nint & NO_ARGS) 6368 || InvisibleProc(PP[0].proc_entry)) 6369 { 6370 PP += 8; 6371 Next_Pp; /* debugger is off */ 6372 } 6373 /* 6374 * Construct the called goal: use the information provided by 6375 * the (usually subsequent) bi_xxx A_i1...A_iArity instruction, 6376 * referenced by the argdesc/argref parameters. 6377 */ 6378 proc = PP[0].proc_entry; 6379 val_did = PriDid(proc); 6380 tmp1 = DidArity(val_did); 6381 if (tmp1 > 0) { 6382 Make_Struct(&scratch_pw, TG); 6383 back_code = PP + 9 + PP[7].nint; /* bi_xxx instruction arguments */ 6384 if (PP[6].nint < 0) { 6385 i = back_code[0].nint; /* bi_xxx instruction's argdesc */ 6386 } else { 6387 i = PP[6].nint; /* debug instruction's argdesc */ 6388 } 6389 Push_Bip_Debug_Goal(back_code,val_did,tmp1,i); 6390 } else { 6391 Make_Atom(&scratch_pw, val_did); 6392 } 6393 err_code = PP[1].val.nint; /* port */ 6394 back_code = PP; 6395 PP += 8; 6396 6397 /* Push a trace frame */ 6398 if (TD < GB) { Trail_Pword(&TAGGED_TD); } 6399#ifdef USE_FIRST_FLAG 6400 /* we'd need to pass the old TD to the handler somehow */ 6401 ec_panic("USE_FIRST_FLAG unsupported", "emulator"); 6402 if (!(err_code & FIRST_CALL)) 6403 { 6404 tmp1 = DLevel(TD); /* depth */ 6405 TAGGED_TD = TD[TF_ANCESTOR]; /* pop exited frame */ 6406 } 6407 else 6408#endif 6409 { 6410 tmp1 = TD ? DLevel(TD)+1 : 0; /* depth */ 6411 } 6412 6413 Push_Dbg_Frame(pw1, NINVOC, scratch_pw.val, scratch_pw.tag, 6414 tmp1, WP, proc, 6415 back_code[2].did, back_code[3].nint, back_code[4].nint, back_code[5].nint, PriModule(proc)) 6416 NINVOC++; 6417 6418 /* Raise an exception to trace the call port, if it is of interest */ 6419 err_code &= BREAKPOINT; /* == TF_BREAK */ 6420 Set_Tf_Flag(TD, TF_SIMPLE|err_code) 6421 if (OfInterest(PriFlags(proc), NINVOC-1, tmp1, err_code)) 6422 { 6423 err_code = DEBUG_BIPCALL_EVENT; 6424 proc = true_proc_; /* dummy culprit */ 6425 goto _nbip_err_; /* (err_code, proc) */ 6426 } 6427 Next_Pp; 6428 6429 6430 Case(Debug_exit_simple_args, I_Debug_exit_simple_args) /* unused, <ref to debug_call_simple> */ 6431 if (TD && (TfFlags(TD) & TF_SIMPLE) && !OldStamp(&TD[TF_CHP_STAMP])) 6432 { 6433 if (!(TfFlags(TD) & TF_NOGOAL) 6434 && ExitPortWanted 6435 && OfInterest(PriFlags(DProc(TD)), DInvoc(TD), DLevel(TD), 0)) 6436 { 6437 /* If the goal had any uninitialised arguments, fill them in now */ 6438 back_code = PP[1].code + 1; /* debug_call_simple instruction */ 6439 if (back_code[6].nint < 0) { 6440 back_code = back_code + 9 + back_code[7].nint; /* bi_xxx instruction arguments */ 6441 i = back_code[0].nint; /* bi_xxx instruction's argdesc */ 6442 } else { 6443 i = back_code[6].nint; /* debug_call_simple instruction's argdesc */ 6444 back_code = back_code + 9 + back_code[7].nint; /* bi_xxx instruction arguments */ 6445 } 6446 pw1 = DGoal(TD).val.ptr; 6447 Update_Bip_Debug_Goal(back_code,tmp1,i,pw1); 6448 6449 /* handler will trace the exit and pop the frame */ 6450 err_code = DEBUG_BIPEXIT_EVENT; 6451 proc = true_proc_; /* dummy culprit */ 6452 PP += 2; 6453 goto _nbip_err_; /* (err_code, proc) */ 6454 } else { 6455 Pop_Dbg_Frame(); 6456 } 6457 } 6458 PP += 2; 6459 Next_Pp; 6460 6461 6462 Case(Debug_exit_simple, I_Debug_exit_simple) 6463 if (TD && (TfFlags(TD) & TF_SIMPLE) && !OldStamp(&TD[TF_CHP_STAMP])) 6464 { 6465 if (!(TfFlags(TD) & TF_NOGOAL) 6466 && ExitPortWanted 6467 && OfInterest(PriFlags(DProc(TD)), DInvoc(TD), DLevel(TD), 0)) 6468 { 6469 /* handler will trace the exit and pop the frame */ 6470 err_code = DEBUG_BIPEXIT_EVENT; 6471 proc = true_proc_; /* dummy culprit */ 6472 goto _nbip_err_; /* (err_code, proc) */ 6473 } else { 6474 Pop_Dbg_Frame(); 6475 } 6476 } 6477 Next_Pp; 6478 6479#if 0 6480 Case(Debug_fail_simple, I_Debug_fail_simple) 6481 if (TD && (TfFlags(TD) & TF_SIMPLE) && !OldStamp(&TD[TF_CHP_STAMP])) 6482 { 6483 FCULPRIT = DInvoc(TD); 6484 if (!(TfFlags(TD) & TF_NOGOAL) 6485 && OfInterest(PriFlags(proc), DInvoc(TD), DLevel(TD), 0) ) 6486 { 6487 err_code = DEBUG_BIPFAIL_EVENT; 6488 proc = true_proc_; /* dummy culprit */ 6489 goto _nbip_err_; /* (err_code,proc) */ 6490 } else { 6491 Pop_Dbg_Frame(); 6492 } 6493 } 6494 Next_Pp; 6495#endif 6496 6497 6498/*----------------------------------------------------------------------*/ 6499 6500 Case(Undefined, I_Undefined) /* (proc) */ 6501 proc = PP->proc_entry; 6502 val_did = PriDid(proc); 6503 /* save the (unchecked) caller module into scratch_pw */ 6504 if (proc->flags & TOOL) 6505 scratch_pw = A[DidArity(val_did) + 1]; 6506 else /* use the descriptor's module */ 6507 { 6508 Make_Marked_Module(&scratch_pw, PriModule(proc)); 6509 /* the module tag can be marked safely since a locked 6510 module should never call an undefined procedure 6511 (if it is a feature, it should be tested first 6512 with is_predicate). */ 6513 } 6514 /* build a goal structure and put it into A[2] */ 6515 tmp1 = DidArity(val_did); 6516 if(tmp1 == 0) { 6517 Make_Atom(&A[2], val_did); 6518 } else { 6519 S = TG; /* build goal structure */ 6520 TG += tmp1 + 1; 6521 S->val.did = val_did; 6522 (S++)->tag.kernel = TDICT; 6523 pw1 = &A[1]; 6524 for(i = 0; i < tmp1; i++) { 6525 pw2 = pw1++; 6526 Move_Pw_To_Global_Stack(pw2,S, ;) 6527 } 6528 Make_Struct(&A[2], TG - tmp1 - 1); 6529 Check_Gc 6530 } 6531 /* move caller module to A[3] */ 6532 A[3] = scratch_pw; 6533 err_code = CALLING_AUTOLOAD; 6534 /* 6535 * Put lookup module in A[4]: as opposed to Make_Lookup_Module() 6536 * the code here prefers to use the home module because that is 6537 * the one we need for autoloading if it doesn't exist yet. 6538 */ 6539 if (PriIsProxy(proc) && PriModule(proc) != PriHomeModule(proc)) 6540 { 6541 Make_Atom(&A[4], PriHomeModule(proc)); 6542 if (!IsModule(PriHomeModule(proc))) 6543 err_code = NO_LOOKUP_MODULE; 6544 } 6545 else 6546 { 6547 Make_Marked_Module(&A[4], PriModule(proc)); 6548 } 6549 Pop_Ret_Code 6550 goto _regular_err_2_; /* (err_code, A2 goal, A3 caller, A4 lookup) */ 6551 6552 6553 6554 Case(Call_dynamic, I_Call_dynamic) /* (proc,handle) */ 6555 proc = PP[0].proc_entry; 6556 val_did = PriDid(proc); 6557 /* build a goal structure and put it into A[2] */ 6558 tmp1 = DidArity(val_did); 6559 if(tmp1 == 0) { 6560 Make_Atom(&A[2], val_did); 6561 } else { 6562 S = TG; /* build goal structure */ 6563 TG += tmp1 + 1; 6564 S->val.did = val_did; 6565 (S++)->tag.kernel = TDICT; 6566 pw1 = &A[1]; 6567 for(i = 0; i < tmp1; i++) { 6568 pw2 = pw1++; 6569 Move_Pw_To_Global_Stack(pw2,S, ;) 6570 } 6571 Make_Struct(&A[2], TG - tmp1 - 1); 6572 Check_Gc 6573 } 6574 A[1].val.ptr = PP[1].ptr; 6575 A[1].tag.kernel = THANDLE; 6576 Make_Marked_Module(&A[3], PriModule(proc)); 6577 proc = error_handler_[-(CALLING_DYNAMIC)]; 6578 PP = (emu_code) PriCode(proc); 6579 Next_Pp; 6580 6581 6582 6583/* 6584 * The first instruction of exit_block/1: 6585 * check whether the argument is ok, then find a block frame which 6586 * has a suitable tag and is an ancestor of this goal, 6587 * reset the machine and unify the two tags 6588 */ 6589 Case(Throw, I_Throw) 6590 pw3 = &A[1]; 6591 Dereference_Pw_Tag(pw3, tmp1); 6592 if (ISRef(tmp1)) 6593 { 6594 val_did = d_.throw1; 6595 err_code = INSTANTIATION_FAULT; 6596 Pop_Ret_Code 6597 goto _regular_err_; 6598 } 6599 /* the exit tag (ball) may disappear, so we save it */ 6600 if (ISSimple(tmp1)) { 6601 scratch_pw = *pw3; 6602 } else { 6603 Export_B_Sp_Tg_Tt 6604 create_heapterm(&scratch_pw, pw3->val, pw3->tag); 6605 Import_None; 6606 } 6607 6608 pw1 = B.args; 6609 pw2 = E; 6610 for (;;) /* (pw1, pw2, pw3) */ 6611 { 6612 if (IsCatchFrame(BTop(pw1))) 6613 { 6614 /* find the first environment older than the catch frame */ 6615 while (RetCodeAddr(pw2) < BChp(pw1)->sp) 6616 pw2 = RetEnv(pw2); 6617 /* was the block/3 called from this environment? */ 6618 if (RetCodeAddr(pw2) == BChp(pw1)->sp) 6619 { 6620 pw2 = (pword *)(BChp(pw1) + 1); 6621 /* we first only check whether the tags would 6622 * unify; it is done in the current state, hence 6623 * we have to dereference the catch tag 6624 */ 6625 Dereference_Pw_Tag(pw2, tmp1); 6626 if (ISRef(tmp1)) 6627 break; 6628 if (SameTypeC(pw3->tag, tmp1)) 6629 { 6630 if (ISSimple(tmp1)) { 6631 if (SimpleEq(tmp1, pw3->val, pw2->val)) 6632 break; 6633 } else { 6634 Export_B_Sp_Tg_Tt_Eb_Gb 6635 if (ec_unify_(pw3->val, pw3->tag, pw2->val, pw2->tag, &MU) == PSUCCEED) 6636 { 6637 Import_Tg_Tt; 6638 break; 6639 } 6640 Import_Tg_Tt; 6641 } 6642 } 6643 pw2 = BChp(pw1)->e; 6644 } 6645 /* not the right catch frame, skip it */ 6646 pw1 = BPrev(pw1); 6647 } 6648 else if (IsInterruptFrame(BTop(pw1))||IsRecursionFrame(BTop(pw1))) 6649 { 6650 /* exit an emulator: restore everything from the invoc frame. 6651 * Normally we will continue throwing in an earlier emulator 6652 * invocation, but that's not sure because the C code can 6653 * choose not to propagate the throw. Therefore we must 6654 * restore the engine to a reasonable state now rather 6655 * than wait for the catch! 6656 */ 6657 err_code = PTHROW; 6658 B.args = pw1; 6659 Export_B_Sp_Tg_Tt 6660 free_heapterm(&scratch_pw); 6661 Import_None; 6662 scratch_pw = *pw3; 6663 goto _exit_emulator_; /* (err_code,scratch_pw) */ 6664 } 6665 else /* other frame, skip it */ 6666 pw1 = BPrev(pw1); 6667 } 6668 6669/* We finally found a matching ball !! 6670 * pw1: top of the catch frame 6671 * scratch_pw: copy of dereferenced Ball, 6672 */ 6673 /* If the frame indicates that events are to be deferred 6674 * then set the flag */ 6675 if (IsCatchEventsDeferredFrame(BTop(pw1))) 6676 { 6677 VM_FLAGS |= EVENTS_DEFERRED; 6678 } 6679 6680 if (TD) /* find out how deep we fail */ 6681 { 6682 pword *td = TD; 6683 FDROP = 0; 6684 if (!OlderStampThanGlobalAddress(&TD[TF_CHP_STAMP],BChp(pw1)->tg)) 6685 FCULPRIT = DInvoc(TD); 6686 for (; td && !OlderStampThanGlobalAddress(&td[TF_CHP_STAMP],BChp(pw1)->tg); td = DAncestor(td), ++FDROP) 6687 { 6688 /*p_fprintf(log_output_, "\n(%d) %d fail", DInvoc(td), DLevel(td));*/ 6689 if (FDROP < MAX_FAILTRACE) 6690 { 6691 FTRACE[FDROP].invoc = DInvoc(td); 6692 FTRACE[FDROP].proc = DProc(td); 6693 FTRACE[FDROP].source_pos.file = DPath(td); 6694 FTRACE[FDROP].source_pos.line = DLine(td); 6695 FTRACE[FDROP].source_pos.from = DFrom(td); 6696 FTRACE[FDROP].source_pos.to = DTo(td); 6697 } 6698 } 6699 RLEVEL = td ? DLevel(td) : -1; 6700 DBG_DELAY_INVOC = 0; /* if set for DEBUG_DELAY_EVENT */ 6701 } 6702 else { RLEVEL = -1; FDROP = 0; } 6703 6704 /* 6705 * Before untrailing, cut everything above the catch frame. 6706 * This will suppress unnecessary timestamped undo-untrails. 6707 */ 6708 Cut_To(pw1); 6709 pw1 = BPrev(B.args); 6710#ifdef NEW_ORACLE 6711 /* this is preliminary, catch-throw not yet properly oracled */ 6712 if (TO) 6713 TO = Chp(pw1)->tg - ORC_SIZE; 6714#endif 6715 b_aux.args = pw1; /* save pw1 temporarily */ 6716 Untrail_Variables(b_aux.chp->tt, i, pw1); 6717 pw1 = b_aux.args; 6718 SP = Chp(pw1)->sp; 6719 Wipe(Chp(pw1)->tg,TG); 6720 TG = Chp(pw1)->tg; 6721 E = Chp(pw1)->e; 6722 LD = Chp(pw1)->ld; 6723 MU = 0; 6724 Adjust_GcTg_and_TgSl(TG); 6725 pw1 = (pword *)(Chp(pw1) + 1); 6726 A[7] = *pw1++; /* A7 = Catcher */ 6727 A[1] = *pw1++; /* A1 = recovery goal */ 6728 A[2] = *pw1++; /* A2 = module */ 6729 B.args = pw1 = Top(pw1)->frame.args; /* pop catch frame */ 6730 pw1 = (Top(pw1) - 1)->frame.args; 6731 EB = Chp(pw1)->sp; 6732 GB = Chp(pw1)->tg; 6733 Debug_Check_Global 6734 6735 if ( FDROP > 0 && PortWanted(LEAVE_PORT) 6736 || TD && RLEVEL != DLevel(TD) && PortWanted(PREDO_PORT) 6737 || Tracing && PortWanted(NEXT_PORT)) 6738 { 6739 tmp1 = 2; /* arity of call(Recov, Module) */ 6740 { 6741 Push_Env 6742 PushDynEnvHdr(tmp1, 0, PP); /* save arity, PP */ 6743 PP = (emu_code) &restore_code_[1]; 6744 pw1 = &A[1]; /* save the argument registers */ 6745 for (; tmp1; --tmp1) 6746 *(--SP) = *pw1++; 6747 } 6748 Push_Ret_Code(PP) 6749 Check_Local_Overflow 6750 Set_Det 6751 6752 proc = error_handler_[-(DEBUG_REDO_EVENT)]; 6753 PP = (emu_code) PriCode(proc); 6754 A[1] = TAGGED_TD; 6755 Make_Integer(&A[2], FDROP); 6756 Make_Integer(&A[3], RLEVEL); 6757 Make_Integer(&A[4], LEAVE_PORT); 6758 Make_Integer(&A[5], NEXT_PORT); /* show NEXT port? */ 6759 } 6760 6761 /* Get the saved Ball and unify it with the Catcher */ 6762 pw1 = &scratch_pw; 6763 if (!IsSimple(scratch_pw.tag)) 6764 { 6765 pw1 = &A[6]; /* use any free pword */ 6766 Export_B_Sp_Tg_Tt 6767 get_heapterm(&scratch_pw, pw1); 6768 free_heapterm(&scratch_pw); 6769 Import_Tg_Tt; 6770 } 6771 pw2 = &A[7]; 6772 goto _unify_; /* (pw1, pw2) */ 6773 6774 6775/* 6776 * Continue_after_exception is executed after a bip error handler 6777 * succeeded or failed. For failure, it would normally be enough to 6778 * do a Refail, but in case we fail to a small if-then-else choicepoint 6779 * we could not restore all the information. 6780 */ 6781 Case(Continue_after_exception, I_Continue_after_exception) 6782 /* pop frames until exception frame found */ 6783 pw1 = (pword *) (B.top - 1); 6784 while (Top(pw1)->backtrack != exception_fail_code_ ) 6785 pw1 = (pword *) (Top(pw1)->frame.top - 1); 6786 B.top = Top(pw1); /* similar to Cut_To(pw1) */ 6787 pw1 = Top(pw1)->frame.args; 6788 EB = Exception(pw1)->eb; 6789 GB = Exception(pw1)->gb; 6790 while (LCA >= GB) { 6791 Export_B_Sp_Tg_Tt_Eb_Gb 6792 do_cut_action(); 6793 Import_Tg_Tt; 6794 } 6795 Cut_To_Parallel(pw1); 6796 SP = Exception(pw1)->sp; /* pop the local stack */ 6797 E = Exception(pw1)->e; /* maybe changed by handler */ 6798 emu_flags = Exception(pw1)->flags; 6799 DE = Exception(pw1)->de; 6800 Restore_Tg_Soft_Lim(Exception(pw1)->tg_soft_lim); 6801#ifdef STRICT_EXCEPTION 6802 WP = Exception(pw1)->wp; 6803 MU = Exception(pw1)->mu; 6804 if (MU) { Fake_Overflow; } 6805#endif 6806 pw1 = (pword *) (Exception(pw1) + 1); 6807 pw2 = &A[1]; /* restore args, if any */ 6808 while (pw1 < B.args) 6809 *pw2++ = *pw1++; 6810 B.any_frame = B.top->frame; /* pop exception frame */ 6811 Next_Pp; 6812 6813 6814 Case(Exit_emulator, I_Exit_emulator) /* return code */ 6815 err_code = PP++->nint; 6816_exit_emulator_: /* (err_code[,scratch_pw]) */ 6817 pw1 = (B.top - 1)->frame.args; 6818 SP = (pword *)((emu_code *)Invoc(pw1)->sp + 1); 6819 if (err_code == PKEEP) { 6820 err_code = PSUCCEED; 6821 } else { 6822 if (err_code != PTHROW) { 6823 /* for PTHROW, this is done in I_Throw */ 6824 Untrail_Variables(Invoc(pw1)->tt, i, pw2); 6825 Wipe(Invoc(pw1)->tg_before,TG); 6826 TG = Invoc(pw1)->tg_before; 6827 LD = Invoc(pw1)->ld; 6828 } 6829 TAGGED_WL = Invoc(pw1)->wl; 6830 Restore_Tg_Soft_Lim(Invoc(pw1)->tg_soft_lim); 6831 } 6832 E = Invoc(pw1)->e; 6833 EB = Invoc(pw1)->eb; 6834 GB = Invoc(pw1)->gb; 6835 Debug_Check_Global 6836 if (IsInterruptFrame((B.top - 1))) 6837 { 6838 VM_FLAGS = (VM_FLAGS & ~INT_SAFE_BITS) 6839 | (Invoc(pw1)->flags & INT_SAFE_BITS); 6840 destroy_parser_env(); 6841 PARSENV = Invoc(pw1)->parser_env; 6842 g_emu_.trace_data = Invoc(pw1)->trace_data; 6843 PostponedList = Invoc(pw1)->postponed_list; 6844 } 6845 g_emu_.it_buf = Invoc(pw1)->it_buf; 6846 g_emu_.nesting_level = Invoc(pw1)->nesting_level; 6847 g_emu_.global_variable = Invoc(pw1)->global_variable; 6848 6849 WP = Invoc(pw1)->wp; 6850 WP_STAMP = Invoc(pw1)->wp_stamp; 6851 MU = Invoc(pw1)->mu; 6852 SV = Invoc(pw1)->sv; 6853 DE = Invoc(pw1)->de; 6854#ifdef PB_MAINTAINED 6855 PB = Invoc(pw1)->pb; 6856#endif 6857#ifdef NEW_ORACLE 6858 TO = Invoc(pw1)->oracle; 6859 FO = Invoc(pw1)->followed_oracle; 6860 PO = Invoc(pw1)->pending_oracle; 6861#endif 6862 PPB = Invoc(pw1)->ppb; 6863 Set_Bip_Error(Invoc(pw1)->global_bip_error); 6864 GCTG = Invoc(pw1)->gctg; 6865 PP = (emu_code) Invoc(pw1)->pp; 6866 6867 pw2 = &A[0]; 6868 pw1 = &Invoc(pw1)->arg_0; 6869 while(Top(pw1) < B.top - 1) 6870 *pw2++ = *pw1++; 6871 B.args = Top(pw1)->frame.args - SAFE_B_AREA; 6872 Export_All 6873 re_fake_overflow(); /* after export */ 6874 A[0].val.nint = err_code; 6875 if (err_code == PTHROW) 6876 A[1] = scratch_pw; 6877 return (func_ptr) 0; 6878 6879 Case(Bounce, I_Bounce) /* bounce over the trampoline */ 6880 PP++; 6881 Export_All 6882 /* 6883 { 6884 extern func_ptr compiledcode(); 6885 return (func_ptr) compiledcode; 6886 } 6887 */ 6888 return (func_ptr) (PP-1)->func; 6889 6890 6891 Case(Gc, I_Gc) /* (forceflag) */ 6892 tmp1 = PP++->offset; 6893 Export_B_Sp_Tg_Tt_Eb_Gb 6894 err_code = collect_stacks(0, tmp1); 6895 Import_B_Sp_Tg_Tt_Eb_Gb 6896#if 0 6897 if (err_code > 0) /* request to leave a choicepoint */ 6898 { 6899 pw1 = B.args; 6900 if (!IsGcFrame(BTop(pw1))) 6901 { 6902 B.chp = Chp(pw1) + 1; 6903 B.top->frame.top = Top(pw1); 6904 B.top->backtrack = gc_fail_code_; 6905 B.top++; 6906 Check_Control_Overflow 6907 Chp(pw1)->sp = EB = SP; 6908 Chp(pw1)->e = E; 6909 Clr_Det; 6910 } 6911 else /* reuse the existing one */ 6912 { 6913 /* Do not update E and SP fields in the choicepoint, 6914 * because that can interfere with subsequent cuts! 6915 */ 6916 pw1 = BPrev(pw1); 6917 EB = Chp(pw1)->sp; 6918 } 6919 Chp(pw1)->tg = GB = TG; 6920 Push_Witness 6921 Chp(pw1)->tt = TT; 6922 Chp(pw1)->ld = LD; 6923 GCTG = TG; 6924 } 6925 else if (err_code < 0) /* invalidate dummy choicepoint */ 6926 { 6927 pw1 = BPrev(B.args); 6928 Chp(pw1)->tg = GB = BChp(pw1)->tg; 6929 Chp(pw1)->tt = BChp(pw1)->tt; 6930 Chp(pw1)->ld = BChp(pw1)->ld; 6931 while (LCA >= GB) 6932 { 6933 Export_B_Sp_Tg_Tt; 6934 do_cut_action(); 6935 Import_Tg_Tt; 6936 } 6937 GCTG = TG; 6938 } 6939#endif 6940 Next_Pp; 6941 6942 6943#ifdef OLD_DYNAMIC 6944 Case(Clause, I_Clause) /* Head, Body, Ref, Module, Error */ 6945 err_code = 0; 6946 pw1 = &A[1]; /* clause head */ 6947 Dereference_Pw(pw1); 6948 pw2 = &A[4]; /* module */ 6949 Dereference_Pw(pw2); 6950 if (IsRef(pw1->tag) || IsRef(pw2->tag)) 6951 err_code = INSTANTIATION_FAULT; 6952 else if (!IsAtom(pw2->tag)) 6953 err_code = TYPE_ERROR; 6954 else if (!IsModule(pw2->val.did)) 6955 err_code = MODULENAME; 6956 else if IsStructure(pw1->tag) /* find the did */ 6957 val_did = pw1->val.ptr->val.did; 6958 else if IsAtom(pw1->tag) 6959 val_did = pw1->val.did; 6960 else if IsList(pw1->tag) 6961 val_did = d_.list; 6962 else if IsNil(pw1->tag) 6963 val_did = d_.nil; 6964 else 6965 err_code = TYPE_ERROR; 6966 6967 if (err_code == 0) /* there is no instantiation fault 6968 or type error */ 6969 { 6970 Export_B_Sp_Tg_Tt 6971 proc = visible_procedure(val_did, pw2->val.did, pw2->tag, 0); 6972 Import_None 6973 if (proc) 6974 { 6975 if (proc->module_ref == pw2->val.did) 6976 { 6977 if (DynamicProc(proc)) 6978 { 6979 PP = (emu_code) StartOfProcSource(PriCode(proc)); 6980 Next_Pp; /* go and execute the source clause*/ 6981 } 6982 else if (PriFlags(proc) & CODE_DEFINED) 6983 err_code = NOT_DYNAMIC; 6984 else 6985 err_code = ACCESSING_UNDEF_DYN_PROC; 6986 } 6987 else 6988 err_code = ACCESSING_NON_LOCAL; 6989 } 6990 else 6991 { 6992 Get_Bip_Error(err_code); 6993 if (err_code == NOENTRY) 6994 err_code = ACCESSING_UNDEF_DYN_PROC; 6995 } 6996 } 6997 /* we have an error */ 6998 pw1 = &A[5]; /* bind error code */ 6999 Dereference_Pw(pw1); 7000 Trail_If_Needed(pw1); 7001 pw1->val.nint = -err_code; 7002 pw1->tag.kernel = TINT; 7003 Next_Pp; 7004#endif 7005 7006 7007/*---------------------------------------------------------------------- 7008 * Abstract machine instructions for compilation of builtins 7009 *----------------------------------------------------------------------*/ 7010 7011 Case(BI_Exit, I_BI_Exit) 7012 err_code = PP->arg->val.nint; 7013 goto _exit_emulator_; 7014 7015 Case(BI_CutToStamp, I_BI_CutToStamp) /* Ai Aj Mask=0000 */ 7016 Get_Argument(pw2) 7017 Dereference_Pw(pw2); 7018 Get_Argument(pw1) 7019 Dereference_Pw(pw1); 7020 ++PP; 7021 if (!IsStructure(pw2->tag) || !IsInteger(pw1->tag)) { 7022 err_code = TYPE_ERROR; 7023 proc = cut_to_stamp_proc_; 7024 goto _nbip_err_; 7025 } 7026 pw2 = pw2->val.ptr; 7027 if (pw1->val.nint < 1 || pw1->val.nint > DidArity(pw2->val.did)) { 7028 err_code = RANGE_ERROR; 7029 proc = cut_to_stamp_proc_; 7030 goto _nbip_err_; 7031 } 7032 pw2 += pw1->val.nint; 7033 if (!IsRef(pw2->tag)) { 7034 err_code = TYPE_ERROR; 7035 proc = cut_to_stamp_proc_; 7036 goto _nbip_err_; 7037 } 7038 /* We should probably have some extra checks here to guard against 7039 * cutting through invocation frames and maybe even blocks. */ 7040 for(pw1 = B.args; OlderStamp(pw2,pw1); pw1 = BPrev(pw1)) 7041 ; 7042 Cut_To(pw1); /* Cut all choicepoints newer than the stamp */ 7043 Next_Pp; 7044 7045 Case(BI_SetBipError, I_BI_SetBipError) 7046 if (g_emu_.global_bip_error == 0) 7047 { 7048 Get_Argument(pw1) 7049 Dereference_Pw_Tag(pw1, tmp1); 7050 if (IsTag(tmp1, TINT)) 7051 Set_Bip_Error(- pw1->val.nint); 7052 } 7053 Fail; 7054 7055 Case(BI_GetBipError, I_BI_GetBipError) /* Ai(uninit) */ 7056 Get_Bip_Error(err_code); 7057 if (err_code) 7058 { 7059 Get_Argument(pw1) 7060 Make_Integer(pw1, -err_code); 7061 Next_Pp; 7062 } 7063 Fail; 7064 7065 Case(BI_Free, I_BI_Free) 7066 Get_Argument(pw1) 7067 Dereference_Pw_Tag(pw1, tmp1); 7068 if (!(ISVar(tmp1) || IsTag(tmp1,TNAME))) { Fail } 7069 Next_Pp; 7070 7071 Case(BI_Var, I_BI_Var) 7072 Get_Argument(pw1) 7073 Dereference_Pw_Tag(pw1, tmp1); 7074 if (!ISRef(tmp1)) { Fail } 7075 Next_Pp; 7076 7077 Case(BI_NonVar, I_BI_NonVar) 7078 Get_Argument(pw1) 7079 Dereference_Pw_Tag(pw1, tmp1); 7080 if (ISRef(tmp1)) { Fail } 7081 Next_Pp; 7082 7083 Case(BI_Atom, I_BI_Atom) 7084 Get_Argument(pw1) 7085 Dereference_Pw_Tag(pw1, tmp1); 7086 if (!(IsTag(tmp1, TDICT) || IsTag(tmp1, TNIL))) { Fail } 7087 Next_Pp; 7088 7089 Case(BI_Integer, I_BI_Integer) 7090 Get_Argument(pw1) 7091 Dereference_Pw_Tag(pw1, tmp1); 7092 if (!(IsTag(tmp1, TINT) || IsTag(tmp1,TBIG))) { Fail } 7093 Next_Pp; 7094 7095 Case(BI_Bignum, I_BI_Bignum) 7096 Get_Argument(pw1) 7097 Dereference_Pw_Tag(pw1, tmp1); 7098 if (!IsTag(tmp1,TBIG)) { Fail } 7099 Next_Pp; 7100 7101 Case(BI_Float, I_BI_Float) 7102 Get_Argument(pw1) 7103 Dereference_Pw_Tag(pw1, tmp1); 7104 if (!IsTag(tmp1,TDBL)) { Fail } 7105 Next_Pp; 7106 7107 Case(BI_Breal, I_BI_Breal) 7108 Get_Argument(pw1) 7109 Dereference_Pw_Tag(pw1, tmp1); 7110 if (!(IsTag(tmp1,TIVL))) { Fail } 7111 Next_Pp; 7112 7113 Case(BI_Real, I_BI_Real) 7114 Get_Argument(pw1) 7115 Dereference_Pw_Tag(pw1, tmp1); 7116 if (!(IsTag(tmp1,TDBL) || IsTag(tmp1,TIVL))) 7117 { Fail } 7118 Next_Pp; 7119 7120 Case(BI_Rational, I_BI_Rational) 7121 Get_Argument(pw1) 7122 Dereference_Pw_Tag(pw1, tmp1); 7123 if (!IsTag(tmp1,TRAT)) { Fail } 7124 Next_Pp; 7125 7126 Case(BI_String, I_BI_String) 7127 Get_Argument(pw1) 7128 Dereference_Pw_Tag(pw1, tmp1); 7129 if (!IsTag(tmp1,TSTRG)) { Fail } 7130 Next_Pp; 7131 7132 Case(BI_Number, I_BI_Number) 7133 Get_Argument(pw1) 7134 Dereference_Pw_Tag(pw1, tmp1); 7135 if (ISRef(tmp1) || !tag_desc[TagTypeC(tmp1)].numeric) { Fail } 7136 Next_Pp; 7137 7138 Case(BI_Atomic, I_BI_Atomic) 7139 /* break original || into two ifs -- original did not compile 7140 correctly on NT with gcc */ 7141 Get_Argument(pw1) 7142 Dereference_Pw_Tag(pw1, tmp1); 7143 if (ISRef(tmp1)) { Fail } 7144 if (IsTag(tmp1, TLIST) || IsTag(tmp1, TCOMP)) { Fail } 7145 Next_Pp; 7146 7147 Case(BI_Compound, I_BI_Compound) 7148 Get_Argument(pw1) 7149 Dereference_Pw_Tag(pw1, tmp1); 7150 if (!(IsTag(tmp1, TLIST) || IsTag(tmp1, TCOMP))) { Fail } 7151 Next_Pp; 7152 7153 Case(BI_Callable, I_BI_Callable) 7154 Get_Argument(pw1) 7155 Dereference_Pw_Tag(pw1, tmp1); 7156 if (!(IsTag(tmp1,TCOMP) || IsTag(tmp1,TDICT) || 7157 IsTag(tmp1,TLIST) || IsTag(tmp1,TNIL))) { Fail } 7158 Next_Pp; 7159 7160 Case(BI_Meta, I_BI_Meta) 7161 Get_Argument(pw1) 7162 Dereference_Pw_Tag(pw1, tmp1); 7163 if (!IsTag(tmp1,TMETA)) { Fail } 7164 Next_Pp; 7165 7166 Case(BI_IsSuspension, I_BI_IsSuspension) 7167 Get_Argument(pw1) 7168 Dereference_Pw_Tag(pw1, tmp1); 7169 if (!IsTag(tmp1, TSUSP) || SuspDead(pw1->val.ptr)) { 7170 Fail; 7171 } 7172 Next_Pp; 7173 7174 Case(BI_IsHandle, I_BI_IsHandle) 7175 Get_Argument(pw1) 7176 Dereference_Pw_Tag(pw1, tmp1); 7177 if (!IsTag(tmp1, THANDLE)) { 7178 Fail; 7179 } 7180 Next_Pp; 7181 7182 Case(BI_IsEvent, I_BI_IsEvent) 7183 Get_Argument(pw1) 7184 Dereference_Pw_Tag(pw1, tmp1); 7185 if (IsTag(tmp1, THANDLE) && IsTag(pw1->val.ptr->tag.kernel, TEXTERN)) { 7186 extern t_ext_type heap_event_tid; 7187 if (ExternalClass(pw1->val.ptr) != &heap_event_tid) { 7188 Fail; 7189 } 7190 } 7191 else { 7192 if (!(IsAtom(pw1->tag) || IsNil(pw1->tag))) { Fail } 7193 } 7194 Next_Pp; 7195 7196 Case(BI_IsList, I_BI_IsList) 7197 Get_Argument(pw1) 7198 Dereference_Pw_Tag(pw1, tmp1); 7199 while (IsTag(tmp1, TLIST)) { 7200 pw1 = pw1->val.ptr + 1; 7201 Dereference_Pw_Tag(pw1, tmp1); 7202 } 7203 if (!IsTag(tmp1, TNIL)) { 7204 Fail; 7205 } 7206 Next_Pp; 7207 7208 Case(BI_ListEnd, I_BI_ListEnd) /* list_end(?List, -End) */ 7209 Get_Argument(pw1) 7210 Dereference_Pw_Tag(pw1, tmp1); 7211 while (IsTag(tmp1, TLIST)) { 7212 pw1 = pw1->val.ptr + 1; 7213 Dereference_Pw_Tag(pw1, tmp1); 7214 } 7215 Get_Argument(pw2) 7216 *pw2 = *pw1; 7217 Next_Pp; 7218 7219 7220 /* 7221 * ==/2, \==/2 and ~=/2 are implemented with the diff routine 7222 */ 7223 Case(BI_Identical, I_BI_Identical) 7224 Get_Argument(pw1) 7225 Get_Argument(pw2) 7226 proc = identical_proc_; 7227 goto _diff_; /* (proc, pw1, pw2) */ 7228 7229 Case(BI_NotIdentical, I_BI_NotIdentical) 7230 Get_Argument(pw1) 7231 Get_Argument(pw2) 7232 proc = not_identical_proc_; 7233 goto _diff_; /* (proc, pw1, pw2) */ 7234 7235 Case(BI_Inequality, I_BI_Inequality) 7236 Get_Argument(pw1) 7237 Get_Argument(pw2) 7238 proc = inequality_proc_; 7239 goto _diff_; /* (proc, pw1, pw2, PP) */ 7240 7241 Case(BI_NotIdentList, I_BI_NotIdentList) 7242 Get_Argument(pw1) 7243 Get_Argument(pw2) 7244 /* 3rd argument read later! */ 7245 proc = not_ident_list_proc_; 7246 goto _diff_; /* (proc, pw1, pw2, PP) */ 7247 7248 Case(BI_ContDebug, I_BI_ContDebug) 7249 /* Allow normal tracing again, except pred is skipped. 7250 * Always allow tracing wakes again. 7251 */ 7252 if (TD) 7253 { 7254 Clr_Tf_Flag(TD, TF_INTRACER); 7255#ifdef PRINTAM 7256 if (TfFlags(TD) & TF_SYSTRACE) { 7257 /* reenable abstract instruction tracing, if necessary */ 7258 Clr_Tf_Flag(TD, TF_SYSTRACE); 7259 VM_FLAGS |= TRACE; 7260 } 7261#endif 7262 } 7263 Next_Pp; 7264 7265 7266/* 7267 * Instructions for the arithmetic builtins 7268 * 7269 * bi_minus &Ai &Ak 2'000100 7270 * bi_add &Ai &Aj &Ak 2'010000 7271 * bi_addi i &Aj &Ak 2'010010 7272 * bi_ge &Ai &Aj module 2'110000 7273 * 7274 * bi_arg &Ai &Aj &Ak 2'010000 7275 * bi_make_susp &Ai &Aj &Ak &Al 2'00000000 or 2'00010000 7276 * 7277 * CAUTION: the output argument(s) may be the same as the inputs. 7278 * Do not store there while the inputs are still needed! 7279 */ 7280 7281/* pw is assumed dereferenced */ 7282#define NDelay_Check_1(pw) \ 7283 if (IsRef((pw)->tag)) { \ 7284 err_code = PDELAY_1; \ 7285 goto _npdelay_; \ 7286 } 7287 7288#define NDelay_Check_2(pw) \ 7289 if (IsRef((pw)->tag)) { \ 7290 err_code = PDELAY_2; \ 7291 goto _npdelay_; \ 7292 } 7293 7294#define NCompare_Bip(Proc, BIxx, Op) /* arity 3 */\ 7295 proc = Proc;\ 7296 PP+= 4;\ 7297 pw1 = PP[-4].arg;\ 7298 Dereference_Pw(pw1)\ 7299 NDelay_Check_1(pw1)\ 7300 pw2 = PP[-3].arg;\ 7301 Dereference_Pw(pw2)\ 7302 NDelay_Check_2(pw2)\ 7303 /* don't Kill_DE here since arith_compare() can return PDELAY */\ 7304 if (IsInteger(pw1->tag)) {\ 7305 if (IsInteger(pw2->tag))\ 7306 if (pw1->val.nint Op pw2->val.nint)\ 7307 { goto _nbip_kill_succeed_;}\ 7308 else\ 7309 { goto _nbip_fail_; }\ 7310 else if (IsDouble(pw2->tag))\ 7311 if ((double)pw1->val.nint Op Dbl(pw2->val))\ 7312 { goto _nbip_kill_succeed_;}\ 7313 else\ 7314 { goto _nbip_fail_; }\ 7315 }\ 7316 else if (IsDouble(pw1->tag)) {\ 7317 if (IsInteger(pw2->tag))\ 7318 if (Dbl(pw1->val) Op (double)pw2->val.nint)\ 7319 { goto _nbip_kill_succeed_;}\ 7320 else\ 7321 { goto _nbip_fail_; }\ 7322 else if (IsDouble(pw2->tag))\ 7323 if (Dbl(pw1->val) Op Dbl(pw2->val))\ 7324 { goto _nbip_kill_succeed_;}\ 7325 else\ 7326 { goto _nbip_fail_; }\ 7327 }\ 7328 if (IsNumber(pw1->tag) && IsNumber(pw2->tag)) {\ 7329 int relation = BIxx; /* don't use a register */ \ 7330 Export_B_Sp_Tg_Tt\ 7331 err_code = (word) arith_compare(pw1->val, pw1->tag,\ 7332 pw2->val, pw2->tag, &relation);\ 7333 Import_Tg_Tt\ 7334 if (err_code == PDELAY){\ 7335 SV = (pword *) 0;\ 7336 goto _npdelay_always_;\ 7337 }\ 7338 if (err_code != PSUCCEED)\ 7339 goto _nbip_err_;\ 7340 if (relation Op 0) {\ 7341 goto _nbip_kill_succeed_;\ 7342 } else {\ 7343 goto _nbip_fail_;\ 7344 }\ 7345 }\ 7346 err_code = COMPARE_TRAP;\ 7347 goto _nbip_err_; 7348 7349 7350#define NGeneric_Arith_Overflow_Bip(BIxx, Op, SignOp, OpNr) /* arity 3 */\ 7351 PP += 4;\ 7352 pw1 = PP[-4].arg;\ 7353 Dereference_Pw(pw1);\ 7354 pw2 = PP[-3].arg;\ 7355 Dereference_Pw(pw2);\ 7356 NDelay_Check_1(pw1)\ 7357 NDelay_Check_2(pw2)\ 7358 Kill_DE;\ 7359 if (IsInteger(pw1->tag)) {\ 7360 if (IsInteger(pw2->tag)) {\ 7361 register word n1 = pw1->val.nint;\ 7362 register word n2 = pw2->val.nint;\ 7363 tmp1 = n1 Op n2;\ 7364 if (((n1 >= 0) SignOp (n2 >= 0)) && \ 7365 (n1 >= 0) != (tmp1 >= 0)) {\ 7366 err_code = INTEGER_OVERFLOW;\ 7367 goto _nbip_err_;\ 7368 } \ 7369 PP[-2].arg->val.nint = tmp1;\ 7370 PP[-2].arg->tag.kernel = TINT;\ 7371 Next_Pp;\ 7372 }\ 7373 if (IsDouble(pw2->tag)) {\ 7374 dbl_res = (double)pw1->val.nint Op Dbl(pw2->val);\ 7375 goto _nis_float_check_;\ 7376 }\ 7377 }\ 7378 else if (IsDouble(pw1->tag)) {\ 7379 if (IsInteger(pw2->tag)) {\ 7380 dbl_res = Dbl(pw1->val) Op (double)pw2->val.nint;\ 7381 goto _nis_float_check_;\ 7382 }\ 7383 if (IsDouble(pw2->tag)) {\ 7384 dbl_res = Dbl(pw1->val) Op Dbl(pw2->val);\ 7385 goto _nis_float_check_;\ 7386 }\ 7387 }\ 7388 err_code = OpNr;\ 7389 goto _nbin_op_; 7390 7391 7392#define NInt_Arith_Bip(Proc, BIxx, Op, OpNr) /* arity 3 */\ 7393 proc = Proc;\ 7394 PP += 4;\ 7395 pw1 = PP[-4].arg;\ 7396 Dereference_Pw(pw1);\ 7397 NDelay_Check_1(pw1)\ 7398 pw2 = PP[-3].arg;\ 7399 Dereference_Pw(pw2);\ 7400 NDelay_Check_2(pw2)\ 7401 Kill_DE;\ 7402 if (IsInteger(pw1->tag) && IsInteger(pw2->tag)) {\ 7403 PP[-2].arg->val.nint = pw1->val.nint Op pw2->val.nint;\ 7404 PP[-2].arg->tag.kernel = TINT;\ 7405 Next_Pp;\ 7406 }\ 7407 err_code = OpNr;\ 7408 goto _nbin_op_; 7409 7410 7411 7412 Case(BI_Minus, I_BI_Minus) 7413 proc = minus_proc_; 7414 PP += 3; 7415 pw1 = PP[-3].arg; 7416 Dereference_Pw(pw1); 7417 NDelay_Check_1(pw1) 7418 if (IsInteger(pw1->tag)) 7419 { 7420 if ((tmp1 = -pw1->val.nint) == MIN_S_WORD) { 7421 err_code = INTEGER_OVERFLOW; 7422 goto _nbip_err_; 7423 } 7424 Make_Integer(PP[-2].arg, tmp1); 7425 Next_Pp; 7426 } 7427 else if (IsDouble(pw1->tag)) 7428 { 7429 Make_Double(PP[-2].arg, -Dbl(pw1->val)); 7430 Next_Pp; 7431 } 7432 err_code = ARITH_NEG; 7433 7434_nun_op_: /* (err_code,pw1,PP,proc) */ 7435 Export_B_Sp_Tg_Tt_Eb_Gb 7436 err_code = un_arith_op(pw1->val, pw1->tag, PP[-2].arg, err_code, TINT); 7437 Import_Tg_Tt 7438 goto _nbip_res_; 7439 7440 7441 Case(BI_Addi, I_BI_Addi) 7442 proc = add_proc_; 7443 PP += 4; 7444 pw1 = PP[-4].arg; 7445 Dereference_Pw(pw1); 7446 NDelay_Check_1(pw1) 7447 Kill_DE; 7448 if (IsInteger(pw1->tag)) { 7449 register word n1 = pw1->val.nint; 7450 register word n2 = PP[-3].nint; 7451 tmp1 = n1 + n2; 7452 if (((n1 >= 0) == (n2 >= 0)) && 7453 (n1 >= 0) != (tmp1 >= 0)) { 7454 err_code = INTEGER_OVERFLOW; 7455 goto _nbip_err_; 7456 } 7457 Make_Integer(PP[-2].arg, tmp1); 7458 Next_Pp; 7459 } else if (IsDouble(pw1->tag)) { 7460 dbl_res = Dbl(pw1->val) + (double)PP[-3].nint; 7461_nis_float_check_: /* (dbl_res) */ 7462 if (!GoodFloat(dbl_res)) 7463 { 7464 err_code = ARITH_EXCEPTION; 7465 goto _nbip_err_; 7466 } 7467 Make_Double(PP[-2].arg, dbl_res); 7468 Next_Pp; 7469 } 7470 Make_Integer(&scratch_pw, PP[-3].nint); 7471 pw2 = &scratch_pw; 7472 err_code = ARITH_ADD; 7473 7474_nbin_op_: /* (err_code,pw1,pw2,proc,PP) */ 7475 Export_B_Sp_Tg_Tt_Eb_Gb 7476 err_code = bin_arith_op(pw1->val, pw1->tag, pw2->val, pw2->tag, PP[-2].arg, err_code); 7477 Import_Tg_Tt 7478 goto _nbip_res_; 7479 7480 7481 Case(BI_Add, I_BI_Add) 7482 proc = add_proc_; 7483 NGeneric_Arith_Overflow_Bip(BIAdd, +, ==, ARITH_ADD) 7484 7485 Case(BI_Sub, I_BI_Sub) 7486 proc = sub_proc_; 7487 NGeneric_Arith_Overflow_Bip(BISub, -, !=, ARITH_SUB) 7488 7489 Case(BI_Mul, I_BI_Mul) 7490 proc = mul_proc_; 7491 PP += 4; 7492 pw1 = PP[-4].arg; 7493 Dereference_Pw(pw1); 7494 NDelay_Check_1(pw1) 7495 pw2 = PP[-3].arg; 7496 Dereference_Pw(pw2); 7497 NDelay_Check_2(pw2) 7498 Kill_DE /* it's a demon */ 7499 if (IsInteger(pw1->tag)) { 7500 if (IsInteger(pw2->tag)) 7501 { 7502 tmp1 = pw1->val.nint; 7503 if (tmp1 != 0) { 7504 tmp1 *= pw2->val.nint; 7505 if (tmp1 == MIN_S_WORD || /* maybe */ 7506 tmp1/pw1->val.nint != pw2->val.nint) /* for sure */ 7507 { 7508 err_code = INTEGER_OVERFLOW; 7509 goto _nbip_err_; 7510 } 7511 } 7512 Make_Integer(PP[-2].arg, tmp1); 7513 Next_Pp; 7514 } 7515 if (IsDouble(pw2->tag)) { 7516 dbl_res = (double)pw1->val.nint * Dbl(pw2->val); 7517 goto _nis_float_check_; 7518 } 7519 } 7520 else if (IsDouble(pw1->tag)) { 7521 if (IsInteger(pw2->tag)) { 7522 dbl_res = Dbl(pw1->val) * (double)pw2->val.nint; 7523 goto _nis_float_check_; 7524 } 7525 if (IsDouble(pw2->tag)) { 7526 dbl_res = Dbl(pw1->val) * Dbl(pw2->val); 7527 goto _nis_float_check_; 7528 } 7529 } 7530 err_code = ARITH_MUL; 7531 goto _nbin_op_; /* (err_code,pw1,pw2,proc,PP) */ 7532 7533 Case(BI_Quot, I_BI_Quot) 7534 proc = quot_proc_; 7535 PP += 4; 7536 pw1 = PP[-4].arg; 7537 Dereference_Pw(pw1); 7538 NDelay_Check_1(pw1) 7539 pw2 = PP[-3].arg; 7540 Dereference_Pw(pw2); 7541 NDelay_Check_2(pw2) 7542 Kill_DE /* it's a demon */ 7543 if (IsInteger(pw2->tag)) 7544 { 7545 if (IsInteger(pw1->tag)) { 7546 if (GlobalFlags & PREFER_RATIONALS) 7547 { 7548 err_code = ARITH_DIV; 7549 goto _nbin_op_; /* (err_code,pw1,pw2,proc,PP) */ 7550 } 7551 else 7552 { 7553 dbl_res = (double)pw1->val.nint / (double)pw2->val.nint; 7554 goto _nis_float_check_; 7555 } 7556 } 7557 if (IsDouble(pw1->tag)) { 7558 dbl_res = Dbl(pw1->val) / (double)pw2->val.nint; 7559 goto _nis_float_check_; 7560 } 7561 } 7562 else if (IsDouble(pw2->tag)) 7563 { 7564 if (IsInteger(pw1->tag)) { 7565 dbl_res = (double)pw1->val.nint / Dbl(pw2->val); 7566 goto _nis_float_check_; 7567 } 7568 if (IsDouble(pw1->tag)) { 7569 dbl_res = Dbl(pw1->val) / Dbl(pw2->val); 7570 goto _nis_float_check_; 7571 } 7572 } 7573 err_code = ARITH_DIV; 7574 goto _nbin_op_; /* (err_code,pw1,pw2,proc,PP) */ 7575 7576 Case(BI_Div, I_BI_Div) 7577 proc = div_proc_; 7578 PP += 4; 7579 pw1 = PP[-4].arg; 7580 Dereference_Pw(pw1); 7581 NDelay_Check_1(pw1) 7582 pw2 = PP[-3].arg; 7583 Dereference_Pw(pw2); 7584 NDelay_Check_2(pw2); 7585 Kill_DE /* it's a demon */ 7586 if (IsInteger(pw1->tag) && IsInteger(pw2->tag)) 7587 { 7588 if (pw2->val.nint == 0) 7589 { 7590 err_code = ARITH_EXCEPTION; 7591 goto _nbip_err_; 7592 } 7593 if (pw1->val.nint == MIN_S_WORD && pw2->val.nint == -1) 7594 { 7595 err_code = INTEGER_OVERFLOW; 7596 goto _nbip_err_; 7597 } 7598 Make_Integer(PP[-2].arg, pw1->val.nint / pw2->val.nint); 7599 Next_Pp; 7600 } 7601 err_code = ARITH_IDIV; 7602 goto _nbin_op_; /* (err_code,pw1,pw2,proc,PP) */ 7603 7604 Case(BI_Rem, I_BI_Rem) 7605 proc = rem_proc_; 7606 PP += 4; 7607 pw1 = PP[-4].arg; 7608 Dereference_Pw(pw1); 7609 NDelay_Check_1(pw1); 7610 pw2 = PP[-3].arg; 7611 Dereference_Pw(pw2); 7612 NDelay_Check_2(pw2); 7613 Kill_DE /* it's a demon */ 7614 if (IsInteger(pw1->tag) && IsInteger(pw2->tag)) 7615 { 7616 if (pw2->val.nint == 0) 7617 { 7618 err_code = ARITH_EXCEPTION; 7619 goto _nbip_err_; 7620 } 7621 PP[-2].arg->val.nint = 7622#if defined(i386) || defined(__x86_64) || defined(__POWERPC__) || defined(sparc) 7623 /* need to check this, causes arith exception on i386 */ 7624 (/* pw1->val.nint == MIN_S_WORD && */ pw2->val.nint == -1) ? 0 : 7625#endif 7626 /* Assume % truncates towards zero */ 7627 pw1->val.nint % pw2->val.nint; 7628 PP[-2].arg->tag.kernel = TINT; 7629 Next_Pp; 7630 } 7631 err_code = ARITH_MOD; 7632 goto _nbin_op_; /* (err_code,pw1,pw2,proc,PP) */ 7633 7634 Case(BI_FloorDiv, I_BI_FloorDiv) 7635 proc = fdiv_proc_; 7636 PP += 4; 7637 pw1 = PP[-4].arg; 7638 Dereference_Pw(pw1); 7639 NDelay_Check_1(pw1); 7640 pw2 = PP[-3].arg; 7641 Dereference_Pw(pw2); 7642 NDelay_Check_2(pw2); 7643 Kill_DE /* it's a demon */ 7644 if (IsInteger(pw1->tag) && IsInteger(pw2->tag)) 7645 { 7646 if (pw2->val.nint == 0) 7647 { 7648 err_code = ARITH_EXCEPTION; 7649 goto _nbip_err_; 7650 } 7651 if (pw1->val.nint == MIN_S_WORD && pw2->val.nint == -1) 7652 { 7653 err_code = INTEGER_OVERFLOW; 7654 goto _nbip_err_; 7655 } 7656 tmp1 = pw1->val.nint / pw2->val.nint; 7657 /* Need to adjust rounding if opposite signs */ 7658 if (((pw1->val.nint ^ pw2->val.nint) < 0) && (pw1->val.nint % pw2->val.nint)) 7659 --tmp1; 7660 Make_Integer(PP[-2].arg, tmp1); 7661 Next_Pp; 7662 } 7663 err_code = ARITH_FLOORDIV; 7664 goto _nbin_op_; /* (err_code,pw1,pw2,proc,PP) */ 7665 7666 Case(BI_FloorRem, I_BI_FloorRem) 7667 proc = mod_proc_; 7668 PP += 4; 7669 pw1 = PP[-4].arg; 7670 Dereference_Pw(pw1); 7671 NDelay_Check_1(pw1); 7672 pw2 = PP[-3].arg; 7673 Dereference_Pw(pw2); 7674 NDelay_Check_2(pw2); 7675 Kill_DE /* it's a demon */ 7676 if (IsInteger(pw1->tag) && IsInteger(pw2->tag)) 7677 { 7678 if (pw2->val.nint == 0) { 7679#ifdef KNUTH_EXTENDED_MOD 7680 /* extension according to Knuth Vol 1, 1.2.4 */ 7681 tmp1 = pw1->val.nint; 7682#else 7683 err_code = ARITH_EXCEPTION; 7684 goto _nbip_err_; 7685#endif 7686#if defined(i386) || defined(__x86_64) || defined(__POWERPC__) || defined(sparc) 7687 /* need to check this, causes arith exception on i386 */ 7688 } else if (/* pw1->val.nint == MIN_S_WORD && */ pw2->val.nint == -1) { 7689 tmp1 = 0; 7690#endif 7691 } else { 7692 /* Assume % truncates towards zero */ 7693 tmp1 = pw1->val.nint % pw2->val.nint; 7694 /* Need to adjust nonzero results if opposite signs */ 7695 if (tmp1 && (pw1->val.nint ^ pw2->val.nint) < 0) 7696 tmp1 += pw2->val.nint; 7697 } 7698 Make_Integer(PP[-2].arg, tmp1); 7699 Next_Pp; 7700 } 7701 err_code = ARITH_FLOORREM; 7702 goto _nbin_op_; /* (err_code,pw1,pw2,proc,PP) */ 7703 7704 Case(BI_And, I_BI_And) /* the bit operations */ 7705 NInt_Arith_Bip(and_proc_, BIAnd, &, ARITH_AND) 7706 7707 Case(BI_Or, I_BI_Or) 7708 NInt_Arith_Bip(or_proc_, BIOr, |, ARITH_OR) 7709 7710 Case(BI_Xor, I_BI_Xor) 7711 NInt_Arith_Bip(xor_proc_, BIXor, ^, ARITH_XOR) 7712 7713 Case(BI_Bitnot, I_BI_Bitnot) 7714 proc = bitnot_proc_; 7715 pw1 = PP->arg; 7716 PP += 3; 7717 Dereference_Pw(pw1); 7718 NDelay_Check_1(pw1); 7719 if (IsInteger(pw1->tag)) 7720 { 7721 Make_Integer(PP[-2].arg, ~ pw1->val.nint); 7722 Next_Pp; 7723 } 7724 err_code = ARITH_COM; 7725 goto _nun_op_; /* (err_code,pw1,PP,proc) */ 7726 7727 7728 Case(BI_Lt, I_BI_Lt) /* The arithmetic comparisons */ 7729 NCompare_Bip(lt_proc3_, BILt, <) 7730 7731 Case(BI_Le, I_BI_Le) 7732 NCompare_Bip(le_proc3_, BILe, <=) 7733 7734 Case(BI_Gt, I_BI_Gt) 7735 NCompare_Bip(gt_proc3_, BIGt, >) 7736 7737 Case(BI_Ge, I_BI_Ge) 7738 NCompare_Bip(ge_proc3_, BIGe, >=) 7739 7740 Case(BI_Eq, I_BI_Eq) 7741 NCompare_Bip(eq_proc3_, BIEq, ==) 7742 7743 Case(BI_Ne, I_BI_Ne) 7744 NCompare_Bip(ne_proc3_, BINe, !=) 7745 7746 Case(BI_Arity, I_BI_Arity) /* arity(+Term,-N) */ 7747 pw1 = PP->arg; 7748 PP += 3; /* 2 args + desc */ 7749 Dereference_Pw_Tag(pw1, tmp1); 7750 if (IsTag(tmp1, TCOMP)) { 7751 Make_Integer(PP[-2].arg, DidArity(pw1->val.ptr->val.did)); 7752 Next_Pp; 7753 } else if (IsTag(tmp1, TLIST)) { 7754 Make_Integer(PP[-2].arg, 2); 7755 Next_Pp; 7756 } else if (!ISRef(tmp1)) { 7757 Make_Integer(PP[-2].arg, 0); 7758 Next_Pp; 7759 } 7760 proc = arity_proc_; 7761 err_code = PDELAY_1; 7762 goto _npdelay_; 7763 7764 Case(BI_Arg, I_BI_Arg) /* arg(+N, +Term, -Arg) */ 7765 proc = arg_proc_; 7766 PP += 4; 7767 pw1 = PP[-3].arg; /* check Term */ 7768 if (PP[-1].nint & 2) { 7769 pw2 = &scratch_pw; /* immediate integer argument */ 7770 Make_Integer(&scratch_pw, PP[-4].nint); 7771 } else { 7772 pw2 = PP[-4].arg; 7773 } 7774_narg_: 7775/* pw1 and pw2 must be set correctly before jumping here */ 7776 Dereference_Pw_Tag(pw1, tmp1); 7777 if (IsTag(tmp1, TCOMP)) 7778 { 7779 pw1 = pw1->val.ptr; 7780 i = DidArity(pw1->val.did); 7781 } 7782 else if (IsTag(tmp1, TLIST)) 7783 { 7784 pw1 = pw1->val.ptr - 1; 7785 i = 2; 7786 } 7787 else if (ISRef(tmp1)) 7788 { 7789 Dereference_Pw_Tag(pw2, tmp1); 7790 if (ISRef(tmp1) || IsTag(tmp1,TINT) || IsTag(tmp1,TLIST)) { 7791 err_code = PDELAY_2; 7792 goto _npdelay_; 7793 } 7794 else if (IsTag(tmp1,TBIG)) 7795 err_code = RANGE_ERROR; 7796 else if (tag_desc[TagTypeC(tmp1)].numeric) 7797 err_code = TYPE_ERROR; 7798 else 7799 err_code = ARITH_TYPE_ERROR; 7800 goto _nbip_err_; 7801 } 7802 else 7803 { 7804 err_code = TYPE_ERROR; 7805 goto _nbip_err_; 7806 } 7807 Dereference_Pw_Tag(pw2, tmp1); /* check N */ 7808 if (IsTag(tmp1, TINT)) 7809 { 7810 tmp1 = pw2->val.nint; 7811 if (tmp1 >= 1 && tmp1 <= i) 7812 { 7813 Kill_DE; /* necessary before success */ 7814 *PP[-2].arg = pw1[tmp1]; 7815 Next_Pp; 7816 } 7817 else 7818 err_code = RANGE_ERROR; 7819 } 7820 else if (ISRef(tmp1)) { 7821 err_code = PDELAY_1; 7822 goto _npdelay_; 7823 } 7824 else if (IsTag(tmp1,TBIG)) 7825 err_code = RANGE_ERROR; 7826 else if (tag_desc[TagTypeC(tmp1)].numeric) 7827 err_code = TYPE_ERROR; 7828 else if (IsTag(tmp1, TLIST)) 7829 { 7830 scratch_pw = *pw2; 7831 pw2 = pw2->val.ptr; 7832 Dereference_Pw_Tag(pw2,tmp1); /* car */ 7833 tmp1 = pw2->tag.kernel; 7834 if (IsTag(tmp1, TINT)) 7835 { 7836 tmp1 = pw2->val.nint; 7837 if (tmp1 >= 1 && tmp1 <= i) 7838 { 7839 pw1 += tmp1; /* get argument */ 7840 pw2 = scratch_pw.val.ptr + 1; /* cdr */ 7841 Dereference_Pw(pw2); 7842 if (IsTag(pw2->tag.kernel, TNIL)) 7843 { 7844 Kill_DE; /* necessary before success */ 7845 *PP[-2].arg = *pw1; 7846 Next_Pp; 7847 } 7848 else 7849 { 7850 /* pw1, pw2 pointing at the right place */ 7851 goto _narg_; 7852 } 7853 } 7854 else 7855 err_code = RANGE_ERROR; 7856 } 7857 else if (ISRef(tmp1)) { 7858 err_code = PDELAY_1; 7859 goto _npdelay_; /* (err_code, proc) */ 7860 } 7861 else if (IsTag(tmp1,TBIG)) 7862 err_code = RANGE_ERROR; 7863 else if (tag_desc[TagTypeC(tmp1)].numeric) 7864 err_code = TYPE_ERROR; 7865 else 7866 err_code = ARITH_TYPE_ERROR; 7867 } 7868 else 7869 err_code = ARITH_TYPE_ERROR; 7870 goto _nbip_err_; 7871 7872 7873 7874 /* 7875 * make_suspension(Goal, Prio, Susp, {Pri|CallerMod}) 7876 * 7877 * Normal call: make_suspension(Goal, Prio, Susp, CallerMod) 7878 * 7879 * Specially compiled call from inside a delay clause: 7880 * make_suspension(Goal, Prio, Susp, Pri) 7881 */ 7882 Case(BI_MakeSuspension, I_BI_MakeSuspension) 7883 proc = make_suspension_proc_; 7884 PP += 5; 7885 pw1 = PP[-5].arg; 7886 Dereference_Pw_Tag(pw1, tmp1); /* check goal argument */ 7887 if (IsTag(tmp1, TCOMP)) 7888 val_did = pw1->val.ptr->val.did; 7889 else if (IsTag(tmp1, TDICT)) 7890 val_did = pw1->val.did; 7891 else if (IsTag(tmp1, TLIST)) 7892 val_did = d_.list; 7893 else if (IsTag(tmp1, TNIL)) 7894 val_did = d_.nil; 7895 else { 7896 err_code = ISRef(tmp1) ? INSTANTIATION_FAULT : TYPE_ERROR; 7897 goto _nbip_err_; 7898 } 7899 pw2 = TG; /* allocate suspension */ 7900 TG += SUSP_SIZE; 7901 Check_Gc 7902 pw3 = PP[-2].arg; 7903 Dereference_Pw_Tag(pw3, tmp1); /* find the pri */ 7904 if (IsTag(tmp1, TINT)) /* we have the pri already */ 7905 { 7906 procb = (pri *) pw3->val.wptr; 7907 pw2[SUSP_MODULE].val.did = procb->module_ref; 7908 pw2[SUSP_MODULE].tag.kernel = ModuleTag(procb->module_ref); 7909 } 7910 else if (IsTag(tmp1, TDICT)) /* we have to look up */ 7911 { 7912 if(!IsModule(pw3->val.did)) { 7913 TG = pw2; /* pop incomplete suspension */ 7914 err_code = MODULENAME; 7915 goto _nbip_err_; 7916 } 7917 Export_B_Sp_Tg_Tt 7918 procb = visible_procedure(val_did, pw3->val.did, pw3->tag, 0); 7919 Import_None 7920 if (!procb) { 7921 TG = pw2; /* pop incomplete suspension */ 7922 Get_Bip_Error(err_code); 7923 goto _nbip_err_; 7924 } 7925 pw2[SUSP_MODULE] = *pw3; 7926 } 7927 else { 7928 TG = pw2; /* pop incomplete suspension */ 7929 err_code = ISRef(tmp1) ? INSTANTIATION_FAULT : TYPE_ERROR; 7930 goto _nbip_err_; /* (proc, err_code) */ 7931 } 7932 pw3 = PP[-4].arg; 7933 Dereference_Pw_Tag(pw3, tmp1); /* find the priority */ 7934 if (IsTag(tmp1, TINT)) 7935 { 7936 tmp1 = pw3->val.nint; 7937 if (tmp1 == 0) /* use procedure's setting */ 7938 tmp1 = PriPriority(procb); 7939 else if (tmp1 < 0 || tmp1 > SUSP_MAX_PRIO) 7940 tmp1 = RANGE_ERROR; 7941 } 7942 else 7943 tmp1 = ISRef(tmp1) ? INSTANTIATION_FAULT : TYPE_ERROR; 7944 if (tmp1 < 0) { 7945 TG = pw2; /* pop incomplete suspension */ 7946 err_code = tmp1; 7947 goto _nbip_err_; /* (proc, err_code) */ 7948 } 7949 Init_Susp_Header(pw2, procb); 7950 Init_Susp_State(pw2, tmp1, PriRunPriority(procb)); 7951 pw2[SUSP_GOAL] = *pw1; /* deref'ed arg 1: goal */ 7952 7953 7954 if (Tracing && AnyPortWanted) 7955 { 7956 Set_Susp_DebugInvoc(pw2, NINVOC); 7957 ++NINVOC; 7958 if (PortWanted(DELAY_PORT) && OfInterest(PriFlags(procb), NINVOC-1, DLevel(TD)+1, 0) ) 7959 { 7960 err_code = DEBUG_DELAY_EVENT; 7961 if (DBG_DELAY_INVOC == 0) { 7962 DBG_DELAY_INVOC = NINVOC-1; 7963 } 7964 /* to suppress tracing of the event handler call: */ 7965 Set_Tf_Flag(TD, TF_INTRACER); 7966 goto _nbip_err_; /* (proc, err_code) */ 7967 } 7968 } 7969 7970 pw1 = PP[-3].arg; /* output unification */ 7971 Dereference_Pw(pw1); 7972 if (IsRef(pw1->tag)) 7973 { 7974 /* Extra dereference to work around Bug 0855 7975 * (an environment variable may have been globalised) */ 7976 pw1 = pw1->val.ptr->val.ptr; 7977 if (IsVar(pw1->tag)) 7978 { 7979 Trail_If_Needed(pw1) 7980 pw1->val.ptr = pw2; 7981 pw1->tag.kernel = TSUSP; 7982 } 7983 else /* if(IsRef(pw1->tag)) */ 7984 { 7985 tmp1 = TSUSP; 7986 goto _bind_nonstandard_; /* (pw1, pw2, tmp1) */ 7987 } 7988 } 7989 else { Fail } 7990 Next_Pp; 7991 7992 7993 Case(BI_Compare, I_BI_Compare) /* compare(-R, ?X, ?Y) */ 7994 pw1 = PP[1].arg; 7995 pw2 = PP[2].arg; 7996 Dereference_Pw(pw1); 7997 Dereference_Pw(pw2); 7998 Export_B_Sp_Tg_Tt 7999 err_code = ec_compare_terms(pw1->val, pw1->tag, pw2->val, pw2->tag); 8000 Import_None 8001 PP[0].arg->val.did = err_code<0 ? d_.inf0 : err_code>0 ? d_.sup0 : d_.unify0; 8002 PP[0].arg->tag.kernel = TDICT; 8003 PP += 3; 8004 Next_Pp; 8005 8006 8007 Case(BI_Qualify, I_BI_Qualify) /* qualify_(?Term,-QualTerm,+Module) */ 8008 pw1 = PP[0].arg; 8009 Dereference_Pw_Tag(pw1, tmp1); 8010 if (IsTag(tmp1, TCOMP) && pw1->val.ptr->val.did == d_.colon) { 8011 *PP[1].arg = *pw1; 8012 } else { 8013 TG[0].val.did = d_.colon; 8014 TG[0].tag.kernel = TDICT; 8015 TG[1] = *PP[2].arg; 8016 TG[2] = *pw1; 8017 Make_Struct(PP[1].arg, TG); 8018 TG += 3; 8019 Check_Gc 8020 } 8021 PP += 3; 8022 Next_Pp; 8023 8024 8025/* the following instructions should be resurrected for double floats */ 8026#ifndef TFLOAT 8027 Case(Out_get_floatAM, I_Out_get_floatAM) 8028 Case(Get_floatAM, I_Get_floatAM) 8029 Case(Read_float, I_Read_float) 8030 Case(Write_float, I_Write_float) 8031 Case(Push_float, I_Push_float) 8032 Case(Put_floatAM, I_Put_floatAM) 8033 Case(Puts_float, I_Puts_float) 8034 Case(In_get_floatAM, I_In_get_floatAM) 8035#endif 8036#ifndef OLD_DYNAMIC 8037 Case(Try_me_dynamic, I_Try_me_dynamic) 8038 Case(Retry_me_dynamic, I_Retry_me_dynamic) 8039 Case(Clause, I_Clause) 8040#endif 8041/***** obsolete/unused *****/ 8042 Case(Neckcut_par, I_Neckcut_par) 8043 Case(Neckcut, I_Neckcut) 8044/***** not yet implemented *****/ 8045 Case(Escapef, I_Escapef) 8046 Case(Escape, I_Escape) 8047/***** pseudoinstructions *****/ 8048 Case(Code_end, I_Code_end) 8049 Case(Comment, I_Comment) 8050 default: 8051#ifdef PRINTAM 8052 emu_break(); 8053#endif 8054 err_code = UNDEFINED; 8055 val_did = d_.emulate; 8056 goto _regular_err_; 8057 8058 } /* end big switch or extension switch */ 8059 8060} /* end emulc() */ 8061 8062 8063 8064#if defined(PRINTAM) || defined(LASTPP) 8065emu_break(void) {} /* a dummy function to put a breakpoint in */ 8066#endif /* PRINTAM */ 8067 8068 8069/*-------------------------------------------------- 8070 * Signal handler for WAM-level profiling 8071 *--------------------------------------------------*/ 8072 8073#if defined(__GNUC__) && defined(HAVE_UCONTEXTGREGS) 8074 8075#include <signal.h> 8076#include <ucontext.h> 8077#ifndef REG_ESI 8078#define REG_ESI ESI /* e.g. on Solaris 10 */ 8079#endif 8080 8081 8082RETSIGTYPE 8083sigprof_handler(int signr, siginfo_t* dummy, void *context) 8084 8085#else 8086 8087RETSIGTYPE 8088sigprof_handler(void) 8089 8090#endif 8091{ 8092 extern stream_id profile_stream_; 8093 8094 if (VM_FLAGS & PROFILING) 8095 { 8096 if (VM_FLAGS & EXPORTED) 8097 (void) ec_outfw(profile_stream_, (word) g_emu_.pp); 8098 else 8099 { 8100 (void) ec_outfw(profile_stream_, (word) Int_Pp); 8101 } 8102 } 8103} 8104 8105