home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-gc.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  36KB  |  1,280 lines
  1. /*  pl-gc.c,v 1.3 1993/02/23 13:16:32 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: Garbage Collection
  8. */
  9.  
  10. /*#define O_DEBUG 1*/
  11. #include "pl-incl.h"
  12.  
  13. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  14. This module is based on
  15.  
  16.     Karen Appleby, Mats Carlsson, Seif Haridi and Dan Sahlin
  17.     ``Garbage Collection for Prolog Based on WAM''
  18.     Communications of the ACM, June 1988, vol. 31, No. 6, pages 719-741.
  19.  
  20. Garbage collection is invoked if the WAM  interpreter  is  at  the  call
  21. port.   This  implies  the current environment has its arguments filled.
  22. For the moment we assume the other  reachable  environments  are  filled
  23. completely.   There  is  room  for some optimisations here.  But we will
  24. exploit these later.
  25.  
  26. The sole fact that the garbage collector can  only  be  invoked  if  the
  27. machinery  is  in a well known phase of the execution is irritating, but
  28. sofar I see no solutions around this, nor have had any indications  from
  29. other  Prolog implementors or the literature that this was feasible.  As
  30. a consequence however, we should start the garbage collector well before
  31. the system runs out of memory.
  32.  
  33. In theory, we could have the compiler calculating the maximum amount  of
  34. global   stack   data  created  before  the  next  `save  point'.   This
  35. unfortunately is not possible for the trail stack, which  also  benifits
  36. from  a  garbage  collection pass.  Furthermore, there is the problem of
  37. foreign code creating global stack data (=../2, name/2, read/1, etc.).
  38.  
  39.  
  40.           CONSEQUENCES FOR THE VIRTUAL MACHINE
  41.  
  42. The virtual machine interpreter now should ensure the stack  frames  are
  43. in  a predicatable state.  For the moment, this implies that all frames,
  44. except for the current one (which only has its arguments filled)  should
  45. be  initialised fully.  I'm not yet sure whether we can't do better, but
  46. this is simple and save and allows us to  debug  the  garbage  collector
  47. first before starting on the optimisations.
  48.  
  49.  
  50.         CONSEQUENCES FOR THE DATA REPRESENTATION
  51.  
  52. The garbage collector needs two bits on each cell of `Prolog  data'.   I
  53. decided  to  use the low order two bits for this.  The advantage of this
  54. that pointers to word aligned data are not affected (at least on 32 bits
  55. machines.  Unfortunately, you will have to use 4 bytes alignment  on  16
  56. bits  machines  now  as  well).   This demand only costs us two bits for
  57. integers, which are now shifted two bits to the left when stored on  the
  58. stack.   The  normal  Prolog machinery expects the lower two bits of any
  59. Prolog data object to be zero.  The  garbage  collection  part  must  be
  60. carefull to strip of these two bits before operating on the data.
  61.  
  62. Finally, for the compacting phase we should be able to scan  the  global
  63. stack  both  upwards  and downwards while identifying the objects in it.
  64. This implies reals are  now  packed  into  two  words  and  strings  are
  65. surrounded by a word at the start and end, indicating their length.
  66.  
  67.                   DEBUGGING
  68.  
  69. Debugging a garbage collector is a difficult job.  Bugs --like  bugs  in
  70. memory  allocation--  usually  cause  crashes  long  after  the  garbage
  71. collection has finished.   To  simplify  debugging  a  large  number  of
  72. actions  are  counted  during garbage collection.  At regular points the
  73. consistency between these counts  is  verified.   This  causes  a  small
  74. performance degradation, but for the moment is worth this I think.
  75.  
  76. If the O_DEBUG cpp flag is set  some  additional  expensive  consistency
  77. checks  that need considerable amounts of memory and cpu time are added.
  78. Garbage collection gets about 3-4 times as slow.
  79. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  80.  
  81. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  82. Marking, testing marks and extracting values from GC masked words.
  83. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  84.  
  85. #define GC_MASK        (MARK_MASK|FIRST_MASK)
  86. #define VALUE_MASK    (~GC_MASK)
  87.  
  88. #if O_DEBUG
  89. #define recordMark(p)    { if ( (p) < gTop ) *mark_top++ = (p); }
  90. #else
  91. #define recordMark(p)
  92. #define needsRelocation(p) { needs_relocation++; }
  93. #define check_relocation(p)
  94. #endif
  95.  
  96. #define ldomark(p)    { *(p) |= MARK_MASK; }
  97. #define domark(p)    { if ( marked(p) ) sysError("marked twice: 0x%lx (*= 0x%lx), gTop = 0x%lx", p, *(p), gTop); \
  98.               *(p) |= MARK_MASK; \
  99.               total_marked++; \
  100.               recordMark(p); \
  101.               DEBUG(4, printf("marked(0x%lx)\n", p)); \
  102.             }
  103. #define unmark(p)    (*(p) &= ~MARK_MASK)
  104. #define marked(p)    (*(p) & MARK_MASK)
  105.  
  106. #define mark_first(p)    (*(p) |= FIRST_MASK)
  107. #define unmark_first(p)    (*(p) &= ~FIRST_MASK)
  108. #define is_first(p)    (*(p) & FIRST_MASK)
  109.  
  110. #define get_value(p)    (*(p) & VALUE_MASK)
  111. #define set_value(p, w)    { *(p) &= GC_MASK; *(p) |= w; }
  112.  
  113. #define onGlobal(p)    ((Word)(p) >= gBase && (Word)(p) < gTop)
  114. #define isGlobalRef(w)    (  ((isIndirect(w) || isPointer(w)) \
  115.                 && onGlobal(unMask(w))) \
  116.             || (isRef(w) && onGlobal(unRef(w))))
  117.  
  118. #define L_MARK       0    /* Foreign reference marks */
  119. #define L_WORD      1
  120. #define L_POINTER 2
  121.  
  122. forwards long        offset_cell P((Word));
  123. forwards Word        previous_gcell P((Word));
  124. forwards void        mark_variable P((Word));
  125. forwards void        mark_foreign P((void));
  126. forwards void        clear_uninitialised P((LocalFrame, Code));
  127. forwards LocalFrame    mark_environments P((LocalFrame));
  128. forwards void        mark_choicepoints P((LocalFrame));
  129. forwards void        mark_stacks P((LocalFrame));
  130. forwards void        mark_phase P((LocalFrame));
  131. forwards void        update_relocation_chain P((Word, Word));
  132. forwards void        into_relocation_chain P((Word));
  133. forwards void        compact_trail P((void));
  134. forwards void        sweep_mark P((mark *));
  135. forwards void        sweep_foreign P((void));
  136. forwards void        sweep_trail P((void));
  137. forwards LocalFrame    sweep_environments P((LocalFrame));
  138. forwards void        sweep_choicepoints P((LocalFrame));
  139. forwards void        sweep_stacks P((LocalFrame));
  140. forwards void        sweep_local P((LocalFrame));
  141. forwards bool        is_downward_ref P((Word));
  142. forwards bool        is_upward_ref P((Word));
  143. forwards void        compact_global P((void));
  144. forwards void        collect_phase P((LocalFrame));
  145.  
  146. #if O_DEBUG
  147. forwards int        cmp_address P((Word *, Word *));
  148. forwards void        check_relocation P((Word));
  149. forwards void        needsRelocation P((Word));
  150. forwards bool        scan_global P((void));
  151. #endif
  152.         /********************************
  153.         *           GLOBALS             *
  154.         *********************************/
  155.  
  156. static long total_marked;    /* # marked global cells */
  157. static long trailcells_deleted;    /* # garbage trailcells */
  158. static long relocation_chains;    /* # relocation chains (debugging) */
  159. static long relocation_cells;    /* # relocation cells */
  160. static long relocated_cells;    /* # relocated cells */
  161. static long needs_relocation;    /* # cells that need relocation */
  162. static long local_marked;    /* # cells marked local -> global ptrs */
  163. static long relocation_refs;    /* # refs that need relocation */
  164. static long relocation_indirect;/* # indirects */
  165.  
  166. #if O_DEBUG
  167.         /********************************
  168.         *           DEBUGGING           *
  169.         *********************************/
  170.  
  171. static Word *mark_base;            /* Array of addresses of marked cells */
  172. static Word *mark_top;            /* Top of this array */
  173. static Table check_table = NULL;    /* relocation address table */
  174.  
  175. static void
  176. needsRelocation(addr)
  177. Word addr;
  178. { needs_relocation++;
  179.  
  180.   addHTable(check_table, addr, (Void) TRUE);
  181. }
  182.  
  183. static void
  184. check_relocation(addr)
  185. Word addr;
  186. { Symbol s;
  187.   if ( (s=lookupHTable(check_table, addr)) == NULL )
  188.   { sysError("Address 0x%lx was not supposed to be relocated", addr);
  189.     return;
  190.   }
  191.  
  192.   if ( s->value == FALSE )
  193.   { sysError("Relocated twice: 0x%lx", addr);
  194.     return;
  195.   }
  196.  
  197.   s->value = FALSE;
  198. }
  199. #endif /* O_DEBUG */
  200.  
  201.         /********************************
  202.         *          UTILITIES            *
  203.         *********************************/
  204.  
  205. static long
  206. offset_cell(p)
  207. Word p;
  208. { word w = get_value(p);
  209.  
  210.   if ( (w & DATA_TAG_MASK) == REAL_MASK )
  211.   { DEBUG(3, printf("REAL at 0x%lx (w = 0x%lx)\n", p, w));
  212.     return 1;
  213.   }
  214.   if ( (w & DATA_TAG_MASK) == STRING_MASK )
  215.   { long l = ((w) << DMASK_BITS) >> (DMASK_BITS+LMASK_BITS);
  216.     DEBUG(3, printf("STRING ``%s'' at 0x%lx (w = 0x%lx)\n", p, p+1, w));
  217.     return allocSizeString(l) / sizeof(word) - 1;
  218.   }
  219.   
  220.   return 0;
  221. }
  222.  
  223. static Word
  224. previous_gcell(p)
  225. Word p;
  226. { p--;
  227.   return p - offset_cell(p);
  228. }
  229.  
  230.         /********************************
  231.         *            MARKING            *
  232.         *********************************/
  233.  
  234. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  235. void mark_variable(start)
  236.      Word start;
  237.  
  238. After the marking phase has been completed, the following statements are
  239. supposed to hold:
  240.  
  241.     - All non-garbage cells on the local- and global stack are
  242.       marked.
  243.     - `total_marked' equals the size of the global stack AFTER
  244.       compacting (e.i. the amount of non-garbage) in words.
  245.     - `needs_relocation' holds the total number of references from the
  246.       argument- and local variable fields of the local stack and the
  247.       internal global stack references that need be relocated. This
  248.       number is only used for consistency checking with the relocation
  249.       statistic obtained during the compacting phase.
  250.  
  251. The marking algorithm forms a two-state  machine.   While  going  deeper
  252. into  the reference tree, the pointers are reversed and the first bit is
  253. set to indicate the choiche points created by complex terms with arity >
  254. 1.  Also the actuall mark bit is set  on  the  cells.   If  a  leafe  is
  255. reached  the process reverses, restoring the old pointers.  If a `first'
  256. mark is reached we are either finished, or have reached a choice  point,
  257. in  which case the alternative is the cell above (structures are handled
  258. last-argument-first).
  259.  
  260. Mark the tree of global stack cells, referenced by the local stack  word
  261. `start'.  Things are a bit more difficult than described in the liteture
  262. above as SWI-Prolog does not use  a  structure  to  describe  a  general
  263. Prolog object, but just a 32 bits long.  This has performance advantages
  264. as we can exploit things like using negative numbers for references.  It
  265. has  some  disadvantages  here as we have to distinguis some more cases.
  266. Strings and reals on the stacks complicate matters even more.
  267. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  268.  
  269. #define FORWARD        goto forward
  270. #define BACKWARD    goto backward
  271.  
  272. static void
  273. mark_variable(start)
  274. Word start;
  275. { register Word current;        /* current cell examined */
  276.   register word val;            /* old value of current cell */
  277.   register Word next;            /* cell to be examined */
  278.  
  279.   DEBUG(2, printf("marking 0x%lx\n", start));
  280.  
  281.   if ( marked(start) )
  282.     sysError("Attempth to mark twice");
  283.  
  284.   local_marked++;
  285.   current = start;
  286.   mark_first(current);
  287.   val = get_value(current);  
  288.   total_marked--;            /* do not count local stack cell */
  289.   FORWARD;
  290.  
  291. forward:                /* Go into the tree */
  292.   if ( marked(current) )        /* have been here */
  293.     BACKWARD;
  294.   domark(current);
  295.  
  296.   if ( isRef(val) )
  297.   { next = unRef(val);            /* address pointing to */
  298.     if ( next < gBase )
  299.       sysError("REF pointer to 0x%lx\n", next);
  300.     needsRelocation(current);
  301.     relocation_refs++;
  302.     if ( is_first(next) )        /* ref to choice point. we will */
  303.       BACKWARD;                /* get there some day anyway */
  304.     val  = get_value(next);        /* invariant */
  305.     set_value(next, makeRef(current));    /* create backwards pointer */
  306.     DEBUG(5, printf("Marking REF from 0x%lx to 0x%lx\n", current, next));
  307.     current = next;            /* invariant */
  308.     FORWARD;
  309.   }
  310.   /* This is isTerm(); but that is not selective enough (TROUBLE) */
  311.   if ( isPointer(val) &&
  312.        isPointer(get_value((Word)val)) &&
  313.        ((FunctorDef)get_value((Word)val))->type == FUNCTOR_TYPE )
  314.   { int args;
  315.  
  316.     needsRelocation(current);
  317.     next = (Word) val;            /* address of term on global stack */
  318.     if ( next < gBase || next >= gTop )
  319.       sysError("TERM pointer to 0x%lx\n", next);
  320.     if ( marked(next) )
  321.       BACKWARD;                /* term has already been marked */
  322.     args = functorTerm(val)->arity - 1;    /* members to flag first */
  323.     DEBUG(5, printf("Marking TERM %s/%d at 0x%lx\n", stringAtom(functorTerm(val)->name), args+1, next));
  324.     domark(next);
  325.     for( next += 2; args > 0; args--, next++ )
  326.       mark_first(next);
  327.     next--;                /* last cell of term */
  328.     val = get_value(next);        /* invariant */
  329.     set_value(next, (word)current);    /* backwards pointer (NO ref!) */
  330.     current = next;
  331.     FORWARD;
  332.   }
  333.   if ( isIndirect(val) )        /* string or real pointer */
  334.   { next = (Word) unMask(val);
  335.  
  336.     if ( next < gBase )
  337.       sysError("INDIRECT pointer from 0x%lx to 0x%lx\n", current, next);
  338.     needsRelocation(current);
  339.     relocation_indirect++;
  340.     if ( marked(next) )            /* can be referenced from multiple */
  341.       BACKWARD;                /* places */
  342.     domark(next);
  343.     DEBUG(3, printf("Marked indirect data type, size = %ld\n",
  344.             offset_cell(next) + 1));
  345.     total_marked += offset_cell(next);
  346.   }
  347.   BACKWARD;
  348.  
  349. backward:                  /* reversing backwards */
  350.   if ( !is_first(current) )
  351.   { if ( isRef(get_value(current)) )    /* internal cell */
  352.     { next = unRef(get_value(current));
  353.       set_value(current, val);        /* restore its value */
  354.       val  = makeRef(current);        /* invariant */
  355.       current = next;            /* invariant */
  356.       BACKWARD;
  357.     } else                /* first cell of term */
  358.     { next = (Word) get_value(current);
  359.       set_value(current, val);        /* elements of term ok now */
  360.       val = (word)(current - 1);    /* invariant */
  361.       current = next;
  362.       BACKWARD;
  363.     }
  364.   }
  365.   unmark_first(current);
  366.   if ( current == start )
  367.     return;
  368.  
  369.   { word tmp;
  370.  
  371.     tmp = get_value(current);
  372.     set_value(current, val);        /* restore old value */
  373.     current--;
  374.     val = get_value(current);        /* invariant */
  375.     set_value(current, tmp);
  376.     FORWARD;
  377.   }
  378. }
  379.  
  380. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  381. References from foreign code.
  382. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  383.  
  384. static void
  385. mark_foreign()
  386. { Lock l;
  387.  
  388.   for( l = pBase; l < pTop; l++ )
  389.   { switch( l->type )
  390.     { case L_WORD:
  391.     { Word sp = (Word) (l->value << 2);
  392.  
  393.       if ( isGlobalRef(*sp) );
  394.       { DEBUG(5, printf("Marking foreign value at 0x%lx\n"));
  395.         mark_variable(sp);
  396.       }
  397.  
  398.       break;
  399.     }
  400.       case L_POINTER:
  401.     { Word *sp = (Word *) (l->value << 2);
  402.  
  403.       if ( !marked(*sp) && isGlobalRef(**sp) )
  404.       { DEBUG(5, printf("Marking foreign pointer at 0x%lx\n"));
  405.         mark_variable(*sp);
  406.       }
  407.  
  408.       break;
  409.     }
  410.       case L_MARK:
  411.     break;
  412.     }
  413.   }
  414. }
  415.  
  416.  
  417. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  418. Marking the environments.
  419. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  420.  
  421. static void
  422. clear_uninitialised(fr, PC)
  423. LocalFrame fr;
  424. Code PC;
  425. { if ( PC != NULL )
  426.   { Code branch_end = NULL;
  427.  
  428.     for( ; ; PC += (codeTable[decode(*PC)].arguments + 1))
  429.     { switch(decode(*PC))
  430.       { case I_EXIT:
  431.       return;
  432.     case C_JMP:
  433.       if ( PC >= branch_end )
  434.         branch_end = PC + PC[1] + 2;
  435.       break;
  436.     case B_FIRSTVAR:
  437.     case B_ARGFIRSTVAR:
  438.     case C_VAR:
  439.       if ( varFrameP(fr, PC[1]) < argFrameP(fr, fr->procedure->functor->arity) )
  440.         sysError("Reset instruction on argument");
  441.       if ( PC >= branch_end )
  442.         setVar(varFrame(fr, PC[1]));
  443.       break;
  444.       }
  445.       if ( decode(*PC) > I_HIGHEST )
  446.     sysError("GC: Illegal WAM instruction: %d", decode(*PC));
  447.     }
  448.   }
  449. }
  450.  
  451.  
  452. static LocalFrame
  453. mark_environments(fr)
  454. LocalFrame fr;
  455. { Code PC = NULL;
  456.  
  457.   if ( fr == (LocalFrame) NULL )
  458.     return (LocalFrame) NULL;
  459.  
  460.   for( ; ; )
  461.   { int slots;
  462.     Word sp;
  463.     
  464.     if ( true(fr, FR_MARKED) )
  465.       return (LocalFrame) NULL;        /* from choicepoints only */
  466.     set(fr, FR_MARKED);
  467.     
  468.     DEBUG(2, printf("Marking [%ld] %s\n",
  469.         levelFrame(fr), procedureName(fr->procedure)));
  470.  
  471.     clear_uninitialised(fr, PC);
  472.  
  473.     slots = (PC == NULL ? fr->procedure->functor->arity : slotsFrame(fr));
  474.     sp = argFrameP(fr, 0);
  475.     for( ; slots > 0; slots--, sp++ )
  476.     { if ( !marked(sp) )
  477.       { if ( isGlobalRef(*sp) )
  478.       mark_variable(sp);
  479.     else
  480.       ldomark(sp);      
  481.       }
  482.     }
  483.  
  484.     PC = fr->programPointer;
  485.     if ( fr->parent != NULL )
  486.       fr = fr->parent;
  487.     else
  488.       return parentFrame(fr);    /* Prolog --> C --> Prolog calls */
  489.   }
  490. }
  491.  
  492. static void
  493. mark_choicepoints(bfr)
  494. LocalFrame bfr;
  495. { TrailEntry te = tTop - 1;
  496.  
  497.   trailcells_deleted = 0;
  498.  
  499.   for( ; bfr != (LocalFrame)NULL; bfr = bfr->backtrackFrame )
  500.   { Word top = argFrameP(bfr, bfr->procedure->functor->arity);
  501.  
  502.     for( ; te >= bfr->mark.trailtop; te-- )    /* early reset of vars */
  503.     { if ( te->address >= top )
  504.       { te->address = (Word) NULL;
  505.         trailcells_deleted++;
  506.       } else if ( !marked(te->address) )
  507.       { setVar(*te->address);
  508.         DEBUG(3, printf("Early reset of 0x%lx\n", te->address));
  509.         te->address = (Word) NULL;
  510.     trailcells_deleted++;
  511.       }
  512.     }
  513.     needsRelocation((Word)&bfr->mark.trailtop);
  514.     into_relocation_chain((Word)&bfr->mark.trailtop);
  515.  
  516.     mark_environments(bfr);
  517.   }
  518.   
  519.   DEBUG(3, printf("Trail stack garbage: %ld cells\n", trailcells_deleted));
  520. }
  521.  
  522. static void
  523. mark_stacks(fr)
  524. LocalFrame fr;
  525. { LocalFrame pfr;
  526.  
  527.   if ( (pfr = mark_environments(fr)) != NULL )
  528.     mark_stacks(pfr);
  529.  
  530.   mark_choicepoints(fr);
  531. }
  532.  
  533. #if O_DEBUG
  534. static int
  535. cmp_address(p1, p2)
  536. Word *p1, *p2;
  537. { return *p1 > *p2 ? 1 : *p1 == *p2 ? 0 : -1;
  538. }
  539. #endif
  540.  
  541. static void
  542. mark_phase(fr)
  543. LocalFrame fr;
  544. { total_marked = 0;
  545. #if O_DEBUG
  546.   mark_top = mark_base = (Word *) addPointer(lTop, 8192);    /* hack */
  547. #endif
  548.  
  549.   mark_foreign();
  550.   mark_stacks(fr);
  551.  
  552. #if O_DEBUG
  553.   qsort(mark_base, mark_top - mark_base, sizeof(Word), cmp_address);
  554. #endif
  555.  
  556.   DEBUG(2, { long size = gTop - gBase;
  557.          printf("%ld referenced cell; %ld garbage (gTop = 0x%lx)\n",
  558.             total_marked, size - total_marked, gTop);
  559.        });
  560. }
  561.  
  562.  
  563.         /********************************
  564.         *          COMPACTING           *
  565.         *********************************/
  566.  
  567.  
  568. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  569. Relocation chain management
  570.  
  571. A relocation chain is a linked chain of cells, whose elements all should
  572. point to `dest' after it is unwound.  SWI-Prolog knows about a number of
  573. different pointers.  This routine is supposed  to  restore  the  correct
  574. pointer.  The following types are identified:
  575.  
  576.     source    types
  577.     local    address values (gTop references)
  578.             term, reference and indirect pointers
  579.     trail    address values (reset addresses)
  580.     global    term, reference and indirect pointers
  581.  
  582. To do this, a pointer of the same  type  is  stored  in  the  relocation
  583. chain.
  584.  
  585.     update_relocation_chain(current, dest)
  586.     This function checks whether current is the head of a relocation
  587.     chain.  As we know `dest' is the place  `current'  is  going  to
  588.     move  to,  we  can reverse the chain and have all pointers in it
  589.     pointing to `dest'.
  590.  
  591.     We must clear the `first' bit on the field.
  592. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  593.  
  594. static void
  595. update_relocation_chain(current, dest)
  596. Word current, dest;
  597. { if ( is_first(current) )
  598.   { Word head = current;
  599.     word val = get_value(current);
  600.  
  601.     DEBUG(2, printf("unwinding relocation chain at 0x%lx to 0x%lx\n", current, dest));
  602.  
  603.     do
  604.     { unmark_first(current);
  605.       if ( isRef(val) )
  606.       { current = unRef(val);
  607.         val = get_value(current);
  608.     DEBUG(2, printf("Ref from 0x%lx\n", current));
  609.         set_value(current, makeRef(dest));
  610.       } else if ( isIndirect(val) )
  611.       { current = (Word)unMask(val);
  612.         val = get_value(current);
  613.         DEBUG(2, printf("Indirect link from 0x%lx\n", current));
  614.         set_value(current, (word)dest | INDIRECT_MASK);
  615.       } else
  616.       { current = (Word) val;
  617.         val = get_value(current);
  618.         DEBUG(2, printf("Pointer from 0x%lx\n", current));
  619.         set_value(current, (word)dest);
  620.       }
  621.       relocated_cells++;
  622.     } while( is_first(current) );
  623.  
  624.     set_value(head, val);
  625.     relocation_chains--;
  626.   }
  627. }
  628.  
  629.  
  630. static void
  631. into_relocation_chain(current)
  632. Word current;
  633. { Word head;
  634.   word val = get_value(current);
  635.   
  636.   if ( isRef(val) )
  637.   { head = unRef(val);
  638.     set_value(current, get_value(head));
  639.     set_value(head, makeRef(current));
  640.     relocation_refs--;
  641.   } else if ( isIndirect(val) )
  642.   { head = (Word)unMask(val);
  643.     set_value(current, get_value(head));
  644.     set_value(head, (word)current | INDIRECT_MASK);
  645.     relocation_indirect--;
  646.   } else
  647.   { head = (Word) val;
  648.     set_value(current, get_value(head));
  649.     set_value(head, (word)current);
  650.   }
  651.   DEBUG(2, printf("Into relocation chain: 0x%lx (head = 0x%lx)\n", current, head));
  652.  
  653.   if ( is_first(head) )
  654.     mark_first(current);
  655.   else
  656.   { mark_first(head);
  657.     relocation_chains++;
  658.   }
  659.  
  660.   relocation_cells++;
  661. }
  662.  
  663. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  664. Trail stack compacting.
  665. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  666.  
  667. static void
  668. compact_trail()
  669. { TrailEntry dest, current;
  670.   Lock l;
  671.   
  672.     /* get foreign references into the relocation chains */
  673.   for( l = pBase; l < pTop; l++ )
  674.   { if ( l->type == L_MARK )
  675.     { mark *m = (mark *) (l->value << 2);
  676.     
  677.       if ( m->trailtop > tTop )
  678.         sysError("Illegal trail mark from foreign code");
  679.  
  680.       DEBUG(5, printf("Foreign mark: "));
  681.       needsRelocation((Word) &m->trailtop);
  682.       into_relocation_chain((Word) &m->trailtop);
  683.     }
  684.   }
  685.  
  686.     /* compact the trail stack */
  687.   for( dest = current = tBase; current < tTop; )
  688.   { if ( is_first((Word) current) )
  689.       update_relocation_chain((Word) current, (Word) dest);
  690. #if O_DEBUG
  691.     else
  692.     { Symbol s;
  693.       if ( (s=lookupHTable(check_table, current)) != NULL && s->value == TRUE )
  694.         sysError("0x%lx was supposed to be relocated (*= 0x%lx)",
  695.          current, current->address);
  696.     }
  697. #endif
  698.  
  699.     if ( current->address != (Word) NULL )
  700.       *dest++ = *current++;
  701.     else
  702.       current++;
  703.   }
  704.   if ( is_first((Word) current) )
  705.     update_relocation_chain((Word) current, (Word) dest);
  706.  
  707.   tTop = dest;
  708.  
  709.   if ( relocated_cells != relocation_cells )
  710.     sysError("After trail: relocation cells = %ld; relocated_cells = %ld\n",
  711.     relocation_cells, relocated_cells);
  712. } 
  713.  
  714. static void
  715. sweep_mark(m)
  716. mark *m;
  717. { Word gm, prev;
  718.  
  719.   gm = m->globaltop;
  720.   for(;;)
  721.   { if ( gm == gBase )
  722.     { m->globaltop = gm;
  723.       break;
  724.     }
  725.     prev = previous_gcell(gm);
  726.     if ( marked(prev) )
  727.     { m->globaltop = gm;
  728.       DEBUG(2, printf("gTop mark from choice point: "));
  729.       needsRelocation((Word) &m->globaltop);
  730.       into_relocation_chain((Word) &m->globaltop);
  731.       break;
  732.     }
  733.     gm = prev;
  734.   }
  735. }
  736.  
  737.  
  738. static void
  739. sweep_foreign()
  740. { Lock l;
  741.  
  742.   for( l = pBase; l < pTop; l++ )
  743.   { switch( l->type )
  744.     { case L_WORD:
  745.     { Word sp = (Word) (l->value << 2);
  746.       
  747.       unmark(sp);
  748.       if ( isGlobalRef(get_value(sp)) )
  749.       { DEBUG(5, printf("Foreign value: "));
  750.         check_relocation(sp);
  751.         into_relocation_chain(sp);
  752.       }
  753.       break;
  754.     }
  755.       case L_POINTER:
  756.     { Word *sp = (Word *) (l->value << 2);
  757.     
  758.       if ( marked(*sp) && isGlobalRef(get_value(*sp)) )
  759.       { DEBUG(5, printf("Foreign pointer: "));
  760.         check_relocation(*sp);
  761.         into_relocation_chain(*sp);
  762.       }
  763.  
  764.       break;
  765.     }
  766.       case L_MARK:
  767.     DEBUG(5, printf("Foreign mark: "));
  768.     sweep_mark((mark *) (l->value << 2));
  769.     break;
  770.     }
  771.   }
  772. }
  773.  
  774. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  775. Sweeping the local and trail stack to insert necessary pointers  in  the
  776. relocation chains.
  777. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  778.  
  779. static void
  780. sweep_trail()
  781. { register TrailEntry te = tTop - 1;
  782.  
  783.   for( ; te >= tBase; te-- )
  784.   { if ( onGlobal(te->address) )
  785.     { needsRelocation((Word) &te->address);
  786.       into_relocation_chain((Word) &te->address);
  787.     }
  788.   }
  789. }
  790.  
  791.  
  792. static LocalFrame
  793. sweep_environments(fr)
  794. LocalFrame fr;
  795. { Code PC = NULL;
  796.  
  797.   if ( fr == (LocalFrame) NULL )
  798.     return (LocalFrame) NULL;
  799.  
  800.   for( ; ; )
  801.   { int slots;
  802.     Word sp;
  803.  
  804.     if ( false(fr, FR_MARKED) )
  805.       return (LocalFrame) NULL;
  806.     clear(fr, FR_MARKED);
  807.  
  808.     slots = (PC == NULL ? fr->procedure->functor->arity : slotsFrame(fr));
  809.     sp = argFrameP(fr, 0);
  810.     for( ; slots > 0; slots--, sp++ )
  811.     { if ( marked(sp) )
  812.       { unmark(sp);
  813.     if ( isGlobalRef(get_value(sp)) )
  814.     { local_marked--;
  815.       check_relocation(sp);
  816.       into_relocation_chain(sp);
  817.     }
  818.       }
  819.     }
  820.  
  821.     PC = fr->programPointer;
  822.     if ( fr->parent != NULL )
  823.       fr = fr->parent;
  824.     else
  825.       return parentFrame(fr);    /* Prolog --> C --> Prolog calls */
  826.   }
  827. }
  828.  
  829.  
  830. static void
  831. sweep_choicepoints(bfr)
  832. LocalFrame bfr;
  833. { for( ; bfr != (LocalFrame)NULL; bfr = bfr->backtrackFrame )
  834.   { sweep_environments(bfr);
  835.     sweep_mark(&bfr->mark);
  836.   }
  837. }
  838.  
  839. static void
  840. sweep_stacks(fr)
  841. LocalFrame fr;
  842. { LocalFrame pfr;
  843.  
  844.   if ( (pfr = sweep_environments(fr)) != NULL )
  845.     sweep_stacks(pfr);
  846.  
  847.   sweep_choicepoints(fr);
  848. }
  849.  
  850.  
  851. static void
  852. sweep_local(fr)
  853. LocalFrame fr;
  854. { sweep_stacks(fr);
  855.  
  856.   if ( local_marked != 0 )
  857.     sysError("local_marked = %ld", local_marked);
  858. }
  859.  
  860. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  861. All preparations have been made now, and the actual  compacting  of  the
  862. global  stack  may  start.   The  marking phase has calculated the total
  863. number of words (cells) in the global stack that are none-garbage.
  864.  
  865. In the first phase, we will  walk  along  the  global  stack  from  it's
  866. current  top towards the bottom.  During this phase, `current' refers to
  867. the current element we are processing, while `dest' refers to the  place
  868. this  element  will  be  after  the compacting phase is completed.  This
  869. invariant is central and should be maintained carefully while processing
  870. alien objects as strings and reals, which happen to have a  non-standard
  871. size.
  872. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  873.  
  874. static bool
  875. is_downward_ref(p)
  876. Word p;
  877. { word val = get_value(p);
  878.  
  879.   if ( isRef(val) )
  880.   { DEBUG(5, if ( unRef(val) < p ) printf("REF: "));
  881.     return unRef(val) < p;
  882.   }
  883.   if ( isVar(val) || isInteger(val) )
  884.     fail;
  885.   if ( isIndirect(val) )
  886.   { DEBUG(5, if ( (Word)unMask(val) < p ) printf("INDIRECT: "));
  887.     return (Word)unMask(val) < p;
  888.   }
  889.  
  890.   DEBUG(5, if ( (Word)val < p && (Word)val >= gBase ) printf("TERM: "));
  891.   if ( (Word)val < p && (Word)val >= gBase && !marked((Word)val) )
  892.     sysError("Pointer to term should be marked (down)");
  893.  
  894.   return (Word)val < p && (Word)val >= gBase;
  895. }
  896.  
  897. static bool
  898. is_upward_ref(p)
  899. Word p;
  900. { word val = get_value(p);
  901.  
  902.   if ( isRef(val) )
  903.     return unRef(val) > p;
  904.   if ( isVar(val) || isInteger(val) )
  905.     fail;
  906.   if ( isIndirect(val) )
  907.     return (Word)unMask(val) > p;
  908.  
  909.   if ( (Word)val > p && (Word)val < gTop && !marked((Word)val) )
  910.     sysError("Pointer to term should be marked (up) \n\
  911.          p = 0x%lx, val = 0x%lx, *val = 0x%lx, gTop = 0x%lx",
  912.          p, val, *((Word)val), gTop);
  913.  
  914.   return (Word)val > p && (Word)val < gTop;
  915. }
  916.  
  917. static void
  918. compact_global()
  919. { Word dest, current;
  920. #if O_DEBUG
  921.   Word *v = mark_top;
  922. #endif
  923.  
  924.   DEBUG(2, printf("Scanning global stack downwards\n"));
  925.  
  926.   dest = gBase + total_marked;            /* first FREE cell */
  927.   for( current = gTop; current >= gBase; current-- )
  928.   { long offset = (marked(current) || is_first(current) ? 0
  929.                                 : offset_cell(current));
  930.     current -= offset;
  931.  
  932.     if ( marked(current) )
  933.     {
  934. #if O_DEBUG
  935.       if ( current != *--v )
  936.         sysError("Marked cell at 0x%lx (*= 0x%lx); gTop = 0x%lx; should have been 0x%lx", current, *current, gTop, *v);
  937. #endif
  938.       dest -= offset + 1;
  939.       DEBUG(3, printf("Marked cell at 0x%lx (size = %ld; dest = 0x%lx)\n",
  940.                         current, offset+1, dest));
  941.       update_relocation_chain(current, dest);
  942.       if ( is_downward_ref(current) )
  943.       { check_relocation(current);
  944.     into_relocation_chain(current);
  945.       }
  946.     } else
  947.     { update_relocation_chain(current, dest);    /* gTop refs from marks */
  948.     }
  949.   }
  950.  
  951. #if O_DEBUG
  952.   if ( v != mark_base )
  953.   { for( v--; v >= mark_base; v-- )
  954.     { printf("Expected marked cell at 0x%lx, (*= 0x%lx)\n", *v, **v);
  955.     }
  956.     sysError("v = 0x%lx; mark_base = 0x%lx", v, mark_base);
  957.   }
  958. #endif
  959.  
  960.   if ( dest != gBase )
  961.     sysError("Mismatch in down phase: dest = 0x%lx, gBase = 0x%lx\n",
  962.                             dest, gBase);
  963.   if ( relocation_cells != relocated_cells )
  964.     sysError("After down phase: relocation_cells = %ld; relocated_cells = %ld",
  965.                     relocation_cells, relocated_cells);
  966.  
  967.   DEBUG(2, printf("Scanning global stack upwards\n"));
  968.   dest = gBase;
  969.   for(current = gBase; current < gTop; )
  970.   { if ( marked(current) )
  971.     { long l, n;
  972.  
  973.       update_relocation_chain(current, dest);
  974.  
  975.       if ( (l = offset_cell(current)) == 0 )    /* normal cells */
  976.       { *dest = *current;
  977.         if ( is_upward_ref(current) )
  978.     { check_relocation(current);
  979.           into_relocation_chain(dest);
  980.     }
  981.     unmark(dest);
  982.     dest++;
  983.     current++;
  984.       } else                    /* indirect values */
  985.       { Word cdest, ccurrent;
  986.  
  987.     l++;
  988.     
  989.     for( cdest=dest, ccurrent=current, n=0; n < l; n++ )
  990.       *cdest++ = *ccurrent++;
  991.       
  992.     unmark(dest);
  993.     dest += l;
  994.     current += l;
  995.       }
  996.  
  997.     } else
  998.       current += offset_cell(current) + 1;
  999.   }
  1000.  
  1001.   if ( dest != gBase + total_marked )
  1002.     sysError("Mismatch in up phase: dest = 0x%lx, gBase + total_marked = 0x%lx\n", dest, gBase + total_marked );
  1003.  
  1004.   gTop = dest;
  1005. }
  1006.  
  1007. static void
  1008. collect_phase(fr)
  1009. LocalFrame fr;
  1010. { DEBUG(2, printf("Sweeping foreign references\n"));
  1011.   sweep_foreign();
  1012.   DEBUG(2, printf("Sweeping trail stack\n"));
  1013.   sweep_trail();
  1014.   DEBUG(2, printf("Sweeping local stack\n"));
  1015.   sweep_local(fr);
  1016.   DEBUG(2, printf("Compacting global stack\n"));
  1017.   compact_global();
  1018.  
  1019.   if ( relocation_chains != 0 )
  1020.     sysError("relocation chains = %ld", relocation_chains);
  1021.   if ( relocated_cells != relocation_cells ||
  1022.        relocated_cells != needs_relocation ||
  1023.        relocation_refs != 0 || relocation_indirect != 0)
  1024.     sysError("relocation cells = %ld; relocated_cells = %ld, needs_relocation = %ld\n\trelocation_refs = %ld, relocation_indirect = %ld",
  1025.     relocation_cells, relocated_cells, needs_relocation,
  1026.     relocation_refs, relocation_indirect);
  1027. }
  1028.  
  1029.  
  1030.         /********************************
  1031.         *             MAIN              *
  1032.         *********************************/
  1033.  
  1034. static long gsmall = 200000L;
  1035. static long tsmall = 100000L;
  1036.  
  1037. word
  1038. pl_collect_parms(g, t)
  1039. Word g, t;
  1040. { if ( !isInteger(*g) || !isInteger(*t) )
  1041.     return warning("$collect_parms/2: instantiation fault");
  1042.  
  1043.   gsmall = valNum(*g);
  1044.   tsmall = valNum(*t);
  1045.  
  1046.   succeed;
  1047. }
  1048.  
  1049.  
  1050. #if O_DYNAMIC_STACKS
  1051. void
  1052. considerGarbageCollect(s)
  1053. Stack s;
  1054. { if ( s == (Stack) &stacks.global )
  1055.   { Word gsegb = (gc_status.segment ? gc_status.segment->mark.globaltop
  1056.                     : gBase);
  1057.     if ( s->max - (caddress)gsegb > (caddress)gsegb - s->base + gsmall )
  1058.     { DEBUG(1, printf("Global overflow: Posted garbage collect request\n"));
  1059.       gc_status.requested = TRUE;
  1060. #if O_PROFILE
  1061.       PROCEDURE_garbage_collect0->definition->profile_calls++;
  1062. #endif
  1063.     }
  1064.   }
  1065.  
  1066.   if ( s == (Stack) &stacks.trail )
  1067.   { TrailEntry tsegb = (gc_status.segment ? gc_status.segment->mark.trailtop
  1068.                       : tBase);
  1069.     if ( s->max - (caddress)tsegb > (caddress)tsegb - s->base + tsmall )
  1070.     { DEBUG(1, printf("Trail overflow: Posted garbage collect request\n"));
  1071.       gc_status.requested = TRUE;
  1072. #if O_PROFILE
  1073.       PROCEDURE_garbage_collect0->definition->profile_calls++;
  1074. #endif
  1075.     }
  1076.   }
  1077. }
  1078. #endif /* O_DYNAMIC_STACKS */
  1079.  
  1080. #if O_DEBUG
  1081. static bool
  1082. scan_global()
  1083. { Word current;
  1084.   int errors = 0;
  1085.   long cells = 0;
  1086.  
  1087.   for( current = gBase; current < gTop; current += (offset_cell(current)+1) )
  1088.   { cells++;
  1089.     if ( (Word)(*current) >= gBase && (Word)(*current) < gTop )
  1090.       if ( !isTerm(*current) )
  1091.         sysError("Pointer on global stack is not a term");
  1092.     if ( marked(current) || is_first(current) )
  1093.     { warning("Illegal cell in global stack (up) at 0x%lx (*= 0x%lx)", current, *current);
  1094.       if ( isAtom(*current) )
  1095.     warning("0x%lx is atom %s", current, stringAtom(*current));
  1096.       if ( isTerm(*current) )
  1097.     warning("0x%lx is term %s/%d", current,
  1098.                        stringAtom(functorTerm(*current)->name),
  1099.                        functorTerm(*current)->arity);
  1100.       if ( ++errors > 10 )
  1101.       { printf("...\n");
  1102.         break;
  1103.       }
  1104.     }
  1105.   }
  1106.  
  1107.   for( current = gTop - 1; current >= gBase; current-- )
  1108.   { cells --;
  1109.     current -= offset_cell(current);
  1110.     if ( marked(current) || is_first(current) )
  1111.     { warning("Illegal cell in global stack (down) at 0x%lx (*= 0x%lx)", current, *current);
  1112.       if ( ++errors > 10 )
  1113.       { printf("...\n");
  1114.         break;
  1115.       }
  1116.     }
  1117.   }
  1118.  
  1119.   if ( !errors && cells != 0 )
  1120.     sysError("Different count of cells upwards and downwards: %ld\n", cells);
  1121.  
  1122.   return errors == 0;
  1123. }
  1124. #endif
  1125.  
  1126.  
  1127. void
  1128. garbageCollect(fr)
  1129. LocalFrame fr;
  1130. { long tgar, ggar;
  1131.   real t = CpuTime();
  1132.  
  1133.   if ( gc_status.blocked )
  1134.     return;
  1135.   gc_status.requested = FALSE;
  1136.  
  1137.   gc_status.active = TRUE;
  1138.   DEBUG(0, printf("Garbage collect ... "));
  1139. #if O_DEBUG
  1140.   if ( !scan_global() )
  1141.     sysError("Stack not ok at gc entry");
  1142.  
  1143.   if ( check_table == NULL )
  1144.     check_table = newHTable(256);
  1145.   else
  1146.     clearHTable(check_table);
  1147. #endif
  1148.  
  1149.   needs_relocation  = 0;
  1150.   relocation_chains = 0;
  1151.   relocation_cells  = 0;
  1152.   relocated_cells   = 0;
  1153.   local_marked        = 0;
  1154.   relocation_refs   = 0;
  1155.   relocation_indirect = 0;
  1156.  
  1157.   STACKVERIFY( if ( gTop + 1 >= gMax ) outOf((Stack) &stacks.global) );
  1158.   setVar(*gTop);
  1159.   STACKVERIFY( if ( tTop + 1 >= tMax ) outOf((Stack) &stacks.trail) );
  1160.   tTop->address = NULL;
  1161.  
  1162.   mark_phase(fr);
  1163.   tgar = trailcells_deleted * sizeof(struct trail_entry);
  1164.   ggar = (gTop - gBase - total_marked) * sizeof(word);
  1165.   gc_status.trail_gained  += tgar;
  1166.   gc_status.global_gained += ggar;
  1167.   gc_status.collections++;
  1168.   gc_status.segment = fr;
  1169.  
  1170.   DEBUG(2, printf("Compacting trail ... "));
  1171.   compact_trail();
  1172.  
  1173.   collect_phase(fr);
  1174. #if O_DEBUG
  1175.   if ( !scan_global() )
  1176.     sysError("Stack not ok after gc; gTop = 0x%lx", gTop);
  1177. #endif
  1178.   DEBUG(0, printf("gained %ld+%ld bytes (now: %ld+%ld bytes)\n",
  1179.               ggar, tgar,
  1180.               (gTop-gBase)*sizeof(word),
  1181.               (tTop-tBase)*sizeof(word)));
  1182.   gc_status.time += CpuTime() - t;
  1183.  
  1184.   pl_trim_stacks();
  1185.   gc_status.active = FALSE;
  1186. }
  1187.  
  1188. word
  1189. pl_garbage_collect(d)
  1190. Word d;
  1191. { LocalFrame fr = environment_frame;
  1192. #if O_DEBUG
  1193.   int ol = status.debugLevel;
  1194.  
  1195.   if ( !isInteger(*d) )
  1196.     return warning("garbage_collect/1: instantiation fault");
  1197.   status.debugLevel = (int) valNum(*d);
  1198. #endif
  1199.   gc_status.blocked--;
  1200.   garbageCollect(fr);
  1201.   gc_status.blocked++;
  1202. #if O_DEBUG
  1203.   status.debugLevel = ol;
  1204. #endif
  1205.   succeed;
  1206. }
  1207.  
  1208. void
  1209. resetGC()
  1210. { gc_status.requested = FALSE;
  1211.   gc_status.blocked = 0;
  1212.   gc_status.segment = NULL;
  1213.   gc_status.collections = gc_status.global_gained = gc_status.trail_gained = 0;
  1214.   gc_status.time = 0.0;
  1215. }
  1216.  
  1217.         /********************************
  1218.         *      LOCKING FOREIGN DATA     *
  1219.         *********************************/
  1220.  
  1221. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1222. There are various types of foreign data that  are  of  interest  to  the
  1223. garbage  collector.  First of all the internal code both supports `word'
  1224. and `Word'.  Both can refer to the stacks.  Their value  is  non-garbage
  1225. and  should  be  relocated similar to local stack variables.  Second are
  1226. marks (Mark() and Undo()). Marks kept by foreign code should be  treated
  1227. equal to marks kept in the choicepoints on the local stack.
  1228. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1229.  
  1230. void
  1231. lockw(p)
  1232. Word p;
  1233. { Lock l = pTop++;
  1234.  
  1235.   verifyStack(lock);
  1236.   l->type  = L_WORD;
  1237.   l->value = (unsigned) p >> 2;
  1238. }
  1239.  
  1240. void
  1241. lockp(p)
  1242. Word *p;
  1243. { Lock l = pTop++;
  1244.  
  1245.   verifyStack(lock);
  1246.   l->type  = L_POINTER;
  1247.   l->value = (unsigned) p >> 2;
  1248. }
  1249.   
  1250. void
  1251. lockMark(m)
  1252. mark *m;
  1253. { Lock l = pTop++;
  1254.  
  1255.   verifyStack(lock);
  1256.   l->type  = L_MARK;
  1257.   l->value = (unsigned) m >> 2;
  1258. }
  1259.  
  1260. void
  1261. unlockw(p)
  1262. Word p;
  1263. { if ( ((--pTop)->value << 2) != (unsigned)p )
  1264.     sysError("Mismatch in lock()/unlock()\n");
  1265. }
  1266.  
  1267. void
  1268. unlockp(p)
  1269. Word *p;
  1270. { if ( ((--pTop)->value << 2) != (unsigned)p )
  1271.     sysError("Mismatch in lock()/unlock()\n");
  1272. }
  1273.  
  1274. void
  1275. unlockMark(m)
  1276. mark *m;
  1277. { if ( ((--pTop)->value << 2) != (unsigned)m )
  1278.     sysError("Mismatch in lock()/unlock()\n");
  1279. }
  1280.