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/* 25 * SEPIA INCLUDE FILE 26 * 27 * VERSION $Id: emu_export.h,v 1.13 2015/04/02 14:35:46 jschimpf Exp $ 28 */ 29 30/* 31 * IDENTIFICATION emu_export.h 32 * 33 * DESCRIPTION 34 * 35 * 36 * CONTENTS: Macros and extern declarations related to the 37 * abstract machine 38 * 39 */ 40 41#define SAFE_B_AREA 4 /* interrupt-safe area on control stack (in pwords) */ 42 43/* 44 * macros to recognise control frames 45 */ 46 47extern vmcode it_fail_code_[], 48 gc_fail_code_[], 49 soft_cut_code_[], 50 slave_fail_code_[], 51 stop_fail_code_[], 52 *catch_fail_code_, 53 catch_unint_fail_code_[], 54 external_fail_code_[], 55 exception_fail_code_[]; 56 57#define IsInterruptFrame(top)\ 58 ((vmcode *)(top)->backtrack == it_fail_code_) 59#define IsRecursionFrame(top)\ 60 ((vmcode *)(top)->backtrack == stop_fail_code_ ||\ 61 (vmcode *)(top)->backtrack == slave_fail_code_) 62#define IsExceptionFrame(top)\ 63 ((vmcode *)(top)->backtrack == exception_fail_code_) 64#define IsCatchFrame(top)\ 65 ((vmcode *)(top)->backtrack == catch_fail_code_ ||\ 66 (vmcode *)(top)->backtrack == catch_unint_fail_code_) 67#define IsCatchEventsDeferredFrame(top)\ 68 ((vmcode *)(top)->backtrack == catch_unint_fail_code_) 69#define IsGcFrame(top)\ 70 ((vmcode *)(top)->backtrack == gc_fail_code_) 71#define IsUnpubParFrame(top)\ 72 SameCode(*((vmcode *)(top)->backtrack), Retry_seq) 73#define IsPubParFrame(top)\ 74 SameCode(*((vmcode *)(top)->backtrack), Fail_clause) 75#define IsParallelFrame(top)\ 76 (IsPubParFrame(top) || IsUnpubParFrame(top)) 77 78#define RETRY_ME_INLINE_SIZE 4 79#define IsRetryMeInlineFrame(top)\ 80 SameCode(*((vmcode *)(top)->backtrack), Retry_me_inline) 81#define TRUST_ME_INLINE_SIZE 3 82#define IsTrustMeInlineFrame(top)\ 83 SameCode(*((vmcode *)(top)->backtrack), Trust_me_inline) 84#define RETRY_INLINE_SIZE 4 85#define IsRetryInlineFrame(top)\ 86 SameCode(*((vmcode *)(top)->backtrack), Retry_inline) 87#define TRUST_INLINE_SIZE 4 88#define IsTrustInlineFrame(top)\ 89 SameCode(*((vmcode *)(top)->backtrack), Trust_inline) 90 91#define Top(pw) ((struct top_frame *)(pw)) 92#define Invoc(pw) ((struct invocation_frame *)(pw)) 93#define Exception(pw) ((struct exception_frame *)(pw)) 94#define Chp(pw) ((struct choice_frame *)(pw)) 95#define ChpPar(pw) ((struct parallel_frame *)(pw)) 96#define ChpInline(pw) ((struct inline_frame *)(pw)) 97#define ChpDbg(pw) ((struct choice_debug *)(pw)) 98 99/* macros for accessing choicepoint fields */ 100#define BPrev(pw) ((Top(pw)-1)->frame.args) 101#define BBp(pw) ((Top(pw)-1)->backtrack) 102#define BAlt(pw) ((Top(pw)-1)->frame.chp_par->alt) 103 104#define BTop(pw) ((Top(pw)-1)) 105#define BChp(pw) ((Top(pw)-1)->frame.chp) 106#define BPar(pw) ((Top(pw)-1)->frame.chp_par) 107#define BInline(pw) ((Top(pw)-1)->frame.chp_inline) 108#define BException(pw) ((Top(pw)-1)->frame.exception) 109#define BInvoc(pw) ((Top(pw)-1)->frame.invoc) 110 111 112/* find the actual size of an environment whose size is not known statically 113 * (indicated by -1 in the environment size location in the code) 114 */ 115#define DynEnvSize(e) (((((e)-1)->tag.kernel >> 8) & 0xffff) + 1) 116#define DynEnvFlags(e) (((e)-1)->tag.kernel) 117#define DynEnvVal(e) (((e)-1)->val.wptr) 118#define DynEnvDE(e) ((e)-2) 119#define DynEnvDbgPri(e) ((e)-3) 120#define DynEnvDbgPort(e) ((e)-4) 121#define DynEnvDbgInvoc(e) ((e)-5) 122#define DynEnvDbgPath(e) ((e)-6) 123#define DynEnvDbgLine(e) ((e)-7) 124#define DynEnvDbgFrom(e) ((e)-8) 125#define DynEnvDbgTo(e) ((e)-9) 126#define DYNENVDBGSIZE 8 127 128#define PushDynEnvHdr(NrSlots, Flags, Val) \ 129 (--SP)->tag.all = ((NrSlots) << 8) | Flags | TPTR;\ 130 SP->val.wptr = (uword *) (Val); 131 132 133/* 134 * Environment descriptors and their access macros. 135 * Environment descriptors occur in call and retry/trust_inline 136 * instructions. They indicate which parts of an environment are active, 137 * and consist of an environment size or an activity bitmap (EAM). 138 * 139 * Preliminary scheme, allowing both environment sizes and bitmaps, 32-bit: 140 * <29 bit env size>000 LSB=00 indicates size field, all slots active, 141 * size in bytes, multiple of pword. 142 * <31 bit EAM bitmap>1 LSB= 1 indicates 31-bit EAM (activity bitmap) 143 * <pointer to EAM>10 LSB=10 indicates pointer to uword-array 144 * of 31+1 bit maps, where all but the last 145 * uword of the array have LSB=0. 146 * compatible on 64-bit: 147 * <60 bit env size>0000 LSB=00 indicates size field, all slots active, 148 * size in bytes, multiple of pword. 149 * <31 bit EAM bitmap>1 LSB= 1 indicates 31-bit EAM (activity bitmap) 150 * bits 32..63 are same as bit 31 (sign extended) 151 * <pointer to EAM>010 LSB=10 indicates pointer to uword-array 152 * of 31+1 bit maps, where all but the last 153 * uword of the array have LSB=0. 154 * 155 * Dynamic environments marked by -1 size field (true size in Y1 tag). 156 * 157 * Bitmaps are cut up into 31-bit chunks (bits 1 to 31 of a uword, with 158 * bit 0 of the uword being used as a marker for the last chunk). 159 * First chunk corresponds to Y1(bit1)..Y31(bit31), second chunk to 160 * Y32(bit1)..Y62(bit31), etc. To have portable byte code, we use 31 bit 161 * chunks even on 64-bit machines, with the rest of the uword wasted. 162 */ 163 164#define EAM_CHUNK_SZ 31 165 166#define EdescIsSize(ed) (((ed) & 3) == 0) 167#define EdescSize(ed,e) ((ed) == -((word)sizeof(pword)) ? DynEnvSize(e) : (ed) / (word)sizeof(pword)) 168 169#define EdescIsEam(ed) (!EdescIsSize(ed)) 170#define EdescEamPtr(ed) ((ed)&1 ? (uword*)(&(ed)) : (uword*)((ed) & ~2)) 171#define EamPtrNext(peam) (!(*(peam)++ & 1)) 172/* (uint32) cast needed to get rid of sign extension on 64-bit */ 173#define EamPtrEam(peam) ((uint32)(*(uword*)(peam)) >> 1) 174 175/* Final, simplified scheme (env size no longer supported): 176 * <31 bit EAM bitmap>1 LSB=1 indicates 31-bit EAM (activity bitmap) 177 * <pointer to EAM>0 LSB=0 indicates pointer to uword-array 178 * of 31+1 bit maps, where all but the last 179 * uword of the array have LSB=0. 180 * Dynamic environment sizes (formerly marked by -1 size) are then 181 * indicated by a pointer to a particular static address. 182 * 183#define EdescIsSize(ed) ((uword*)(ed) == &dyn_env_size_indicator) 184#define EdescSize(ed,e) DynEnvSize(e) 185#define EdescEamPtr(ed) ((ed)&1 ? (uword*)(&(ed)) : (uword*)(ed)) 186*/ 187 188 189/*--------------------------------------------------------------------------- 190 * Overflow checks and garbage collection 191 *---------------------------------------------------------------------------*/ 192 193extern int control_ov ARGS((void)), local_ov ARGS((void)); 194 195#ifdef IN_C_EMULATOR 196#undef Check_Trail_Ov 197#define Check_Trail_Ov if (TT <= TT_LIM) \ 198 { Export_B_Sp_Tg_Tt trail_ov(); Import_None } 199#undef Check_Gc 200#define Check_Gc if (TG >= TG_LIM) \ 201 { Export_B_Sp_Tg_Tt global_ov(); Import_None } 202#endif 203 204#define LOCAL_CONTROL_GAP (SAFE_B_AREA+NARGREGS+sizeof(struct invocation_frame)) 205 206 207/* 208 * Constants for default size check, in pwords. It must hold 209 * GC_MAX_HEAD == GC_MAX_FACT + GC_MAX_PUT + GC_MAX_PUTS 210 */ 211#define GC_MAX_HEAD 200 /* head up to first put's */ 212#define GC_MAX_FACT 80 /* the whole unit clause */ 213#define GC_MAX_PUT 120 /* put's in the body */ 214#define GC_MAX_PUTS 50 /* puts' before Exit */ 215 216 217/* 218 * The gap left between TT and TG. It specifies how much can be pushed 219 * on the two stacks before an overflow check is really needed. 220 * It should be greater or equal to the maximum of 221 * MAXARITY, GC_MAX_HEAD and the size of the largest trail frame. 222 */ 223#define GLOBAL_TRAIL_GAP NARGREGS 224 225 226/* 227 * The initial trail gap is slightly larger. On overflow, it gets reduced 228 * to GLOBAL_TRAIL_GAP and a GC triggered in the hope that the gc will 229 * make trail expansion unnecessary. 230 */ 231#define TRAIL_GAP (GLOBAL_TRAIL_GAP + 128) 232 233 234/* 235 * If after a GC and stack trimming there are less than TG_MIN_SEG 236 * pwords available, we give up with stack overflow. 237 */ 238 239#define TG_MIN_SEG 1024 /* in pwords */ 240 241 242/*--------------------------------------------------------------------------- 243 * Trailing and Untrailing 244 *---------------------------------------------------------------------------*/ 245 246/* 247 * the two least significant bits identify the trail frame: 248 */ 249#define TRAIL_ADDRESS 0x0 250#define TRAIL_TAG 0x1 251#define TRAIL_MULT 0x2 252#define TRAIL_EXT 0x3 253 254/* 255 * an extended trail is further specified by the Etype Field: 256 */ 257#define TrailedEtype(x) (((word)(x) >> 4) & 0x0f) 258#define TrailedEtypeField(x) ((word)(x) << 4) 259#define TrailedEsize(x) (((word)(x) >> 8) & 0xffffff) 260#define TrailedEsizeField(x) (((word)(x) & 0xffffff) << 8) 261 262#define TRAIL_UNDO 0x0 263#define TRAIL_UNDO_STAMPED 0x1 264 265 266#define TRAIL_UNDO_FLAGS 0 267#define TRAIL_UNDO_ADDRESS 1 268#define TRAIL_UNDO_FUNCT 2 269#define TRAIL_UNDO_SIMPLE_HEADER_SIZE 3 270 271#define TRAIL_UNDO_STAMP_ADDRESS 3 272#define TRAIL_UNDO_OLDSTAMP 4 273#define TRAIL_UNDO_STAMPED_HEADER_SIZE 5 274 275 276/* 277 * how to get the tag from a tag trail frame 278 * the argument is the first word of the trail frame 279 * x is casted to preserve the sign bit in the shift, 280 * 0x9fffffff is casted because ansi C treats it as unsigned. 281 */ 282#define TrailedTag(x) (((word)(x) >> 2) & (word)(~(MARK|LINK))) 283 284/* 285 * the following macros are used in value trails 286 * the argument is the first word of the trail frame 287 */ 288#define TrailedOffset(x) ((word)(x)>>8) 289#define TrailedNumber(x) ((word)(x)>>4 & 0xf) 290#define TrailedType(x) ((word)(x) & 0xc) 291 292#define TRAILED_TYPE_MASK 0xc 293 294/* consistency check with ifdefs in sepia.h */ 295#if ((TRAILED_PWORD|TRAILED_REF|TRAILED_WORD32|TRAILED_COMP) & ~TRAILED_TYPE_MASK) 296Trailed type macros not defined correctly!!! 297#endif 298 299 300/* 301 * Extract the adress of the trailed location from an arbitrary trail frame. 302 * tr is a pointer to the first word of the frame 303 */ 304#define TrailedLocation(tr) (((word) *(tr) & 3) ? *((tr)+1) : *(tr)) 305 306/* 307 * Skip a trail frame 308 * tr is a pointer to the first word of the trail frame 309 * end is set to the beginning of the next trail frame 310 */ 311#define End_Of_Frame(tr, end) \ 312 switch(((word) *(tr) & 3)) {\ 313 default:\ 314 case TRAIL_ADDRESS:\ 315 end = (tr)+1; break;\ 316 case TRAIL_TAG:\ 317 end = (tr)+2; break;\ 318 case TRAIL_MULT:\ 319 end = (tr) + TrailedNumber((word)*(tr)) + 3; break;\ 320 case TRAIL_EXT:\ 321 end = (tr) + TrailedEsize((word)*(tr)); break;\ 322 } 323 324 325/* 326 * simple address trail 327 * the trailed pword is restored to a self reference with TREF tag 328 */ 329 330#define Trail_(pw) \ 331 *--TT = (pword *) (pw);\ 332 Check_Trail_Ov 333 334/* 335 * Tag trail for trailing the binding of a non-standard variable 336 * On untrailing, the trailed pword is restored to a self reference 337 * with the old tag (note that the GC bits are always restored to 00 !). 338 * (this macro would be simpler if we were sure never to trail a TREF tag!) 339 */ 340 341#define Trail_Tag(pw) \ 342 *--TT = (pword *) (pw);\ 343 *--TT = (pword *) ( ((pw)->tag.kernel & SIGN_BIT)\ 344 | ((pw)->tag.kernel << 2) | TRAIL_TAG);\ 345 Check_Trail_Ov 346 347/* 348 * different value trails 349 * The type information is needed by the garbage collector. 350 * The addresses in the trail must point to proper pwords, 351 * at least if they point into the global stack. 352 */ 353 354#define Trail_Pointer(pw) \ 355 *--TT = ((pword *) (pw))->val.ptr;\ 356 *--TT = (pword *) (pw);\ 357 *--TT = (pword *) (TRAILED_REF | TRAIL_MULT);\ 358 Check_Trail_Ov 359 360#define Trail_Comp(pw) \ 361 *--TT = ((pword *) (pw))->val.ptr;\ 362 *--TT = (pword *) (pw);\ 363 *--TT = (pword *) (TRAILED_COMP | TRAIL_MULT);\ 364 Check_Trail_Ov 365 366/* 367 * trail a word at a fixed offset from a pword. 368 * The type information is needed by the garbage collector. 369 */ 370 371#define Trail_Word(pw, offset, type) \ 372 *--TT = (pword *) (*((uword *) (pw) + (offset)));\ 373 *--TT = (pword *) (pw);\ 374 *--TT = (pword *) ((offset) << 8 | (type) | TRAIL_MULT);\ 375 Check_Trail_Ov 376 377#define Trail_Pword(pw) \ 378 *--TT = (pword *) ((pword *) (pw))->tag.all;\ 379 *--TT = ((pword *) (pw))->val.ptr;\ 380 *--TT = (pword *) (pw);\ 381 *--TT = (pword *) ((1 << 4) | TRAILED_PWORD | TRAIL_MULT);\ 382 Check_Trail_Ov 383 384 385/* trail multiple words at an offset from pw */ 386 387#define Trail_Pwords(pw, offset, n) { \ 388 word _i = (offset) + (n); \ 389 do { \ 390 TT -= 2; \ 391 * (pword *) TT = (pw)[--_i]; \ 392 } while (_i > offset); \ 393 *--TT = (pword *) (pw); \ 394 *--TT = (pword *) (word)((2*(offset) << 8) | (2*(n)-1 << 4) | TRAILED_PWORD | TRAIL_MULT); \ 395 Check_Trail_Ov \ 396 } 397 398/* 399 * general trail for multiple words 400 * nwords is the number of trailed 32 bit words (max 16). 401 * offset is the offset of the first trailed word relative to pw 402 * (in units of 32 bit words), type must be one of 403 * TRAILED_PWORD, TRAILED_WORD32, TRAILED_REF, TRAILED_COMP 404 * specifying what kind of data has been trailed (for the GC) 405 */ 406 407#define Trail_Frame(pw, offset, nwords, type) \ 408 {\ 409 uword *ptr = (uword *)(pw) + (offset) + (nwords);\ 410 while(ptr > (uword *)(pw) + (offset))\ 411 *--TT = (pword *) (*--ptr);\ 412 *--TT = ((pword *) (ptr));\ 413 *--TT = (pword *) (((offset) << 8) | ((nwords) - 1 << 4)\ 414 | (type) | TRAIL_MULT);\ 415 Check_Trail_Ov\ 416 } 417 418/* 419 * This trail will cause the specified function to be called on 420 * backtracking, usually to undo a side effect. 421 * The function will be called with a single argument which is 422 * a pointer to the prolog word pw. 423 */ 424 425#define Trail_Undo(pw, function) \ 426 TT = (pword **) ((void (**)ARGS((pword *))) TT - 1);\ 427 * (void (**)ARGS((pword *))) TT = (void (*)ARGS((pword *))) (function);\ 428 *--TT = (pword *) (pw);\ 429 *--TT = (pword *) ( TrailedEsizeField(TRAIL_UNDO_SIMPLE_HEADER_SIZE)\ 430 | TrailedEtypeField(TRAIL_UNDO) | TRAIL_EXT);\ 431 Check_Trail_Ov 432 433 434/* 435 * conditional trailing macros 436 */ 437 438#define Trail_If_Needed(pw) \ 439 if((pword *)(pw) < GB || (pword *)(pw) >= EB) {\ 440 Trail_(pw)\ 441 } 442 443/* the following works only with local stack locations */ 444 445#define Trail_If_Needed_Eb(pw) \ 446 if((pword *)(pw) >= EB) {\ 447 Trail_(pw)\ 448 } 449 450/* the following works only with global stack locations */ 451 452#define Trail_If_Needed_Gb(pw) \ 453 if((pword *) (pw) < GB) {\ 454 Trail_(pw)\ 455 } 456 457#define Trail_Tag_If_Needed_Gb(pw) \ 458 if((pword *) (pw) < GB) {\ 459 Trail_Tag(pw)\ 460 } 461 462/* Check a pointer for pointing into deterministic part of the global stack. 463 * Use this macro when you are not sure pw really points into the global 464 * stack (e.g. ground structures in the heap) !!! 465 */ 466#define NewLocation(pw) ((pw) >= GB && (pw) <= TG) 467 468/* Check whether a pword can be recognised as being "new", i.e. younger 469 * than the most recent choicepoint. This is the case only for items that 470 * have been pushed onto the global stack since. 471 */ 472#define NewValue(v, t) (ISPointer((t).kernel) && NewLocation((v).ptr)) 473 474 475#define Trail_Word_If_Needed_Gb(pw, offset, type) \ 476 if ((pword *) (pw) < GB) {\ 477 Trail_Word(pw, offset, type)\ 478 } 479 480#define Trail_Pointer_If_Needed_Gb(pw) \ 481 if ((pword *) (pw) < GB) {\ 482 Trail_Pointer(pw)\ 483 } 484 485#define Trail_Pword_If_Needed_Gb(pw) \ 486 if ((pword *) (pw) < GB) {\ 487 Trail_Pword(pw)\ 488 } 489 490 491/* 492 * With the assembler emulator we must be careful not to untrail something 493 * above the local stack top, since this may corrupt the C stack. 494 */ 495 496#ifdef AS_EMU 497 498extern pword *spmax_; 499 500#define Ignore_If_Above_Sp(pw) \ 501 if((pw) < SP && (pw) >= spmax_) continue; 502 503#else /* AS_EMU */ 504 505#define Ignore_If_Above_Sp(pw) 506 507#endif /* AS_EMU */ 508 509 510/* 511 * The Untrailing Routine 512 * 513 * top Where to stop untrailing (previous TT value) 514 * ctr an auxiliary variable of type word 515 * pw an auxiliary pointer of type pword * 516 */ 517 518#define Untrail_(ttptr, top, ctr, pw) \ 519 while(ttptr < top) {\ 520 switch((((word) *ttptr) & 3)) {\ 521 case TRAIL_ADDRESS:\ 522 pw = *ttptr++;\ 523 Ignore_If_Above_Sp(pw);\ 524 pw->val.ptr = pw;\ 525 pw->tag.kernel = TREF;\ 526 break;\ 527 case TRAIL_TAG:\ 528 pw = *(ttptr+1);\ 529 pw->val.ptr = pw;\ 530 pw->tag.kernel = TrailedTag(*(ttptr));\ 531 ttptr += 2;\ 532 break;\ 533 case TRAIL_MULT:\ 534 ctr = (word) *ttptr++;\ 535 pw = (pword *)((uword *) *(ttptr++) + TrailedOffset(ctr));\ 536 ctr = TrailedNumber(ctr);\ 537 do {\ 538 pw->val.ptr = *ttptr++;\ 539 pw = (pword *) ((uword *) pw + 1);\ 540 } while (ctr--);\ 541 break;\ 542 case TRAIL_EXT:\ 543 Untrail_Export;\ 544 untrail_ext(ttptr, UNDO_FAIL);\ 545 Untrail_Import;\ 546 ttptr += TrailedEsize(*ttptr);\ 547 break;\ 548 }\ 549 } 550 551 552#ifdef IN_C_EMULATOR 553 554#define Untrail_Export Export_B_Sp_Tg_Tt_Eb_Gb 555#define Untrail_Import Import_Tg_Tt 556 557#define Untrail_Variables(top, ctr, pw) \ 558 Untrail_(TT, top, ctr, pw) 559 560#else /* IN_C_EMULATOR */ 561 562#define Untrail_Export 563#define Untrail_Import 564 565#define Untrail_Variables(top) {\ 566 word n; pword *pw1;\ 567 Untrail_(TT, top, n, pw1);\ 568 } 569 570#endif /* IN_C_EMULATOR */ 571 572/*--------------------------------------------------------------------------- 573 * Mechanism to flag asynchronous events by simulating a stack overflow 574 * 575 * A shadow register TG_SLS always holds the corect value of TG_SL. 576 * TG_SL itself can be set to 0 (thus faking a stack overflow) in order 577 * to trigger synchronous engine events. 578 * Whenever TG_SL or TG_LIM is changed, make sure that TG_SL =< TG_LIM !! 579 * Use only the macros below to manipulate TG_SL, TG_SLS and TG_LIM! 580 *---------------------------------------------------------------------------*/ 581 582#define FakedOverflow (TG_SL == (pword *) 0) 583 584#define Fake_Overflow \ 585 TG_SL = (pword *) 0; 586 587#define Interrupt_Fake_Overflow { \ 588 Fake_Overflow; \ 589 IFOFLAG = 1; \ 590 } 591 592/* The following must only be called when we are about to handle 593 * FakedOverflow conditions anyway, or in interrupt protected regions, 594 * since we may miss an Interrupt_Fake_Overflow when overwriting TG_SL! 595 */ 596#define Reset_Faked_Overflow \ 597 TG_SL = TG_SLS; 598 599/* Reset TG_SL from TG_SLS if possible, i.e. if there is no 600 * FakedOverflow condition. Take care of possible interruptions 601 * by Interrupt_Fake_Overflow. 602 */ 603#define Refresh_Tg_Soft_Lim { \ 604 IFOFLAG = 0; \ 605 if (!FakedOverflow) { \ 606 TG_SL = TG_SLS; \ 607 if (IFOFLAG) \ 608 Fake_Overflow; \ 609 } \ 610 } 611 612#define Set_Tg_Soft_Lim(new) { \ 613 TG_SLS = new; \ 614 Refresh_Tg_Soft_Lim; \ 615 } 616 617#define Save_Tg_Soft_Lim(saved) \ 618 (saved) = TG_SLS; 619 620#define Restore_Tg_Soft_Lim(saved) \ 621 Set_Tg_Soft_Lim(TG_LIM < (saved) ? TG_LIM : (saved)) 622 623#define Set_Tg_Lim(newlim) { \ 624 if ((TG_LIM = (newlim)) < TG_SLS) { \ 625 Set_Tg_Soft_Lim(TG_LIM) \ 626 } \ 627 } 628 629 630#define Adjust_GcTg_and_TgSl(TG) { \ 631 if (TG < GCTG) { \ 632 GCTG = TG; \ 633 Restore_Tg_Soft_Lim(TG + TG_SEG); \ 634 } \ 635 } 636 637 638#define Compute_Gcb(gcb) { \ 639 pword *_gcb = B.args; \ 640 while (BChp(_gcb)->tg >= GCTG && \ 641 !(IsInterruptFrame(BTop(_gcb)) || \ 642 IsRecursionFrame(BTop(_gcb)) || \ 643 IsExceptionFrame(BTop(_gcb)))) \ 644 { \ 645 _gcb = BPrev(_gcb); \ 646 } \ 647 gcb = _gcb; \ 648 } 649 650#define EventPending (TG >= TG_SL) 651 652#define GlobalOverflow (TG >= TG_SLS) /* a real stack overflow */ 653 654 655#ifdef IN_C_EMULATOR 656#define Poll_Interrupts() \ 657 if (EVENT_FLAGS & DEL_IRQ_POSTED) { \ 658 Export_B_Sp_Tg_Tt \ 659 ec_handle_async(); \ 660 Import_None \ 661 } 662#else 663#define Poll_Interrupts() \ 664 if (EVENT_FLAGS & DEL_IRQ_POSTED) { \ 665 ec_handle_async(); \ 666 } 667#endif 668 669/*--------------------------------------------------------------------------- 670 * General purpose macros 671 *---------------------------------------------------------------------------*/ 672 673/* Add a positive offset to a pointer. If this overflows the address 674 * range, set it to max instead. */ 675#define Safe_Add_To_Pointer(old, pos_offset, max, new) { \ 676 (new) = (old) + (pos_offset); \ 677 if ((new) < (old)) (new) = (max); \ 678 } 679 680#define Safe_Sub_From_Pointer(old, pos_offset, min, new) { \ 681 (new) = (old) - (pos_offset); \ 682 if ((new) > (old)) (new) = (min); \ 683 } 684 685 686/*--------------------------------------------------------------------------- 687 * Binding macros to be used in the built-ins to speed up the unification 688 *---------------------------------------------------------------------------*/ 689 690#define IsLocal(p) (SP <= (p)) 691 692#ifndef IN_C_EMULATOR 693 694#undef Bind_ 695#define Bind_(pw,v,t) \ 696 Trail_If_Needed(pw) \ 697 (pw)->tag.all = (uword) (t); \ 698 (pw)->val.all = (uword) (v); 699 700/* 701 * Return_Bind_Var(value, type, (uword), word) 702 * Bind a free (maybe mutable) variable to a term which is known 703 * not to be a reference or a mutable object and then return 704 * from the built-in. This macro can be used instead of Return_Unify(). 705 */ 706#define Return_Bind_Var(vval, vtag, term, termtag) \ 707 if (IsVar(vtag)) { \ 708 Bind_((vval).ptr, term, termtag); \ 709 Succeed_; \ 710 } else { \ 711 pword aux_pw; \ 712 aux_pw.val.all = (uword) (term); \ 713 aux_pw.tag.kernel = (termtag); \ 714 return bind_c((vval).ptr, &aux_pw, &MU); \ 715 } 716 717#define Request_Bind_Var(vval, vtag, term, termtag) \ 718 if (uNiFy_result != PFAIL) { \ 719 if (IsVar(vtag)) { \ 720 Bind_((vval).ptr, term, termtag); \ 721 } else { \ 722 pword aux_pw; \ 723 aux_pw.val.all = (uword) (term); \ 724 aux_pw.tag.kernel = (termtag); \ 725 uNiFy_result = bind_c((vval).ptr, &aux_pw, &MU);\ 726 } \ 727 } 728 729/* 730 * Bind_Var(value, type, (uword), word) 731 * Bind a free (maybe mutable) variable to a term which is known 732 * not to be a reference or a mutable object. This macro can be 733 * used instead of Request_Unify(). 734 */ 735#define Bind_Var(vval, vtag, term, termtag) \ 736 if (IsVar(vtag)) { \ 737 Bind_((vval).ptr, term, termtag); \ 738 } else { \ 739 pword aux_pw; \ 740 aux_pw.val.all = (uword) (term); \ 741 aux_pw.tag.kernel = (termtag); \ 742 (void) bind_c((vval).ptr, &aux_pw, &MU);\ 743 } 744 745#endif /* IN_C_EMULATOR */ 746 747#ifdef IN_C_EMULATOR 748 749#define EmuStringStart(pw) \ 750 ( SameTypeC((pw)->tag, TBUFFER)\ 751 ? ((pw) + 1)\ 752 : ((pw) + 1)->val.ptr\ 753 ) 754 755/* when count is negative, the strings are equal */ 756/* CAUTION: pw1/pw2 are expanded several times! */ 757/* This code raises alignment warnings, but it's ok. */ 758 759#define Compare_Strings(pw1, pw2, count) \ 760 if ((count = pw1->val.nint) == pw2->val.nint) { \ 761 pw1 = EmuStringStart(pw1); \ 762 pw2 = EmuStringStart(pw2); \ 763 while (count--) { \ 764 if (*(char*)(pw1) != *(char*)(pw2)) \ 765 break; \ 766 pw1 = (pword *) ((char*)(pw1) + 1); \ 767 pw2 = (pword *) ((char*)(pw2) + 1); \ 768 } \ 769 } 770 771#else /* IN_C_EMULATOR */ 772 773/* when count is negative, the strings are equal */ 774/* CAUTION: v1/v2 are expanded several times! */ 775 776#define Compare_Strings(v1, v2, count) \ 777 if ((count = (v1).ptr->val.nint) == (v2).ptr->val.nint) { \ 778 register char *s1 = StringStart(v1); \ 779 register char *s2 = StringStart(v2); \ 780 while (count--) \ 781 if (*s1++ != *s2++) \ 782 break; \ 783 } 784 785#endif /* IN_C_EMULATOR */ 786 787/* 788 * Bind and return a numeric result, make appropriate type error if 789 * the result argument is not a variable or the same numeric type. 790 */ 791 792#ifdef ARITH_OUTPUT_TYPE_ERROR 793#define Return_Numeric(v, t, result) \ 794 if (IsRef(t)) { \ 795 Return_Bind_Var(v, t, result.val.all, result.tag.all); \ 796 } else if (SameType(t, result.tag)) { \ 797 Succeed_If( \ 798 IsSimple(t) ? SimpleEq(t.kernel, v, result.val) \ 799 : tag_desc[TagType(t)].equal(result.val.ptr, v.ptr)); \ 800 } else if (tag_desc[TagType(t)].super == tag_desc[TagType(result.tag)].super) { \ 801 Fail_; \ 802 } else { Bip_Error(TYPE_ERROR); } 803#else 804#define Return_Numeric(v, t, result) \ 805 if (IsRef(t)) { \ 806 Return_Bind_Var(v, t, result.val.all, result.tag.all); \ 807 } else if (SameType(t, result.tag)) { \ 808 Succeed_If( \ 809 IsSimple(t) ? SimpleEq(t.kernel, v, result.val) \ 810 : tag_desc[TagType(t)].equal(result.val.ptr, v.ptr)); \ 811 } else { \ 812 Fail_; \ 813 } 814#endif 815 816/*--------------------------------------------------------------------------- 817 * Coroutining / Metaterms 818 *---------------------------------------------------------------------------*/ 819 820#define MetaTerm(pw) ((pw) + 1) 821#define MetaDelayTerm(pw) MetaTerm(pw) 822 823/* 824 * Maximum overhead size of an attribute in its canonical I/O format, 825 * i.e. ( name1:Attr1 , name2:Attr , ... , nameN:AttrN ) 826 * N*3 for every :/2 structure plus (N-1)*3 for every ,/2 827 */ 828#define ATTR_IO_TERM_SIZE (6 * p_meta_arity_->val.nint - 3) 829 830 831#define Push_var_delay(vptr, tdummy) { \ 832 register pword *_pw = TG; \ 833 Push_List_Frame(); \ 834 if (IsLocal(vptr)) { /* assume IsRef */ \ 835 Make_Var(_pw); /* globalise */ \ 836 Make_Ref(vptr, _pw); \ 837 } else { \ 838 Make_Ref(_pw, vptr); \ 839 } \ 840 if (SV) { \ 841 Make_List(&_pw[1], SV); \ 842 } else \ 843 Make_Nil(&_pw[1]); \ 844 SV = _pw; \ 845 } 846 847#define Push_var_delay_unif(v, t) Push_var_delay(v, t) 848 849 850/* 851 * Suspension structure: 852 * 853 * |-----------------| 854 * | | 855 * |- - - MODULE - -| 856 * | | 857 * |-----------------| 858 * | | 859 * |- - - GOAL - - -| 860 * | | 861 * |-----------------| 862 * | RP/PRIO WS TREF| <= these are mutable fields 863 * |- - - STATE - - -| 864 * | timestamp | 865 * |-----------------| 866 * | INVOC | <= CAUTION: no tag! 867 * |- - - - - - - - -| 868 * | PRI | 869 * |-----------------| |---------| 870 * |0-- DD TDE | | TSUSP | 871 * |- - - - - - - - -| |- - - - -| 872 * | LD | /------- | 873 * |-----------------|<--/ |---------| 874 * 875 * When the suspension is SuspDead, then the suspension may be partially 876 * garbage collected, i.e. goal and module may no longer be present and 877 * it may be removed from the LD list. 878 * 879 * |-----------------| 880 * | INVOC | 881 * |- - - - - - - - -| 882 * | PRI | 883 * |-----------------| |---------| 884 * |0-- 1D TDE | | TSUSP | 885 * |- - - - - - - - -| |- - - - -| 886 * | NULL | /------- | 887 * |-----------------|<--/ |---------| 888 * 889 * 890 * Suspension states (non-demon): 891 * ________ _________ ____ 892 * | 00 | | 11 | | | 893 * |Sleeping|--sch->|Scheduled|--------uns---exe--------->|Dead|<--kill 894 * |________| |_________| |____| 895 * 896 * Suspension states (demon): 897 * ________ _________ ___________ ____ 898 * | 00 |--sch->| 11 |--uns->| 10 | | | 899 * |Sleeping| |Scheduled| |Unscheduled| |Dead|<--kill 900 * |________|<-exe--|_________|<-sch--|___________| |____| 901 * | | 902 * \----------------------------/ 903 * 904 * An unscheduled suspension is one that had been scheduled, but some other 905 * code made its actual execution redundant and called unschedule_suspension/1. 906 * The difference between 'unscheduled' and 'sleeping' is that unscheduled 907 * suspensions are still in the WL lists. From there it can either be 908 * rescheduled cheaply, or go to dead/sleeping state at the time it gets 909 * taken out of the WL lists. 910 * 911 * Priorities: 912 * We store both priority and run_priority in the suspension. 913 * The run-priority is always equal or higher than the schedule-priority. 914 */ 915 916 917/* In the SUSP_FLAGS tag: */ 918#define SUSP_FLAG_DEMON 0x00000100 919#define SUSP_FLAG_DEAD 0x00000200 920 921/* In the SUSP_STATE tag: */ 922#define SUSP_FLAG_PRIO 0x00F00000 923#define SUSP_FLAG_RUNPRIO 0x0F000000 924#define SUSP_STATE_SCHED 0x00000100 /* scheduled */ 925#define SUSP_STATE_INWL 0x00000200 /* in woken lists */ 926 927#define SUSP_PRIO_SHIFT 20 928#define SUSP_RUNPRIO_SHIFT 24 929#define SUSP_MAX_PRIO PRIORITY_MAX 930 931#define SUSP_LD 0 /* offsets in suspensions */ 932#define SUSP_FLAGS 0 933#define SUSP_PRI 1 934#define SUSP_INVOC 1 935#define SUSP_HEADER_SIZE 2 936#define SUSP_STATE 2 937#define SUSP_GOAL 3 938#define SUSP_MODULE 4 939#define SUSP_SIZE 5 940 941/* field access macros */ 942#define SuspDemon(p) ((p)[SUSP_FLAGS].tag.kernel & SUSP_FLAG_DEMON) 943#define SuspDead(p) ((p)[SUSP_FLAGS].tag.kernel & SUSP_FLAG_DEAD) 944#define SuspScheduled(p) ((p)[SUSP_STATE].tag.kernel & SUSP_STATE_SCHED) 945#define SuspInWL(p) ((p)[SUSP_STATE].tag.kernel & SUSP_STATE_INWL) 946#define SuspPrio(p) (((unsigned) ((p)[SUSP_STATE].tag.kernel) & SUSP_FLAG_PRIO)>>SUSP_PRIO_SHIFT) 947#define SuspRunPrio(p) (((unsigned) ((p)[SUSP_STATE].tag.kernel) & SUSP_FLAG_RUNPRIO)>>SUSP_RUNPRIO_SHIFT) 948#define SuspStamp(p) ((p)[SUSP_STATE].val.ptr) 949#define SuspPrevious(p) (((pword *) p)[SUSP_LD].val.ptr) 950#define SuspProc(p) ((pri*)(((pword *) p)[SUSP_PRI].val.wptr)) 951#define SuspDebugInvoc(p) (((pword *) p)[SUSP_INVOC].tag.kernel) 952#define SuspModule(p) (((pword *) p)[SUSP_MODULE].val.did) 953 954#define SuspTagDead(t) ((t) & SUSP_FLAG_DEAD) 955 956/* field update macros */ 957#define Set_Susp_Scheduled(p) Set_Susp_State(p, (SUSP_STATE_SCHED|SUSP_STATE_INWL)) 958#define Set_Susp_Delayed(p) Reset_Susp_State(p, (SUSP_STATE_SCHED|SUSP_STATE_INWL)) 959#define Set_Susp_Rescheduled(p) Set_Susp_State(p, SUSP_STATE_SCHED) 960#define Set_Susp_Unscheduled(p) Reset_Susp_State(p, SUSP_STATE_SCHED) 961#define Set_Susp_Dead(p) Set_Susp_Flag(p, SUSP_FLAG_DEAD) 962#define Set_Susp_Dead_Untrailed(p) Set_Susp_Flag_Untrailed(p, SUSP_FLAG_DEAD) 963#define Set_Susp_DebugInvoc(p,i) p[SUSP_INVOC].tag.kernel = (i); 964 965#define Init_Susp_Header(p,proc) \ 966 (p)[SUSP_LD].val.ptr = (pword *)LD;\ 967 Update_LD(p);\ 968 (p)[SUSP_FLAGS].tag.kernel = TDE|(PriFlags(proc) & PROC_DEMON ? SUSP_FLAG_DEMON : 0);\ 969 (p)[SUSP_PRI].val.wptr = (uword *)(proc);\ 970 (p)[SUSP_INVOC].tag.kernel = 0; 971#define Init_Susp_Dead(p) \ 972 (p)[SUSP_LD].val.ptr = (pword *)0;\ 973 (p)[SUSP_FLAGS].tag.kernel = TDE|SUSP_FLAG_DEAD; 974 975/* 976 * In order to be able to safely use global stack addresses as time stamps, 977 * we push a "witness" word with every choicepoint. Their addresses are 978 * used as the time stamps. GB will always point to such a witness. 979 * A stamp looks like a [] (a ref to a TNIL of the proper age). 980 * Make_Stamp() and OldStamp() are in sepia.h 981 * A stamp older than any other is at the first word of the stack! 982 */ 983 984#define Push_Witness TG++->tag.kernel = TNIL; 985 986#define OlderStamp(p,b) \ 987 OlderStampThanGlobalAddress(p,BChp(b)->tg) 988 989#define OlderStampThanGlobalAddress(p,tg) \ 990 ((p)->val.ptr < tg) 991 992#define Update_Stamp(p) \ 993 Trail_Pointer(p);\ 994 (p)->val.ptr = GB; 995 996 997 998#define Trail_State(p) \ 999 if ((p)->val.ptr < GB /* implies p < GB */) {\ 1000 Trail_Pword(p);\ 1001 (p)->val.ptr = BChp(B.args)->tg;\ 1002 } 1003 1004#define Init_Susp_State(p, prio, runprio) { \ 1005 (p)[SUSP_STATE].val.ptr = BChp(B.args)->tg;\ 1006 (p)[SUSP_STATE].tag.kernel = TREF | \ 1007 ((prio) << SUSP_PRIO_SHIFT) | \ 1008 (((prio) < (runprio) ? prio : runprio) << SUSP_RUNPRIO_SHIFT); \ 1009} 1010 1011#define Set_Susp_State(p, f) \ 1012 Trail_State(&(p)[SUSP_STATE]);\ 1013 (p)[SUSP_STATE].tag.kernel |= (f) 1014 1015#define Reset_Susp_State(p, f) \ 1016 Trail_State(&(p)[SUSP_STATE]);\ 1017 (p)[SUSP_STATE].tag.kernel &= ~(f) 1018 1019#define Set_Susp_Prio(p, prio) { \ 1020 int _runprio = SuspRunPrio(p); \ 1021 Trail_State(&(p)[SUSP_STATE]);\ 1022 (p)[SUSP_STATE].tag.kernel = \ 1023 ((p)[SUSP_STATE].tag.kernel & ~(SUSP_FLAG_PRIO|SUSP_FLAG_RUNPRIO)) | \ 1024 ((prio) << SUSP_PRIO_SHIFT) | \ 1025 (((prio) < _runprio ? prio : _runprio) << SUSP_RUNPRIO_SHIFT); \ 1026} 1027 1028 1029#define Set_Susp_Flag_Untrailed(p, f) \ 1030 (p)[SUSP_FLAGS].tag.kernel |= (f) 1031#define Set_Susp_Flag(p, f) \ 1032 if ((p) < GB) {\ 1033 Trail_Word(p, 1, TRAILED_WORD32);\ 1034 }\ 1035 Set_Susp_Flag_Untrailed(p, f) 1036 1037#define Reset_Susp_Flag_Untrailed(p, f) \ 1038 (p)[SUSP_FLAGS].tag.kernel &= ~(f) 1039#define Reset_Susp_Flag(p, f) \ 1040 if ((p) < GB) {\ 1041 Trail_Word(p, 1, TRAILED_WORD32);\ 1042 }\ 1043 Reset_Susp_Flag_Untrailed(p, f) 1044 1045 1046#define Update_LD(suspension) \ 1047 LD = (suspension); 1048 1049#define Reset_DE DE = (pword *) 0 1050#define Kill_DE { if (DE) { Set_Susp_Dead(DE); Reset_DE; }} 1051 1052 1053/* 1054 * Woken goals structure 1055 * 1056 * . . . 1057 * | | 1058 * |-----------------| 1059 * | | 1060 * |- List for #1 - -| 1061 * | | 1062 * |-----------------| 1063 * | TSUSP | 1064 * |- - - - - - - - -| 1065 * | previous LD | 1066 * |-----------------| 1067 * | TINT | 1068 * |- - - - - - - - -| 1069 * | previous WP | 1070 * |-----------------| 1071 * | TCOMP | 1072 * |- - - - - - - - -| 1073 * | previous WL | 1074 * |-----------------| 1075 * | TDICT | 1076 * |- - - - - - - - -| 1077 * |woken/SUSP_MAX_PR| 1078 * |-----------------|<-- WL 1079 * 1080 */ 1081 1082#define WL_PREVIOUS 1 1083#define WL_PREVIOUS_WP 2 1084#define WL_PREVIOUS_LD 3 1085#define WL_FIRST 4 1086#define WL_ARITY (WL_FIRST + PRIORITY_MAX - 1) 1087 1088#define LD_END WL[WL_PREVIOUS_LD].val.ptr 1089 1090#define Init_WP(prio) {\ 1091 Make_Stamp(&g_emu_.wp_stamp);\ 1092 WP = (prio);\ 1093 } 1094 1095#define Set_WP(prio) {\ 1096 if (WP != (prio)) {\ 1097 if (OldStamp(&WP_STAMP)) {\ 1098 Update_Stamp(&WP_STAMP)\ 1099 Trail_Word(&WP, 0, TRAILED_WORD32)\ 1100 }\ 1101 WP = (prio);\ 1102 }\ 1103 } 1104 1105 1106#define WLPrevious(wl) ((wl) + WL_PREVIOUS) 1107#define WLPreviousWP(wl) ((wl) + WL_PREVIOUS_WP) 1108#define WLPreviousLD(wl) ((wl) + WL_PREVIOUS_LD) 1109#define WLFirst(wl) ((wl) + WL_FIRST) 1110#define WLArity(maxprio) ((maxprio) + WL_FIRST - 1) 1111#define WLMaxPrio(wl) (DidArity(wl->val.did) - WL_FIRST + 1) 1112 1113#define Update_MU(vptr) { \ 1114 register pword *_pw = TG; \ 1115 TG += 2; \ 1116 Check_Gc; \ 1117 _pw[0].val.ptr = vptr; \ 1118 _pw[0].tag.kernel = TLIST; \ 1119 if (MU) { \ 1120 _pw[1].val.ptr = MU; \ 1121 _pw[1].tag.kernel = TLIST; \ 1122 } else { \ 1123 _pw[1].tag.kernel = TNIL; \ 1124 Fake_Overflow; \ 1125 } \ 1126 MU = _pw; \ 1127 } 1128 1129/*--------------------------------------------------------------------------- 1130 * Occur Check 1131 *---------------------------------------------------------------------------*/ 1132 1133#define OccurCheckEnabled() (GlobalFlags & OCCUR_CHECK) 1134 1135#ifdef OC 1136 1137#ifdef OC_STAT 1138extern int occur_check_read_ = 0, occur_check_write_ = 0; 1139#define OC_Read_Inc occur_check_read_++; 1140#define OC_Write_Inc occur_check_write_++; 1141#else 1142#define OC_Read_Inc 1143#define OC_Write_Inc 1144#endif /* OC_STAT */ 1145 1146#define Occur_Check_Boundary(p) OCB = (p); 1147#define Constructed_Structure(pw) TCS = (pw); 1148#define Occur_Check_Read(var, v, t, fail_action) \ 1149 if (var->val.ptr < OCB && IsCompound(t)) { \ 1150 OC_Read_Inc \ 1151 if (ec_occurs(var->val, var->tag, v, t)) \ 1152 fail_action; \ 1153 } 1154#define Occur_Check_Write(var, fail_action) \ 1155 if (OCB) { \ 1156 register pword *p = var; \ 1157 Occur_Check_Boundary(0); \ 1158 Dereference_(p); \ 1159 if (IsCompound(p->tag) && TCS) { \ 1160 OC_Write_Inc \ 1161 if (occurs_compound(TCS, p)) { \ 1162 fail_action; \ 1163 } \ 1164 } \ 1165 } 1166 1167#else /* OC */ 1168 1169#define Occur_Check_Boundary(p) 1170#define Constructed_Structure(pw) 1171#define Occur_Check_Read(var, v, t, fail_action) 1172#define Occur_Check_Write(var, fail_action) 1173 1174#endif /* OC */ 1175 1176/*--------------------------------------------------------------------------- 1177 * Oracle Recording 1178 *---------------------------------------------------------------------------*/ 1179 1180#define ORC_ALT 1 1181#define ORC_NTRY 2 1182#define ORC_NEXT 3 1183#define ORC_ARITY 3 1184#define ORC_SIZE (ORC_ARITY+1) 1185 1186#define O_SHALLOW 0x00000100 1187#define O_PAR_ORACLE 0x00000200 1188#define O_CHK_ORACLE 0x00000400 1189 1190#define ChpOracle(b) (Chp(b)->tg - ORC_SIZE) 1191#define BOracle(b) (BChp(b)->tg - ORC_SIZE) 1192 1193#define OPrev(po) ((po)[ORC_NEXT].val.ptr) 1194#define OAlt(po) ((po)[ORC_ALT].val.nint) 1195#define OCount(po) ((po)[ORC_NTRY].val.nint) 1196#define OParallel(po) ((po)->tag.kernel & O_PAR_ORACLE) 1197 1198#define O_Set_Flag(po,fl) (po)->tag.kernel |= (fl) 1199#define O_Clr_Flag(po,fl) (po)->tag.kernel &= ~(fl) 1200#define OFlagged(po,fl) ((po)->tag.kernel & (fl)) 1201 1202#define O_Set_Alt(po, alt) (po)[ORC_ALT].val.nint = (alt); 1203#define O_Next_Alt(po) (po)[ORC_ALT].val.nint++; 1204 1205#define O_Reset_Try_Count(po) (po)[ORC_NTRY].val.nint = 0; 1206#define O_Count_Try(po) (po)[ORC_NTRY].val.nint++; 1207 1208#define O_Push(n, flags) { \ 1209 pword *_p = TG; \ 1210 Push_Struct_Frame(d_.arg); \ 1211 O_Set_Flag(_p, flags); \ 1212 _p[ORC_NEXT].val.ptr = TO; \ 1213 _p[ORC_NEXT].tag.kernel = TO? TCOMP: TNIL; \ 1214 Make_Integer(_p+ORC_ALT, n); \ 1215 Make_Integer(_p+ORC_NTRY, 0); \ 1216 TO = _p; \ 1217} 1218 1219 1220#ifdef NEW_ORACLE 1221 1222#define Record_Alternative(n, flags) { \ 1223 if (TO) { /* we are recording */ \ 1224 if (OFlagged(TO,O_SHALLOW)) { \ 1225 if (TO > BOracle(B.args)) { \ 1226 /* don't oracle shallow cuts */ \ 1227 TO = TO[ORC_NEXT].val.ptr; /* pop */ \ 1228 O_Count_Try(TO); \ 1229 } else { \ 1230 O_Clr_Flag(TO,O_SHALLOW); /* bury */ \ 1231 } \ 1232 } \ 1233 O_Push(n, flags); \ 1234 } \ 1235} 1236 1237#define Record_Next_Alternative { \ 1238 if (TO) { \ 1239 TO = BOracle(B.args); \ 1240 O_Next_Alt(TO); \ 1241 O_Reset_Try_Count(TO); \ 1242 } \ 1243} 1244 1245#define Update_Recorded_Alternative(n) { \ 1246 if (TO) { \ 1247 TO = BOracle(B.args); \ 1248 O_Set_Alt(TO, n); \ 1249 O_Reset_Try_Count(TO); \ 1250 } \ 1251} 1252 1253#else /* NEW_ORACLE */ 1254 1255#define Record_Alternative(n, flags) 1256#define Record_Next_Alternative 1257#define Update_Recorded_Alternative(n) 1258 1259#endif /* NEW_ORACLE */ 1260 1261 1262/*--------------------------------------------------------------------------- 1263 * Oracle Following 1264 *---------------------------------------------------------------------------*/ 1265 1266#define NODESIZE sizeof(st_handle_t) 1267#define STOPSIZE 1 1268#define CountSize(i) (1 + (i)/128) 1269#define AltSize(i) ((i)<16 ? 1 : 4) 1270 1271#define ALT_FLAG 1 1272#define CREATE_FLAG 2 1273#define PAR_FLAG 4 1274#define CHK_FLAG 8 1275#define ALT_SHIFT 4 1276#define CNT_SHIFT 1 1277 1278#define Write_Stop(p) *--(p) = 0; 1279 1280#define Write_Count(p,n) { \ 1281 uword _i = n; \ 1282 while (_i > 127) \ 1283 { *--(p) = 127<<CNT_SHIFT; _i -= 127; } \ 1284 *--(p) = _i<<CNT_SHIFT; \ 1285 } 1286 1287#define FoCount(fo, n) ((n) >> CNT_SHIFT) 1288 1289/* CAUTION: this scheme cannot handle n==0 */ 1290#define Write_Alt(p, n, fl) { \ 1291 word _i = (n) < 16 ? (n) : 0; \ 1292 *--(p) = (_i<<ALT_SHIFT)|(fl)|ALT_FLAG; \ 1293 if (_i == 0) { \ 1294 *--(p) = (n) >> 24; \ 1295 *--(p) = (n) >> 16; \ 1296 *--(p) = (n) >> 8; \ 1297 *--(p) = (n); \ 1298 } \ 1299 } 1300 1301#define FoAlt(fo, n) \ 1302 ( (n) >> ALT_SHIFT != 0 \ 1303 ? (n) >> ALT_SHIFT \ 1304 : ( (n) = *(fo)++, \ 1305 (n) = (n) << 8 | (*(fo)++) & 0xff, \ 1306 (n) = (n) << 8 | (*(fo)++) & 0xff, \ 1307 (n) = (n) << 8 | (*(fo)++) & 0xff) \ 1308 ) 1309 1310#define Write_Node(p,node) _write_node(p,node) 1311 1312#define FoHeader(fo) (*(fo)++) 1313#define FoEnd(fo) FoIsStop(*(fo)) 1314#define FoIsStop(i) ((i) == 0) 1315#define FoIsCount(i) (!FoIsAlt(i)) 1316#define FoIsCreate(i) ((i) & CREATE_FLAG) 1317#define FoIsPar(i) ((i) & PAR_FLAG) 1318#define FoIsAlt(i) ((i) & ALT_FLAG) 1319#define FoIsChk(i) ((i) & CHK_FLAG) 1320 1321#define Fo_Node(fo,dest) fo = read_node(fo, dest) 1322 1323extern char *read_node(); 1324 1325 1326/*--------------------------------------------------------------------------- 1327 * Global references used in C 1328 *---------------------------------------------------------------------------*/ 1329 1330#ifdef DFID 1331#define DfidDepth (GLOBVAR[1].val.ptr) 1332#define MaxDepth (GLOBVAR[2].val.ptr->val.nint) 1333#define DepthLimit (GLOBVAR[3].val.ptr->val.nint) 1334#define DepthOV (GLOBVAR[4].val.ptr->val.nint) 1335#endif 1336 1337 1338/*--------------------------------------------------------------------------- 1339 * Get DID for a type 1340 *---------------------------------------------------------------------------*/ 1341 1342#define TransfDid(t) transf_did((word) t) 1343extern dident transf_did ARGS((word)); 1344 1345 1346/*--------------------------------------------------------------------------- 1347 * Tracer 1348 *---------------------------------------------------------------------------*/ 1349 1350/* Trace frame access - must correspond to definition in tracer.pl */ 1351#define TF_HEADER 0 1352#define TF_INVOC 1 1353#define TF_GOAL 2 1354#define TF_LEVEL 3 1355#define TF_CHP_STAMP 4 1356#define TF_ANCESTOR 5 1357#define TF_PROC 6 1358#define TF_PRIO 7 1359#define TF_PATH 8 1360#define TF_LINE 9 1361#define TF_FROM 10 1362#define TF_TO 11 1363#define TF_MODULE 12 1364#define TF_ARITY 12 1365 1366#define DInvoc(td) (td)[TF_INVOC].val.nint 1367#define DGoal(td) (td)[TF_GOAL] 1368#define DLevel(td) (td)[TF_LEVEL].val.nint 1369#define DAncestor(td) (td)[TF_ANCESTOR].val.ptr 1370#define DProc(td) (td)[TF_PROC].val.priptr 1371#define DPath(td) (td)[TF_PATH].val.did 1372#define DLine(td) (td)[TF_LINE].val.nint 1373#define DFrom(td) (td)[TF_FROM].val.nint 1374#define DTo(td) (td)[TF_TO].val.nint 1375 1376#define Push_Dbg_Frame(pw, tinvoc, vgoal, tgoal, depth, prio, proc, filedid, line, from, to, mod) { \ 1377 pw = TG; \ 1378 Push_Struct_Frame(d_.trace_frame); \ 1379 if (PriFlags(proc) & DEBUG_SK) pw[TF_HEADER].tag.kernel |= TF_SKIPPED; \ 1380 if (!(PriFlags(proc) & DEBUG_DB) && (PriFlags(proc) & DEBUG_TRMETA) ) pw[TF_HEADER].tag.kernel |= TF_TRMETA; \ 1381 Make_Integer(&pw[TF_INVOC], tinvoc); \ 1382 pw[TF_GOAL].val.all = vgoal.all; \ 1383 pw[TF_GOAL].tag.all = tgoal.all; \ 1384 Make_Integer(&pw[TF_LEVEL], (word) (depth)); \ 1385 Make_Stamp(&pw[TF_CHP_STAMP]); \ 1386 pw[TF_ANCESTOR] = TAGGED_TD; \ 1387 pw[TF_PROC].val.priptr = proc; \ 1388 pw[TF_PROC].tag.kernel = TPTR; \ 1389 Make_Integer(&pw[TF_PRIO], (word) (prio)); \ 1390 Make_Atom(&pw[TF_PATH], filedid); \ 1391 Make_Integer(&pw[TF_LINE], (word) (line)); \ 1392 Make_Integer(&pw[TF_FROM], (word) (from)); \ 1393 Make_Integer(&pw[TF_TO], (word) (to)); \ 1394 pw[TF_MODULE].val.did = mod; \ 1395 pw[TF_MODULE].tag.kernel = ModuleTag(mod); \ 1396 Make_Struct(&TAGGED_TD, pw); \ 1397 } 1398 1399#define Make_Dbg_Frame(pw, tinvoc, vgoal, tgoal, depth, prio, proc, filedid, line, from, to, mod) { \ 1400 pw = TG; \ 1401 Push_Struct_Frame(d_.trace_frame); \ 1402 if (PriFlags(proc) & DEBUG_SK) pw[TF_HEADER].tag.kernel |= TF_SKIPPED; \ 1403 if (!(PriFlags(proc) & DEBUG_DB) && (PriFlags(proc) & DEBUG_TRMETA) ) pw[TF_HEADER].tag.kernel |= TF_TRMETA; \ 1404 Make_Integer(&pw[TF_INVOC], tinvoc); \ 1405 pw[TF_GOAL].val.all = vgoal.all; \ 1406 pw[TF_GOAL].tag.all = tgoal.all; \ 1407 Make_Integer(&pw[TF_LEVEL], (word) (depth)); \ 1408 Make_Stamp(&pw[TF_CHP_STAMP]); \ 1409 Make_Var(&pw[TF_ANCESTOR]); \ 1410 pw[TF_PROC].val.priptr = proc; \ 1411 pw[TF_PROC].tag.kernel = TPTR; \ 1412 Make_Integer(&pw[TF_PRIO], (word) (prio)); \ 1413 Make_Atom(&pw[TF_PATH], filedid); \ 1414 Make_Integer(&pw[TF_LINE], (word) (line)); \ 1415 Make_Integer(&pw[TF_FROM], (word) (from)); \ 1416 Make_Integer(&pw[TF_TO], (word) (to)); \ 1417 pw[TF_MODULE].val.did = mod; \ 1418 pw[TF_MODULE].tag.kernel = ModuleTag(mod); \ 1419 } 1420 1421#define Make_Partial_Dbg_Frame(pw, tinvoc, goal, prio, proc, filedid, line, from, to, mod) { \ 1422 pw = TG; \ 1423 Push_Struct_Frame(d_.trace_frame); \ 1424 if (PriFlags(proc) & DEBUG_SK) pw[TF_HEADER].tag.kernel |= TF_SKIPPED; \ 1425 if (!(PriFlags(proc) & DEBUG_DB) && (PriFlags(proc) & DEBUG_TRMETA) ) pw[TF_HEADER].tag.kernel |= TF_TRMETA; \ 1426 Make_Integer(&pw[TF_INVOC], tinvoc); \ 1427 pw[TF_GOAL] = (goal); \ 1428 Make_Var(&pw[TF_LEVEL]); \ 1429 Make_Stamp(&pw[TF_CHP_STAMP]); \ 1430 Make_Var(&pw[TF_ANCESTOR]); \ 1431 pw[TF_PROC].val.priptr = proc; \ 1432 pw[TF_PROC].tag.kernel = TPTR; \ 1433 Make_Integer(&pw[TF_PRIO], (word) (prio)); \ 1434 Make_Atom(&pw[TF_PATH], filedid); \ 1435 Make_Integer(&pw[TF_LINE], (word) (line)); \ 1436 Make_Integer(&pw[TF_FROM], (word) (from)); \ 1437 Make_Integer(&pw[TF_TO], (word) (to)); \ 1438 pw[TF_MODULE].val.did = mod; \ 1439 pw[TF_MODULE].tag.kernel = ModuleTag(mod); \ 1440 } 1441 1442#define Pop_Dbg_Frame() { \ 1443 if (TD < GB) { Trail_Pword(&TAGGED_TD); } \ 1444 TAGGED_TD = TD[TF_ANCESTOR]; \ 1445 } 1446 1447/* 1448 * OfInterest is true if: 1449 * - the predicate's DEBUG_TR|DEBUG_SP flags are the same as the tracer's 1450 * TR_TRACING|TR_LEAPING flags, i.e. in creep mode all traceable preds 1451 * match, in leap mode only traceable ones with spy points 1452 * *or* 1453 * tracer is in leap mode and we are at a breakpoint 1454 * 1455 * - depth is in selected range 1456 * - invoc is in selected range 1457 */ 1458#define OfInterest(flags, invoc, depth, brkpt) \ 1459 ( (!((((flags) & TRACEMODE) ^ TRACEMODE) & (TR_TRACING|TR_LEAPING)) \ 1460 || ((brkpt) && (TRACEMODE & TR_LEAPING))) \ 1461 && JMINLEVEL <= (depth) && (depth) <= JMAXLEVEL \ 1462 && JMININVOC <= (invoc) && (invoc) <= JMAXINVOC ) 1463 1464/* 1465 * Init the tracer state. The TR_STARTED flag is used to trigger raising 1466 * of the DEBUG_INIT_EVENT, and is then reset (see raise_init_event/0). 1467 */ 1468#define TracerInit \ 1469 NINVOC = RLEVEL = FDROP = JMININVOC = 0; \ 1470 JMINLEVEL = 0; JMAXLEVEL = MAX_DEPTH; JMAXINVOC = MAX_INVOC; \ 1471 PORTFILTER = ANY_NOTIFIES; \ 1472 TRACEMODE = TR_TRACING|TR_STARTED; 1473 1474/* Flag in debug-event save frame */ 1475#define WAS_CALL (SIGN_BIT >> 3) 1476#define WAS_NONDET (SIGN_BIT >> 4) 1477 1478/* Tracer constants */ 1479#define MAX_INVOC MAX_S_WORD 1480#define MAX_DEPTH MAX_S_WORD 1481#define MAX_FAILTRACE 1024 1482 1483/* Trace frame flags */ 1484#define TF_SKIPPED 0x0100 /* it is a skipped procedure's frame */ 1485#define TF_INTRACER 0x0200 /* we are currently inside tracer code */ 1486#define TF_NOGOAL 0x0400 /* frame's goal/module field is invalid */ 1487#define TF_REDO 0x0800 /* we are tracing a REDO (retry/trust) */ 1488#define TF_BREAK 0x1000 /* this frame's CALL had a breakpoint */ 1489#define TF_SYSTRACE 0x2000 /* abstract instruction trace disabled */ 1490#define TF_SIMPLE 0x4000 /* it is a simple goal's trace frame */ 1491#define TF_TRMETA 0x8000 /* trace metacalled subgoals */ 1492 1493#define TfFlags(td) (td)[TF_HEADER].tag.kernel 1494#define Set_Tf_Flag(td,flag) { TfFlags(td) |= (flag); } 1495#define Clr_Tf_Flag(td,flag) { TfFlags(td) &= ~(flag); } 1496#define Flip_Tf_Flag(td,flag) { TfFlags(td) ^= (flag); } 1497 1498#define Unskipped(td) ((TfFlags(td) & (TF_SKIPPED|TF_INTRACER)) == 0) 1499#define Tracing (TD && Unskipped(TD)) 1500#define TracingWakes(invoc) (!(TfFlags(TD) & (TF_INTRACER)) && (!(TfFlags(TD) & TF_SKIPPED) || (invoc))) 1501#define TracingMetacalls(port) (Unskipped(TD) && (TfFlags(TD) & TF_TRMETA)) 1502 1503 1504/*--------------------------------------------------------------------------- 1505 * Resume types 1506 *---------------------------------------------------------------------------*/ 1507 1508#define RESUME_CONT 0 1509#define RESUME_SIMPLE 1 1510 1511 1512/*--------------------------------------------------------------------------- 1513 * Aritmetic comparisons, for arith_compare() 1514 *---------------------------------------------------------------------------*/ 1515 1516#define BILt 1 1517#define BIGt 2 1518#define BILe 3 1519#define BIGe 4 1520#define BIEq 5 1521#define BINe 6 1522#define BILeGe 7 /* =< or >=, needed for sorting */ 1523 1524/*--------------------------------------------------------------------------- 1525 * Prototypes 1526 *---------------------------------------------------------------------------*/ 1527 1528Extern void re_fake_overflow ARGS((void)); 1529Extern int query_emulc ARGS((value, type, value, type)); 1530Extern int query_emulc_noexit ARGS((value, type, value, type)); 1531Extern int sub_emulc ARGS((value, type, value, type)); 1532Extern DLLEXP int sub_emulc_noexit ARGS((value, type, value, type)); 1533Extern int boot_emulc ARGS((value, type, value, type)); 1534Extern int debug_emulc ARGS((value, type, value, type)); 1535Extern int slave_emulc ARGS((void)); 1536Extern int restart_emulc ARGS((void)); 1537Extern int it_emulc ARGS((value, type)); 1538Extern int return_throw ARGS((value, type)); 1539Extern int longjmp_throw ARGS((value, type)); 1540Extern void next_posted_event ARGS((pword *)); 1541Extern int deep_suspend ARGS((value, type, int, pword*, int)); 1542Extern DLLEXP pword * add_attribute ARGS((word, pword*, word, int)); 1543Extern DLLEXP int insert_suspension ARGS((pword*, int, pword*, int)); 1544Extern DLLEXP int notify_constrained ARGS((pword*)); 1545Extern pword * first_woken ARGS((int)); 1546Extern pword * wl_init ARGS((void)); 1547Extern DLLEXP int bind_c ARGS((pword*, pword*, pword**)); 1548Extern int meta_bind ARGS((pword*, value, type)); 1549Extern DLLEXP int ec_assign ARGS((pword*, value, type)); 1550Extern DLLEXP int ec_schedule_susps ARGS((pword*)); 1551Extern DLLEXP int ec_double_to_int_or_bignum ARGS((double, pword *)); 1552 1553Extern pword * ec_keysort ARGS((value, value, type, int, int, int, int *)); 1554Extern pword * ec_nonground ARGS((value, type)); 1555Extern void untrail_ext ARGS((pword**,int)); 1556Extern void do_cut_action ARGS((void)); 1557Extern DLLEXP void schedule_cut_fail_action ARGS((void (*)(value,type), value, type)); 1558Extern void trail_undo ARGS((pword*, void (*)(pword*))); 1559Extern dident meta_name ARGS((int)); 1560Extern int p_schedule_woken ARGS((value, type)); 1561Extern DLLEXP int p_schedule_postponed ARGS((value, type)); 1562Extern int ec_compare_terms ARGS((value, type, value, type)); 1563Extern int trim_global_trail ARGS((uword)); 1564Extern int trim_control_local ARGS((void)); 1565Extern void mark_dids_from_pwords ARGS((pword *from, register pword *to)); 1566Extern int ec_occurs ARGS((value vs, type ts, value vterm, type tterm)); 1567Extern void ec_init_dynamic_event_queue ARGS((void)); 1568Extern void trim_dynamic_event_queue ARGS((void)); 1569Extern void purge_disabled_dynamic_events ARGS((t_heap_event *event)); 1570Extern DLLEXP int p_merge_suspension_lists ARGS((value, type, value, type, value, type, value, type)); 1571Extern DLLEXP int p_set_suspension_priority ARGS((value, type, value, type)); 1572Extern DLLEXP int ec_enter_suspension ARGS((pword *, pword *)); 1573Extern DLLEXP int unary_arith_op ARGS((value,type,value,type,int,int)); 1574Extern int binary_arith_op ARGS((value,type,value,type,value,type,int)); 1575Extern int un_arith_op ARGS((value,type,pword *,int,int)); 1576Extern int bin_arith_op ARGS((value,type,value,type,pword *,int)); 1577Extern void ec_handle_async ARGS((void)); 1578 1579