1 /*  Part of SWI-Prolog
2 
3     Author:        Jan Wielemaker
4     E-mail:        J.Wielemaker@vu.nl
5     WWW:           http://www.swi-prolog.org
6     Copyright (c)  1985-2019, University of Amsterdam
7                               VU University Amsterdam
8 			      CWI, Amsterdam
9     All rights reserved.
10 
11     Redistribution and use in source and binary forms, with or without
12     modification, are permitted provided that the following conditions
13     are met:
14 
15     1. Redistributions of source code must retain the above copyright
16        notice, this list of conditions and the following disclaimer.
17 
18     2. Redistributions in binary form must reproduce the above copyright
19        notice, this list of conditions and the following disclaimer in
20        the documentation and/or other materials provided with the
21        distribution.
22 
23     THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24     "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25     LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26     FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27     COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28     INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29     BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30     LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31     CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32     LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33     ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34     POSSIBILITY OF SUCH DAMAGE.
35 */
36 
37 #ifdef SECURE_GC
38 #define O_DEBUG 1
39 #endif
40 #include "pl-incl.h"
41 #include "pl-comp.h"
42 #include "os/pl-cstack.h"
43 #include "pentium.h"
44 #include "pl-inline.h"
45 #include "pl-prof.h"
46 
47 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
48 This module is based on
49 
50     Karen Appleby, Mats Carlsson, Seif Haridi and Dan Sahlin
51     ``Garbage Collection for Prolog Based on WAM''
52     Communications of the ACM, June 1988, vol. 31, No. 6, pages 719-741.
53 
54 Garbage collection is invoked if the WAM  interpreter  is  at  the  call
55 port.   This  implies  the current environment has its arguments filled.
56 For the moment we assume the other  reachable  environments  are  filled
57 completely.   There  is  room  for some optimisations here.  But we will
58 exploit these later.
59 
60 The sole fact that the garbage collector can  only  be  invoked  if  the
61 machinery  is  in a well known phase of the execution is irritating, but
62 sofar I see no solutions around this, nor have had any indications  from
63 other  Prolog implementors or the literature that this was feasible.  As
64 a consequence however, we should start the garbage collector well before
65 the system runs out of memory.
66 
67 In theory, we could have the compiler calculating the maximum amount  of
68 global   stack   data  created  before  the  next  `save  point'.   This
69 unfortunately is not possible for the trail stack, which  also  benifits
70 from  a  garbage  collection pass.  Furthermore, there is the problem of
71 foreign code creating global stack data (=../2, name/2, read/1, etc.).
72 
73 
74 		  CONSEQUENCES FOR THE VIRTUAL MACHINE
75 
76 The virtual machine interpreter now should   ensure the stack frames are
77 in a predictable state. For the moment,   this  implies that all frames,
78 except for the current one (which only  has its arguments filled) should
79 be initialised fully. I'm not yet sure   whether we can't do better, but
80 this is simple and safe and  allows   us  to debug the garbage collector
81 first before starting on the optimisations.
82 
83 
84 		CONSEQUENCES FOR THE DATA REPRESENTATION
85 
86 The garbage collector needs two bits on each cell of `Prolog  data'.   I
87 decided  to  use the low order two bits for this.  The advantage of this
88 that pointers to word aligned data are not affected (at least on 32 bits
89 machines.  Unfortunately, you will have to use 4 bytes alignment  on  16
90 bits  machines  now  as  well).   This demand only costs us two bits for
91 integers, which are now shifted two bits to the left when stored on  the
92 stack.   The  normal  Prolog machinery expects the lower two bits of any
93 Prolog data object to be zero.  The  garbage  collection  part  must  be
94 carefull to strip of these two bits before operating on the data.
95 
96 Finally, for the compacting phase we should be able to scan  the  global
97 stack  both  upwards  and downwards while identifying the objects in it.
98 This implies reals are  now  packed  into  two  words  and  strings  are
99 surrounded by a word at the start and end, indicating their length.
100 
101 			      DEBUGGING
102 
103 Debugging a garbage collector is a difficult job.  Bugs --like  bugs  in
104 memory  allocation--  usually  cause  crashes  long  after  the  garbage
105 collection has finished.   To  simplify  debugging  a  large  number  of
106 actions  are  counted  during garbage collection.  At regular points the
107 consistency between these counts  is  verified.   This  causes  a  small
108 performance degradation, but for the moment is worth this I think.
109 
110 If the CHK_SECURE prolog_debug flag  is set  some  additional  expensive
111 consistency checks that need considerable amounts of memory and cpu time
112 are added. Garbage collection gets about 3-4 times as slow.
113 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
114 
115 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
116 call_residue_vars(:Goal,  -Vars)  should  avoid  that  the  attvars  are
117 reclaimed by GC. Unfortunately, mark_attvars() is broken because:
118 
119   - Seems there is something wrong calling mark_variable() directly on
120     the pointer.  This can be fixed, worst case by using a temporary
121     term reference.
122   - We also need to sweep.  There is no good place to do that.
123 
124 A solution would be to reference the  attvars from term references, just
125 like global variables. The problem is that we do not know how many there
126 are and computing that upfront is rather expensive.
127 
128 For now, we disable trying to rescue attvars from GC.
129 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
130 
131 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
132 Marking, testing marks and extracting values from GC masked words.
133 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
134 
135 #define GC_MASK		(MARK_MASK|FIRST_MASK)
136 #define VALUE_MASK	(~GC_MASK)
137 
138 #if O_DEBUG
139 char tmp[256];				/* for calling print_val(), etc. */
140 #define check_relocation(p) do_check_relocation(p, __FILE__, __LINE__ PASS_LD)
141 #define relocated_cell(p) do_relocated_cell(p PASS_LD)
142 #define recordMark(p) recordMark__LD(p PASS_LD)
143 static inline void
recordMark__LD(Word p ARG_LD)144 recordMark__LD(Word p ARG_LD)
145 { if ( DEBUGGING(CHK_SECURE) )
146   { if ( (char*)p < (char*)lBase )
147     { assert(onStack(global, p));
148       *LD->gc._mark_top++ = p;		/* = mark_top */
149     }
150   }
151 }
152 #else
153 #define recordMark(p)
154 #define needsRelocation(p) { needs_relocation++; }
155 #define relocated_cell(p)  { relocated_cells++; }
156 #define check_relocation(p)
157 #define markLocal(p) (local_marked++)
158 #define processLocal(p) (local_marked--)
159 #endif
160 
161 #define ldomark(p)	{ *(p) |= MARK_MASK; }
162 #define domark(p)	{ if ( is_marked(p) ) \
163 			    sysError("marked twice: %p (*= 0x%lx), gTop = %p", p, *(p), gTop); \
164 			  DEBUG(3, char b[64]; Sdprintf("\tdomarked(%p = %s)\n", p, print_val(*p, b))); \
165 			  *(p) |= MARK_MASK; \
166 			  total_marked++; \
167 			  recordMark(p); \
168 			}
169 #define unmark(p)	(*(p) &= ~MARK_MASK)
170 
171 #define mark_first(p)	(*(p) |= FIRST_MASK)
172 #define unmark_first(p)	(*(p) &= ~FIRST_MASK)
173 #define is_ref(w)	isRef(w)
174 
175 #define get_value(p)	(*(p) & VALUE_MASK)
176 #define set_value(p, w)	{ *(p) &= GC_MASK; *(p) |= w; }
177 #define val_ptr2(w, s)	((Word)((uintptr_t)valPtr2((w), (s)) & ~(uintptr_t)0x3))
178 #define val_ptr(w)	val_ptr2((w), storage(w))
179 
180 #define inShiftedArea(area, shift, ptr) \
181 	((char *)ptr >= (char *)LD->stacks.area.base + shift && \
182 	 (char *)ptr <  (char *)LD->stacks.area.max + shift )
183 #define topPointerOnStack(name, addr) \
184 	((char *)(addr) >= (char *)LD->stacks.name.base && \
185 	 (char *)(addr) <  (char *)LD->stacks.name.max)
186 
187 #define onGlobal(p)	onGlobalArea(p) /* onStack()? */
188 #define onLocal(p)	onStackArea(local, p)
189 #define onTrail(p)	topPointerOnStack(trail, p)
190 
191 #ifndef offset
192 #define offset(s, f) ((size_t)(&((struct s *)NULL)->f))
193 #endif
194 
195 #define ttag(x)		(((word)(x))&TAG_TRAILMASK)
196 
197 
198 		 /*******************************
199 		 *	     TYPES		*
200 		 *******************************/
201 
202 typedef struct vm_state
203 { LocalFrame	frame;			/* Current frame */
204   Choice	choice;			/* Last choicepoint */
205   Code		pc;			/* Current PC */
206   Code		pc_start_vmi;		/* PC at start of current VMI */
207   Word		argp;			/* Argument pointer */
208   Word		argp0;			/* Arg-pointer for nested term */
209   int		adepth;			/* FUNCTOR/POP nesting depth */
210   LocalFrame	lSave;			/* Saved local top */
211   LocalFrame	lNext;			/* Next environment for new_args */
212   int		save_argp;		/* Need to safe ARGP? */
213   int		in_body;		/* Current frame is executing a body */
214   int		new_args;		/* #new arguments */
215   int		uwrite_count;		/* #UWRITE marked ARGP cells */
216 } vm_state;
217 
218 
219 		 /*******************************
220 		 *     FUNCTION PROTOTYPES	*
221 		 *******************************/
222 
223 forwards void		mark_variable(Word ARG_LD);
224 static void		mark_local_variable(Word p ARG_LD);
225 forwards void		sweep_foreign(void);
226 static void		sweep_global_mark(Word *m ARG_LD);
227 forwards void		update_relocation_chain(Word, Word ARG_LD);
228 forwards void		into_relocation_chain(Word, int stg ARG_LD);
229 forwards void		alien_into_relocation_chain(void *addr,
230 						    int orgst, int stg
231 						    ARG_LD);
232 forwards void		compact_trail(void);
233 forwards void		sweep_mark(mark * ARG_LD);
234 forwards void		sweep_trail(void);
235 forwards bool		is_downward_ref(Word ARG_LD);
236 forwards bool		is_upward_ref(Word ARG_LD);
237 forwards void		compact_global(void);
238 static void		get_vmi_state(QueryFrame qf, vm_state *state);
239 static size_t		tight(Stack s ARG_LD);
240 
241 #if O_DEBUG
242 forwards int		cmp_address(const void *, const void *);
243 forwards void		do_check_relocation(Word, char *file, int line ARG_LD);
244 forwards void		needsRelocation(void *);
245 forwards void		check_mark(mark *m);
246 static int		check_marked(const char *s);
247 #endif
248 
249 		/********************************
250 		*           GLOBALS             *
251 		*********************************/
252 
253 #define	total_marked	   (LD->gc._total_marked)
254 #define	trailcells_deleted (LD->gc._trailcells_deleted)
255 #define	relocation_chains  (LD->gc._relocation_chains)
256 #define	relocation_cells   (LD->gc._relocation_cells)
257 #define	relocated_cells	   (LD->gc._relocated_cells)
258 #define	needs_relocation   (LD->gc._needs_relocation)
259 #define	local_marked	   (LD->gc._local_marked)
260 #define	marks_swept	   (LD->gc._marks_swept)
261 #define	marks_unswept	   (LD->gc._marks_unswept)
262 #define	alien_relocations  (LD->gc._alien_relocations)
263 #define local_frames	   (LD->gc._local_frames)
264 #define choice_count	   (LD->gc._choice_count)
265 #define start_map	   (LD->gc._start_map)
266 #if O_DEBUG
267 #define trailtops_marked   (LD->gc._trailtops_marked)
268 #define mark_base	   (LD->gc._mark_base)
269 #define mark_top	   (LD->gc._mark_top)
270 #define check_table	   (LD->gc._check_table)
271 #define local_table	   (LD->gc._local_table)
272 #define relocated_check	   (LD->gc._relocated_check)
273 #endif
274 
275 #undef LD
276 #define LD LOCAL_LD
277 
278 		/********************************
279 		*           DEBUGGING           *
280 		*********************************/
281 
282 #if defined(O_DEBUG) || defined(O_MAINTENANCE)
283 
284 char *
print_addr(Word adr,char * buf)285 print_addr(Word adr, char *buf)
286 { GET_LD
287   char *name;
288   Word base;
289   static char tmp[256];
290 
291   if ( !buf )
292     buf = tmp;
293 
294   if ( onGlobal(adr) )
295   { name = "global";
296     base = gBase;
297   } else if ( onLocal(adr) )
298   { name = "local";
299     base = (Word) lBase;
300   } else if ( onTrail(adr) )
301   { name = "trail";
302     base = (Word) tBase;
303   } else
304   { Ssprintf(buf, "%p", adr);
305     return buf;
306   }
307 
308   Ssprintf(buf, "%p=%s(%d)", adr, name, adr-base);
309   return buf;
310 }
311 
312 
313 char *
print_val(word val,char * buf)314 print_val(word val, char *buf)
315 { GET_LD
316   static const char *tag_name[] = { "var", "attvar", "float", "int", "atom",
317 				    "string", "term", "ref" };
318   static const char *stg_name[] = { "static", "global", "local", "reserved" };
319   static char tmp[256];
320   char *o;
321 
322   if ( !buf )
323     buf = tmp;
324   o = buf;
325 
326   if ( val & (MARK_MASK|FIRST_MASK) )
327   { *o++ = '[';
328     if ( val & MARK_MASK )
329       *o++ = 'M';
330     if ( val & FIRST_MASK )
331       *o++ = 'F';
332     *o++ = ']';
333     val &= ~(word)(MARK_MASK|FIRST_MASK);
334   }
335 
336   if ( isVar(val) )
337   { strcpy(o, "VAR");
338   } else if ( isTaggedInt(val) )
339   { Ssprintf(o, "int(%ld)", valInteger(val));
340   } else if ( isAtom(val) )
341   { const char *s = stringAtom(val);
342     if ( strlen(s) > 10 )
343     { strncpy(o, s, 10);
344       strcpy(o+10, "...");
345     } else
346     { strcpy(o, s);
347     }
348   } else if ( tagex(val) == (TAG_ATOM|STG_GLOBAL) )
349   { FunctorDef fd = valueFunctor(val);
350 
351     Ssprintf(o, "functor %s/%d", stringAtom(fd->name), fd->arity);
352   } else
353   { size_t offset = (val>>(LMASK_BITS-2))/sizeof(word);
354 
355     if ( storage(val) == STG_GLOBAL )
356       offset -= gBase - (Word)base_addresses[STG_GLOBAL];
357 
358     Ssprintf(o, "%s at %s(%ld)",
359 	     tag_name[tag(val)],
360 	     stg_name[storage(val) >> 3],
361 	     (long)offset);
362   }
363 
364   return buf;
365 }
366 
367 #endif /*O_DEBUG*/
368 
369 #if O_DEBUG
370 
371 #define RELOC_NEEDS   ((void*)1)
372 #define RELOC_CHAINED ((void*)2)
373 #define RELOC_UPDATED ((void*)3)
374 
375 #define LOCAL_MARKED ((void*)1)
376 #define LOCAL_UNMARKED ((void*)2)
377 
378 static void
needsRelocation(void * addr)379 needsRelocation(void *addr)
380 { GET_LD
381 
382   needs_relocation++;
383 
384   DEBUG(CHK_SECURE, updateHTable(check_table, addr, RELOC_NEEDS));
385 }
386 
387 
388 static void
do_check_relocation(Word addr,char * file,int line ARG_LD)389 do_check_relocation(Word addr, char *file, int line ARG_LD)
390 { if ( DEBUGGING(CHK_SECURE) )
391   { void *chk;
392 
393     if ( !(chk = lookupHTable(check_table, addr)) )
394     { char buf1[256];
395       char buf2[256];
396       sysError("%s:%d: Address %s (%s) was not supposed to be relocated",
397 	       file, line, print_addr(addr, buf1), print_val(*addr, buf2));
398       return;
399     }
400 
401     if ( chk != RELOC_NEEDS )
402     { sysError("%s:%d: Relocated twice: 0x%lx", file, line, addr);
403       return;
404     }
405 
406     updateHTable(check_table, addr, RELOC_CHAINED);
407   }
408 }
409 
410 
411 static void
do_relocated_cell(Word addr ARG_LD)412 do_relocated_cell(Word addr ARG_LD)
413 { if ( DEBUGGING(CHK_SECURE) )
414   { if ( relocated_check )		/* we cannot do this during the */
415     { void *chk;			/* final up-phase because the addresses */
416 					/* have already changed */
417       if ( !(chk = lookupHTable(check_table, addr)) )
418       { char buf1[64];
419 
420         sysError("Address %s was not supposed to be updated",
421 	         print_addr(addr, buf1));
422         return;
423       }
424 
425       if ( chk == RELOC_UPDATED )
426       { char buf1[64];
427 
428         sysError("%s: updated twice", print_addr(addr, buf1));
429         return;
430       }
431 
432       updateHTable(check_table, addr, RELOC_UPDATED);
433     }
434   }
435 
436   relocated_cells++;
437 }
438 
439 
440 static void
printNotRelocated()441 printNotRelocated()
442 { GET_LD
443   TableEnum e = newTableEnum(check_table);
444   Word addr;
445   void *chk;
446 
447   Sdprintf("Not relocated cells:\n");
448 
449   while( advanceTableEnum(e, (void**)&addr, (void**)&chk) )
450   { if ( chk == RELOC_CHAINED )
451     { char buf1[64];
452 
453       Sdprintf("\t%s\n", print_addr(addr, buf1));
454     }
455   }
456 
457   freeTableEnum(e);
458 }
459 
460 
461 static void
markLocal(Word addr)462 markLocal(Word addr)
463 { GET_LD
464 
465   local_marked++;
466 
467   DEBUG(CHK_SECURE,
468 	{ void *marked;
469 
470 	  if ( (marked = lookupHTable(local_table, addr)) )
471 	  { assert(marked == LOCAL_UNMARKED);
472 	  }
473 	  updateHTable(local_table, addr, LOCAL_MARKED);
474 	});
475 }
476 
477 
478 static void
processLocal(Word addr)479 processLocal(Word addr)
480 { GET_LD
481 
482   local_marked--;
483 
484   DEBUG(CHK_SECURE,
485 	{ void *marked;
486 
487 	  if ( (marked = lookupHTable(local_table, addr)) )
488 	  { assert(marked == LOCAL_MARKED);
489 	    updateHTable(local_table, addr, LOCAL_UNMARKED);
490 	  } else
491 	  { assert(0);
492 	  }
493 	});
494 }
495 
496 #endif /* O_DEBUG */
497 
498 		 /*******************************
499 		 *	      STATS		*
500 		 *******************************/
501 
502 #define STAT_NEXT_INDEX(i) ((i)+1 == GC_STAT_WINDOW_SIZE ? 0 : (i)+1)
503 #define STAT_PREV_INDEX(i) ((i) > 0 ? (i)-1 : (GC_STAT_WINDOW_SIZE-1))
504 
505 static double
gc_percentage(gc_stat * stat)506 gc_percentage(gc_stat *stat)
507 { return stat->gc_time == 0.0 ?
508 		0.0 :
509 		stat->gc_time/(stat->gc_time+stat->prolog_time);
510 }
511 
512 static void
gc_stat_aggregate(gc_stats * stats)513 gc_stat_aggregate(gc_stats *stats)
514 { gc_stat *this = &stats->aggr[stats->aggr_index];
515   int i;
516 
517   memset(this, 0, sizeof(*this));
518   for(i=0; i<GC_STAT_WINDOW_SIZE; i++)
519   { this->global_before += stats->last[i].global_before;
520     this->global_after  += stats->last[i].global_after;
521     this->trail_before  += stats->last[i].trail_before;
522     this->trail_after   += stats->last[i].trail_after;
523     this->local         += stats->last[i].local;
524     this->gc_time       += stats->last[i].gc_time;
525     this->prolog_time   += stats->last[i].prolog_time;
526     this->reason	+= stats->last[i].reason;
527   }
528 
529   this->global_before /= GC_STAT_WINDOW_SIZE;
530   this->global_after  /= GC_STAT_WINDOW_SIZE;
531   this->trail_before  /= GC_STAT_WINDOW_SIZE;
532   this->trail_after   /= GC_STAT_WINDOW_SIZE;
533   this->local         /= GC_STAT_WINDOW_SIZE;
534   this->gc_time       /= GC_STAT_WINDOW_SIZE;
535   this->prolog_time   /= GC_STAT_WINDOW_SIZE;
536 
537   stats->aggr_index = STAT_NEXT_INDEX(stats->aggr_index);
538 }
539 
540 static void
gc_stat_start(gc_stats * stats,unsigned int reason ARG_LD)541 gc_stat_start(gc_stats *stats, unsigned int reason ARG_LD)
542 { gc_stat *this = &stats->last[stats->last_index];
543   double cpu = ThreadCPUTime(LD, CPU_USER);
544 
545   if ( stats->last_index == 0 && this->global_before )
546     gc_stat_aggregate(stats);
547 
548   if ( !reason )
549     reason = stats->request;
550   stats->request = 0;
551 
552   this->reason        = reason;
553   this->global_before = usedStack(global);
554   this->trail_before  = usedStack(trail);
555   this->local	      = usedStack(local);
556   this->prolog_time   = cpu - stats->thread_cpu;
557   stats->thread_cpu   = cpu;
558 }
559 
560 static gc_stat *
gc_stat_end(gc_stats * stats ARG_LD)561 gc_stat_end(gc_stats *stats ARG_LD)
562 { gc_stat *this = &stats->last[stats->last_index];
563   double cpu = ThreadCPUTime(LD, CPU_USER);
564 
565   this->global_after  = usedStack(global);
566   this->trail_after   = usedStack(trail);
567   this->gc_time       = cpu - stats->thread_cpu;
568   stats->thread_cpu   = cpu;
569   stats->last_index   = STAT_NEXT_INDEX(stats->last_index);
570 
571   LD->stacks.global.gced_size = this->global_after;
572   LD->stacks.trail.gced_size  = this->trail_after;
573 
574   stats->totals.global_gained += this->global_before - this->global_after;
575   stats->totals.trail_gained  += this->trail_before  - this->trail_after;
576   stats->totals.time	      += this->gc_time;
577   stats->totals.collections++;
578 
579   if ( gc_percentage(this) > 0.2 )
580     PL_raise(SIG_TUNE_GC);
581 
582   return this;
583 }
584 
585 gc_stat *
last_gc_stats(gc_stats * stats)586 last_gc_stats(gc_stats *stats)
587 { return &stats->last[STAT_PREV_INDEX(stats->last_index)];
588 }
589 
590 /** '$gc_statistics'(-Stats)
591  *
592  * Stats = gc_stats(Recent, Aggregated, LastPrec, Last3, Last9)
593  */
594 
595 static double
gc_avg(gc_stats * stats)596 gc_avg(gc_stats *stats)
597 { int i;
598   double d = 0.0;
599 
600   for(i=0; i<GC_STAT_WINDOW_SIZE; i++)
601   { d += gc_percentage(&stats->aggr[i]);
602   }
603 
604   d /= (double)GC_STAT_WINDOW_SIZE;
605   return d;
606 }
607 
608 static int
unify_gc_reason(term_t t,gc_stat * stat ARG_LD)609 unify_gc_reason(term_t t, gc_stat *stat ARG_LD)
610 { int go = (stat->reason>> 0)&0xff;
611   int gr = (stat->reason>> 8)&0xff;
612   int to = (stat->reason>>16)&0xff;
613   int tr = (stat->reason>>24)&0xff;
614   int ex = (stat->reason>>32)&0xff;
615   int ur = (stat->reason>>36)&0xff;
616 
617   return PL_unify_term(t, PL_FUNCTOR, FUNCTOR_gc6,
618 		            PL_INT, go,
619 		            PL_INT, gr,
620 		            PL_INT, to,
621 		            PL_INT, tr,
622 		            PL_INT, ex,
623 		            PL_INT, ur);
624 }
625 
626 
627 static int
unify_gc_stats(term_t t,gc_stat * stats,int index ARG_LD)628 unify_gc_stats(term_t t, gc_stat *stats, int index ARG_LD)
629 { term_t tail = PL_copy_term_ref(t);
630   term_t head = PL_new_term_ref();
631   term_t rt   = PL_new_term_ref();
632   int i;
633 
634   for(i=0; i<GC_STAT_WINDOW_SIZE; i++)
635   { gc_stat *this;
636 
637     index = STAT_PREV_INDEX(index);
638     this = &stats[index];
639 
640     if ( this->global_before )
641     { if ( !PL_unify_list(tail, head, tail) ||
642 	   !PL_put_variable(rt) ||
643 	   !unify_gc_reason(rt, this PASS_LD) ||
644 	   !PL_unify_term(head,
645 			  PL_FUNCTOR, FUNCTOR_gc_stats8,
646 			    PL_TERM,   rt,
647 			    PL_INTPTR, this->global_before,
648 			    PL_INTPTR, this->global_after,
649 			    PL_INTPTR, this->trail_before,
650 			    PL_INTPTR, this->trail_after,
651 			    PL_INTPTR, this->local,
652 			    PL_FLOAT,  this->gc_time,
653 			    PL_FLOAT,  gc_percentage(this)) )
654 	return FALSE;
655     }
656   }
657 
658   return PL_unify_nil(tail);
659 }
660 
661 
662 static
663 PRED_IMPL("$gc_statistics", 5, gc_statistics, 0)
664 { PRED_LD
665   gc_stats *stats = &LD->gc.stats;
666   gc_stat  *last  = last_gc_stats(stats);
667   gc_stat  *aggr  = &stats->aggr[STAT_PREV_INDEX(stats->aggr_index)];
668 
669   return ( unify_gc_stats(A1, stats->last, stats->last_index PASS_LD) &&
670 	   unify_gc_stats(A2, stats->aggr, stats->aggr_index PASS_LD) &&
671 	   PL_unify_float(A3, gc_percentage(last)) &&
672 	   PL_unify_float(A4, gc_percentage(aggr)) &&
673 	   PL_unify_float(A5, gc_avg(stats))
674 	 );
675 }
676 
677 
678 		/********************************
679 		*          UTILITIES            *
680 		*********************************/
681 
682 QueryFrame
queryOfFrame(LocalFrame fr)683 queryOfFrame(LocalFrame fr)
684 { QueryFrame qf;
685 
686   assert(!fr->parent);
687 
688   qf = (QueryFrame)((char*)fr - offset(queryFrame, top_frame));
689   assert(qf->magic == QID_MAGIC);
690 
691   return qf;
692 }
693 
694 
695 static inline int
isGlobalRef(word w)696 isGlobalRef(word w)
697 { return storage(w) == STG_GLOBAL;
698 }
699 
700 
701 static inline size_t
offset_word(word m)702 offset_word(word m)
703 { size_t offset;
704 
705   if ( unlikely(storage(m) == STG_LOCAL) )
706     offset = wsizeofInd(m) + 1;
707   else
708     offset = 0;
709 
710   return offset;
711 }
712 
713 
714 static inline size_t
offset_cell(Word p)715 offset_cell(Word p)
716 { return offset_word(*p);
717 }
718 
719 
720 static inline word
makePtr(Word ptr,int tag ARG_LD)721 makePtr(Word ptr, int tag ARG_LD)
722 { int stg;
723 
724   if ( onGlobalArea(ptr) )
725     stg = STG_GLOBAL;
726   else if ( onStackArea(local, ptr) )
727     stg = STG_LOCAL;
728   else
729   { assert(onTrailArea(ptr));
730     stg = STG_TRAIL;
731   }
732 
733   return consPtr(ptr, tag|stg);
734 }
735 
736 
737 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
738 Clear the mask (FR_MARKED or FR_MARKED_PRED) flags left after traversing
739 all reachable frames.
740 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
741 
742 static QueryFrame
unmark_environments(PL_local_data_t * ld,LocalFrame fr,uintptr_t mask)743 unmark_environments(PL_local_data_t *ld, LocalFrame fr, uintptr_t mask)
744 { if ( fr == NULL )
745     return NULL;
746 
747   for(;;)
748   { if ( false(fr, mask) )
749       return NULL;
750     clear(fr, mask);
751     ld->gc._local_frames--;
752 
753     if ( fr->parent )
754       fr = fr->parent;
755     else				/* Prolog --> C --> Prolog calls */
756       return queryOfFrame(fr);
757   }
758 }
759 
760 
761 static void
unmark_choicepoints(PL_local_data_t * ld,Choice ch,uintptr_t mask)762 unmark_choicepoints(PL_local_data_t *ld, Choice ch, uintptr_t mask)
763 { for( ; ch; ch = ch->parent )
764   { ld->gc._choice_count--;
765     unmark_environments(ld, ch->frame, mask);
766   }
767 }
768 
769 
770 void
unmark_stacks(PL_local_data_t * ld,LocalFrame fr,Choice ch,uintptr_t mask)771 unmark_stacks(PL_local_data_t *ld, LocalFrame fr, Choice ch,
772 	      uintptr_t mask)
773 { QueryFrame qf;
774 
775   while(fr)
776   { qf = unmark_environments(ld, fr, mask);
777     assert(qf->magic == QID_MAGIC);
778     unmark_choicepoints(ld, ch, mask);
779     if ( qf->parent )
780     { QueryFrame pqf = qf->parent;
781 
782       if ( !(fr = pqf->registers.fr) )
783 	fr = qf->saved_environment;
784       ch = qf->saved_bfr;
785     } else
786       break;
787   }
788 }
789 
790 
791 		/********************************
792 		*            MARKING            *
793 		*********************************/
794 
795 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
796 void mark_variable(start)
797      Word start;
798 
799 After the marking phase has been completed, the following statements are
800 supposed to hold:
801 
802     - All non-garbage cells on the local- and global stack are
803       marked.
804     - `total_marked' equals the size of the global stack AFTER
805       compacting (e.i. the amount of non-garbage) in words.
806     - `needs_relocation' holds the total number of references from the
807       argument- and local variable fields of the local stack and the
808       internal global stack references that need be relocated. This
809       number is only used for consistency checking with the relocation
810       statistic obtained during the compacting phase.
811 
812 The marking algorithm forms a two-state machine. While going deeper into
813 the reference tree, the pointers are reversed  and the FIRST_MASK is set
814 to indicate the choice points created by   complex terms with arity > 1.
815 Also the actual mark bit is set on the   cells. If a leaf is reached the
816 process reverses, restoring the  old  pointers.   If  a  `first' mark is
817 reached we are either finished, or have reached a choice point, in which
818 case  the  alternative  is  the  cell   above  (structures  are  handled
819 last-argument-first).
820 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
821 
822 #define FORWARD		goto forward
823 #define BACKWARD	goto backward
824 
825 static void
mark_variable(Word start ARG_LD)826 mark_variable(Word start ARG_LD)
827 { Word current;				/* current cell examined */
828   word val;				/* old value of current cell */
829   Word next;				/* cell to be examined */
830 
831   DEBUG(MSG_GC_MARK_VAR,
832 	char b[64];
833 	Sdprintf("marking %p (=%s)\n", start, print_val(*start, b)));
834 
835   if ( is_marked(start) )
836     sysError("Attempt to mark twice");
837 
838   if ( onStackArea(local, start) )
839   { markLocal(start);
840     total_marked--;			/* do not count local stack cell */
841   }
842   current = start;
843   mark_first(current);
844   val = get_value(current);
845   FORWARD;
846 
847 forward:				/* Go into the tree */
848   if ( is_marked(current) )		/* have been here */
849     BACKWARD;
850   domark(current);
851 
852   switch(tag(val))
853   { case TAG_REFERENCE:
854     { next = unRef(val);		/* address pointing to */
855       DEBUG(CHK_SECURE, assert(onStack(global, next)));
856       needsRelocation(current);
857       if ( is_first(next) )		/* ref to choice point. we will */
858         BACKWARD;			/* get there some day anyway */
859       val  = get_value(next);		/* invariant */
860       set_value(next, makeRef(current));/* create backwards pointer */
861       DEBUG(MSG_GC_MARK_VAR_WALK,
862 	    Sdprintf("Marking REF from %p to %p\n", current, next));
863       current = next;			/* invariant */
864       FORWARD;
865     }
866 #ifdef O_ATTVAR
867     case TAG_ATTVAR:
868     { DEBUG(CHK_SECURE, assert(storage(val) == STG_GLOBAL));
869       next = valPtr2(val, STG_GLOBAL);
870       DEBUG(CHK_SECURE, assert(onStack(global, next)));
871       needsRelocation(current);
872       if ( is_marked(next) )
873 	BACKWARD;			/* term has already been marked */
874       val  = get_value(next);		/* invariant */
875 					/* backwards pointer */
876       set_value(next, makePtr(current, TAG_ATTVAR PASS_LD));
877       DEBUG(MSG_GC_MARK_VAR_WALK,
878 	    Sdprintf("Marking ATTVAR from %p to %p\n", current, next));
879       current = next;			/* invariant */
880       FORWARD;
881     }
882 #endif
883     case TAG_COMPOUND:
884     { int args;
885 
886       DEBUG(CHK_SECURE, assert(storage(val) == STG_GLOBAL));
887       next = valPtr2(val, STG_GLOBAL);
888       DEBUG(CHK_SECURE, assert(onStack(global, next)));
889       needsRelocation(current);
890       if ( is_marked(next) )
891 	BACKWARD;			/* term has already been marked */
892       args = arityFunctor(((Functor)next)->definition);
893       DEBUG(MSG_GC_MARK_VAR_WALK,
894 	    Sdprintf("Marking TERM %s/%d at %p\n",
895 		     stringAtom(nameFunctor(((Functor)next)->definition)),
896 		     args, next));
897       domark(next);
898       if ( args == 0 )
899 	BACKWARD;
900       for( next += 2; args > 1; args--, next++ )
901       { DEBUG(CHK_SECURE, assert(!is_first(next)));
902 	mark_first(next);
903       }
904       next--;				/* last cell of term */
905       val = get_value(next);		/* invariant */
906 					/* backwards pointer (NO ref!) */
907       set_value(next, makePtr(current, TAG_COMPOUND PASS_LD));
908       current = next;
909       FORWARD;
910     }
911     case TAG_INTEGER:
912       if ( storage(val) == STG_INLINE )
913 	BACKWARD;
914     case TAG_STRING:
915     case TAG_FLOAT:			/* indirects */
916     { next = valPtr2(val, STG_GLOBAL);
917 
918       DEBUG(CHK_SECURE, assert(storage(val) == STG_GLOBAL));
919       DEBUG(CHK_SECURE, assert(onStack(global, next)));
920       needsRelocation(current);
921       if ( is_marked(next) )		/* can be referenced from multiple */
922         BACKWARD;			/* places */
923       domark(next);
924       DEBUG(MSG_GC_MARK_VAR_WALK,
925 	    Sdprintf("Marked indirect data type, size = %ld\n",
926 		     offset_cell(next) + 1));
927       total_marked += offset_cell(next);
928     }
929   }
930   BACKWARD;
931 
932 backward:				/* reversing backwards */
933   while( !is_first(current) )
934   { word w = get_value(current);
935     int t = (int)tag(w);
936 
937     assert(onStack(global, current));
938 
939     next = valPtr(w);
940     set_value(current, val);
941     switch(t)
942     { case TAG_REFERENCE:
943 	val = makeRef(current);
944         break;
945       case TAG_COMPOUND:
946 	val = makePtr(current-1, t PASS_LD);
947         break;
948       case TAG_ATTVAR:
949 	val = makePtr(current, t PASS_LD);
950         break;
951       default:
952 	assert(0);
953     }
954     current= next;
955   }
956 
957   unmark_first(current);
958   if ( current == start )
959     return;
960 
961   DEBUG(CHK_SECURE, assert(onStack(global, current)));
962   { word tmp;
963 
964     tmp = get_value(current);
965     set_value(current, val);		/* restore old value */
966     current--;
967     val = get_value(current);		/* invariant */
968     set_value(current, tmp);
969     FORWARD;
970   }
971 }
972 
973 
974 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
975 References from foreign code.
976 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
977 
978 static void
mark_term_refs()979 mark_term_refs()
980 { GET_LD
981   FliFrame fr = fli_context;
982 #if O_DEBUG
983   long gmarked = 0;
984   long lmarked = 0;
985 #endif
986 
987   DEBUG(MSG_GC_MARK_TERMREF, Sdprintf("Marking term references ...\n"));
988 
989   for( ; fr; fr = fr->parent )
990   { Word sp = refFliP(fr, 0);
991     int n = fr->size;
992 
993     DEBUG(MSG_GC_MARK_TERMREF,
994 	  Sdprintf("Marking foreign frame %ld (size=%d)\n",
995 		   (Word)fr-(Word)lBase, n));
996 
997     assert(fr->magic == FLI_MAGIC);
998     for( ; n-- > 0; sp++ )
999     { if ( !is_marked(sp) )
1000       { if ( isGlobalRef(*sp) )
1001 	{ DEBUG(MSG_GC_MARK_TERMREF, gmarked++);
1002 	  mark_variable(sp PASS_LD);
1003 	} else
1004 	{ DEBUG(MSG_GC_MARK_TERMREF, lmarked++);
1005 	  mark_local_variable(sp PASS_LD);
1006 	}
1007       }
1008     }
1009 
1010     DEBUG(CHK_SECURE, check_marked("After marking foreign frame"));
1011   }
1012 
1013   DEBUG(MSG_GC_MARK_TERMREF,
1014 	Sdprintf("Marked %ld global and %ld local term references\n",
1015 		 gmarked, lmarked));
1016 }
1017 
1018 
1019 static void
save_grefs(ARG1_LD)1020 save_grefs(ARG1_LD)
1021 {
1022 #ifdef O_ATTVAR
1023   if ( LD->attvar.attvars )
1024   { *valTermRef(LD->attvar.gc_attvars) = makeRefG(LD->attvar.attvars);
1025   }
1026 #endif
1027 }
1028 
1029 static void
restore_grefs(ARG1_LD)1030 restore_grefs(ARG1_LD)
1031 {
1032 #ifdef O_ATTVAR
1033   if ( LD->attvar.attvars )
1034   { LD->attvar.attvars = unRef(*valTermRef(LD->attvar.gc_attvars));
1035     setVar(*valTermRef(LD->attvar.gc_attvars));
1036   }
1037 #endif
1038 }
1039 
1040 
1041 #ifdef O_GVAR
1042 
1043 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1044 Dealing  with  nb_setval/2  and   nb_getval/2  non-backtrackable  global
1045 variables as defined  in  pl-gvar.c.  We   cannot  mark  and  sweep  the
1046 hash-table itself as the  reversed   pointers  cannot  address arbitrary
1047 addresses returned by allocHeapOrHalt(). Therefore we   turn all references to
1048 the  global  stack  into  term-references  and  rely  on  the  available
1049 mark-and-sweep for foreign references.
1050 
1051 If none of the global  variable  refers   to  the  global stack we could
1052 `unfreeze' the global stack, except  we   may  have used nb_setarg/3. We
1053 could enhance on this by introducing  a   `melt-bar'  set  to the lowest
1054 location which we assigned using nb_setarg/3.   If backtracking takes us
1055 before  that  point  we  safely  know  there  are  no  terms  left  with
1056 nb_setarg/3  assignments.  As  the  merged   backtrackable  global  vars
1057 implementation also causes freezing of the stacks, it is uncertain
1058 whether there is much to gain with this approach.
1059 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1060 
1061 static fid_t
gvars_to_term_refs(Word ** saved_bar_at)1062 gvars_to_term_refs(Word **saved_bar_at)
1063 { GET_LD
1064   fid_t fid = PL_open_foreign_frame();
1065 
1066   if ( LD->gvar.nb_vars && LD->gvar.grefs > 0 )
1067   { TableEnum e = newTableEnum(LD->gvar.nb_vars);
1068     int found = 0;
1069     void *v;
1070 
1071     while( advanceTableEnum(e, NULL, &v) )
1072     { word w = (word)v;
1073 
1074       if ( isGlobalRef(w) )
1075       { term_t t = PL_new_term_ref_noshift();
1076 
1077 	assert(t);
1078 	*valTermRef(t) = w;
1079 	found++;
1080       }
1081     }
1082 
1083     freeTableEnum(e);
1084     assert(LD->gvar.grefs == found);
1085 
1086     DEBUG(MSG_GC_MARK_GVAR,
1087 	  Sdprintf("Found %d global vars on global stack. "
1088 		   "stored in frame %p\n", found, fli_context));
1089   }
1090 
1091   if ( LD->frozen_bar )
1092   { Word *sb;
1093 
1094     assert((Word)lTop + 1 <= (Word)lMax);
1095     sb = (Word*)lTop;
1096     lTop = (LocalFrame)(sb+1);
1097     *sb = LD->frozen_bar;
1098     *saved_bar_at = sb;
1099   } else
1100   { *saved_bar_at = NULL;
1101   }
1102 
1103   return fid;
1104 }
1105 
1106 
1107 static void
term_refs_to_gvars(fid_t fid,Word * saved_bar_at)1108 term_refs_to_gvars(fid_t fid, Word *saved_bar_at)
1109 { GET_LD
1110 
1111   if ( saved_bar_at )
1112   { assert((void *)(saved_bar_at+1) == (void*)lTop);
1113     LD->frozen_bar = valPtr2((word)*saved_bar_at, STG_GLOBAL);
1114 
1115     assert(onStack(global, LD->frozen_bar) || LD->frozen_bar == gTop);
1116     lTop = (LocalFrame) saved_bar_at;
1117   }
1118 
1119   if ( LD->gvar.grefs > 0 )
1120   { FliFrame fr = (FliFrame) valTermRef(fid);
1121     Word fp = (Word)(fr+1);
1122     TableEnum e = newTableEnum(LD->gvar.nb_vars);
1123     atom_t name;
1124     word p;
1125     int found = 0;
1126 
1127     while( advanceTableEnum(e, (void**)&name, (void**)&p) )
1128     { if ( isGlobalRef(p) )
1129       { p = *fp++;
1130 	updateHTable(e->table, (void*)name, (void*)p);
1131 	found++;
1132       }
1133     }
1134     assert(found == fr->size);
1135 
1136     freeTableEnum(e);
1137   }
1138 
1139   PL_close_foreign_frame(fid);
1140 }
1141 
1142 #else /*O_GVAR*/
1143 
1144 #define gvars_to_term_refs() 0
1145 #define term_refs_to_gvars(f) (void)0
1146 
1147 #endif /*O_GVAR*/
1148 
1149 #define UWRITE 0x1
1150 #define LARGP  0x2
1151 
1152 static fid_t
argument_stack_to_term_refs(vm_state * state)1153 argument_stack_to_term_refs(vm_state *state)
1154 { if ( state->save_argp )
1155   { GET_LD
1156     fid_t fid = PL_open_foreign_frame();
1157     Word *ap;
1158 
1159     pushArgumentStack(LD->query->registers.argp);
1160     assert(LARGP != TAG_ATTVAR && LARGP != TAG_REFERENCE);
1161 
1162     state->uwrite_count = 0;
1163     for(ap=aBase; ap<aTop; ap++)
1164     { Word adr = *ap;
1165 
1166       if ( onGlobal(adr) )
1167       { term_t t = PL_new_term_ref_noshift();
1168 
1169 	if ( (word)adr & UWRITE )
1170 	{ adr = (Word)((word)adr & ~UWRITE);
1171 	  *valTermRef(t) = consPtr(adr, STG_GLOBAL|TAG_ATTVAR);
1172 	  state->uwrite_count++;
1173 	} else
1174 	{ *valTermRef(t) = consPtr(adr, STG_GLOBAL|TAG_REFERENCE);
1175 	}
1176 	DEBUG(CHK_SECURE, checkData(adr));
1177       } else
1178       { assert(adr >= (Word)lBase);
1179 	*ap = (Word)((word)adr | LARGP);
1180       }
1181     }
1182 
1183     return fid;
1184   }
1185 
1186   return 0;
1187 }
1188 
1189 
1190 static void
term_refs_to_argument_stack(vm_state * state,fid_t fid)1191 term_refs_to_argument_stack(vm_state *state, fid_t fid)
1192 { if ( fid )
1193   { GET_LD
1194     FliFrame fr = (FliFrame) valTermRef(fid);
1195     Word fp = (Word)(fr+1);
1196     Word *ap;
1197     int uwc = 0;
1198 
1199     for(ap=aBase; ap<aTop; ap++)
1200     { Word adr = *ap;
1201 
1202       if ( (word)adr & LARGP )
1203       { *ap = (Word)((word)adr & ~LARGP);
1204       } else
1205       { word w = *fp++;
1206 	word mask = (tag(w) == TAG_ATTVAR ? UWRITE : 0);
1207 
1208 	if ( mask )
1209 	  uwc++;
1210 	*ap = (Word)((word)valPtr(w)|mask);
1211       }
1212     }
1213     assert(fp == (Word)(fr+1) + fr->size);
1214     assert(uwc == state->uwrite_count);
1215 
1216     DEBUG(CHK_SECURE,
1217 	  { if ( onStackArea(local, LD->query->registers.argp) )
1218 	      assert(LD->query->registers.argp == aTop[-1]);
1219 	  });
1220 
1221     LD->query->registers.argp = *--aTop;
1222     PL_close_foreign_frame(fid);
1223   }
1224 }
1225 
1226 
1227 #ifdef O_CALL_RESIDUE
1228 static size_t
count_need_protection_attvars(ARG1_LD)1229 count_need_protection_attvars(ARG1_LD)
1230 { Word p, next;
1231   size_t attvars = 0;
1232 
1233   for(p=LD->attvar.attvars; p; p = next)
1234   { Word avp = p+1;
1235 
1236     next = isRef(*p) ? unRef(*p) : NULL;
1237     if ( isAttVar(*avp) )
1238       attvars++;
1239   }
1240 
1241   return attvars;
1242 }
1243 
1244 static fid_t
link_attvars(ARG1_LD)1245 link_attvars(ARG1_LD)
1246 { if ( LD->attvar.call_residue_vars_count &&
1247        LD->attvar.attvars )
1248   { fid_t fid = PL_open_foreign_frame();
1249     Word p, next;
1250 
1251     for(p=LD->attvar.attvars; p; p = next)
1252     { Word avp = p+1;
1253 
1254       next = isRef(*p) ? unRef(*p) : NULL;
1255       if ( isAttVar(*avp) )
1256       { term_t t = PL_new_term_ref_noshift();
1257 
1258 	assert(t);
1259 	*valTermRef(t) = makeRefG(avp);
1260       }
1261     }
1262 
1263     return fid;
1264   } else
1265     return 0;
1266 }
1267 
1268 static void
restore_attvars(fid_t attvars ARG_LD)1269 restore_attvars(fid_t attvars ARG_LD)
1270 { if ( attvars )
1271     PL_close_foreign_frame(attvars);
1272 }
1273 
1274 
1275 #endif /*O_CALL_RESIDUE*/
1276 
1277 
1278 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1279 clearUninitialisedVarsFrame(LocalFrame fr, Code PC);
1280 
1281 Assuming the clause associated will resume   execution  at PC, determine
1282 the variables that are not yet initialised and set them to be variables.
1283 This  avoids  the  garbage  collector    considering  the  uninitialised
1284 variables.
1285 
1286 [Q] wouldn't it be better to track  the variables that *are* initialised
1287 and consider the others to be not?  Might   take more time, but might be
1288 more reliable and simpler.
1289 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1290 
1291 void
clearUninitialisedVarsFrame(LocalFrame fr,Code PC)1292 clearUninitialisedVarsFrame(LocalFrame fr, Code PC)
1293 { if ( PC != NULL )
1294   { code c;
1295 
1296     for( ; ; PC = stepPC(PC))
1297     { c = fetchop(PC);
1298 
1299     again:
1300       switch( c )
1301       { case I_EXIT:			/* terminate code list */
1302 	case I_EXITFACT:
1303 	case I_EXITCATCH:
1304 	case I_EXITRESET:
1305 	case I_EXITQUERY:
1306 	case I_FEXITDET:
1307 	case I_FEXITNDET:
1308 	case I_FREDO:
1309 	case S_TRUSTME:
1310 	case S_LIST:
1311 	  return;
1312 
1313 	case C_JMP:			/* jumps */
1314 	  PC += (int)PC[1]+2;
1315 	  c = fetchop(PC);
1316 	  goto again;
1317 
1318 	case H_FIRSTVAR:		/* Firstvar assignments */
1319 	case B_FIRSTVAR:
1320 	case B_ARGFIRSTVAR:
1321 	case A_FIRSTVAR_IS:
1322 	case B_UNIFY_FIRSTVAR:
1323 	case C_VAR:
1324 	  DEBUG(CHK_SECURE,
1325 		{ if ( varFrameP(fr, PC[1]) <
1326 		       argFrameP(fr, fr->predicate->functor->arity) )
1327 		    sysError("Reset instruction on argument");
1328 		  /*assert(varFrame(fr, PC[1]) != QID_MAGIC); is possible */
1329 		});
1330 	  setVar(varFrame(fr, PC[1]));
1331 	  break;
1332        case C_VAR_N:
1333        { size_t var = PC[1];
1334 	 size_t count = PC[2];
1335 
1336 	 while(count--)
1337 	 { setVar(varFrame(fr, var));
1338 	   var++;
1339 	 }
1340 	 break;
1341        }
1342        case H_LIST_FF:
1343        case B_UNIFY_FF:
1344           setVar(varFrame(fr, PC[1]));
1345           setVar(varFrame(fr, PC[2]));
1346           break;
1347        case B_UNIFY_FV:
1348        case B_UNIFY_VF:
1349        case B_UNIFY_FC:
1350        case A_ADD_FC:
1351          setVar(varFrame(fr, PC[1]));
1352          break;
1353       }
1354     }
1355   }
1356 }
1357 
1358 
1359 static inline int
slotsInFrame(LocalFrame fr,Code PC)1360 slotsInFrame(LocalFrame fr, Code PC)
1361 { Definition def = fr->predicate;
1362 
1363   if ( !PC || true(def, P_FOREIGN) || !fr->clause )
1364     return def->functor->arity;
1365 
1366   return fr->clause->value.clause->prolog_vars;
1367 }
1368 
1369 
1370 void
clearLocalVariablesFrame(LocalFrame fr)1371 clearLocalVariablesFrame(LocalFrame fr)
1372 { if ( fr->clause )
1373   { Definition def = fr->predicate;
1374     int i     = def->functor->arity;
1375     int slots = fr->clause->value.clause->prolog_vars;
1376     Word sp = argFrameP(fr, i);
1377 
1378     for( ; i<slots; i++, sp++)
1379       setVar(*sp);
1380   }
1381 }
1382 
1383 
1384 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1385 If multiple TrailAssignment() calls happen on  the same address within a
1386 choicepoint we only need to keep the  first. Therefore we scan the trail
1387 for this choicepoint from the mark to the  top and mark (using the FIRST
1388 mark) the (global stack) addresses trailed. If we find one marked we can
1389 delete the trail entry. To  avoid  a   second  scan  we store the marked
1390 addresses on the argument stack.
1391 
1392 Note that this additional scan of a section   of the trail stack is only
1393 required if there are  at  least   two  trailed  assignments  within the
1394 trail-ranged described by the choicepoint.
1395 
1396 As far as I can  see  the  only   first-marks  in  use  at this time are
1397 references to the trail-stack and we use   the first marks on the global
1398 stack.
1399 
1400 Older versions used the argument stack. We   now use the segmented cycle
1401 stack to avoid allocation issues on the argument stack.
1402 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1403 
1404 #if O_DESTRUCTIVE_ASSIGNMENT
1405 static inline void
push_marked(Word p ARG_LD)1406 push_marked(Word p ARG_LD)
1407 { if ( !pushSegStack(&LD->cycle.vstack, p, Word) )
1408     outOfCore();
1409 }
1410 
1411 
1412 static void
popall_marked(ARG1_LD)1413 popall_marked(ARG1_LD)
1414 { Word p;
1415 
1416   while( popSegStack(&LD->cycle.vstack, &p, Word) )
1417   { unmark_first(p);
1418   }
1419 }
1420 
1421 
1422 static void
mergeTrailedAssignments(GCTrailEntry top,GCTrailEntry mark,int assignments ARG_LD)1423 mergeTrailedAssignments(GCTrailEntry top, GCTrailEntry mark,
1424 			int assignments ARG_LD)
1425 { GCTrailEntry te;
1426   LD->cycle.vstack.unit_size = sizeof(Word);
1427 
1428   DEBUG(MSG_GC_ASSIGNMENTS,
1429 	Sdprintf("Scanning %d trailed assignments\n", assignments));
1430 
1431   for(te=mark; te <= top; te++)
1432   { Word p = val_ptr(te->address);
1433 
1434     if ( ttag(te[1].address) == TAG_TRAILVAL )
1435     { assignments--;
1436       if ( is_first(p) )
1437       {	DEBUG(MSG_GC_ASSIGNMENTS_MERGE,
1438 	      Sdprintf("Delete duplicate trailed assignment at %p\n", p));
1439 	te->address = 0;
1440 	te[1].address = 0;
1441 	trailcells_deleted += 2;
1442       } else
1443       { mark_first(p);
1444 	push_marked(p PASS_LD);
1445       }
1446     } else
1447     { if ( is_first(p) )
1448       { te->address = 0;
1449 	trailcells_deleted++;
1450       }
1451     }
1452   }
1453 
1454   popall_marked(PASS_LD1);
1455   assert(assignments == 0);
1456 }
1457 #endif
1458 
1459 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1460 Mark the choicepoints. This function walks   along the environments that
1461 can be reached from  the  choice-points.   In  addition,  it deletes all
1462 trail-references  that  will   be   overruled    by   the   choice-point
1463 stack-reference anyway.
1464 
1465 When using setarg/3 (O_DESTRUCTIVE_ASSIGNMENT),  destructive assignments
1466 are stored on the trail-stack as  two   entries.  The first entry is the
1467 normal trail-pointer, while the  second   is  flagged  with TAG_TRAILVAL
1468 (0x1). When undoing, the tail is scanned backwards and if a tagged value
1469 is encountered, this value is restored  at   the  location  of the first
1470 trail-cell.
1471 
1472 If the trail cell  has  become  garbage,   we  can  destroy  both cells,
1473 otherwise we must mark the value.
1474 
1475 Early reset of trailed  assignments  is   another  issue.  If  a trailed
1476 location has not yet been  marked  it   can  only  be accessed by frames
1477 *after* the undo to this choicepoint took   place.  Hence, we can do the
1478 undo now and remove  the  cell   from  the  trailcell, saving trailstack
1479 space. For a trailed assignment this means   we should restore the value
1480 with the trailed value. Note however that  the trailed value has already
1481 been marked. We however can remove  this   mark  as it will be re-marked
1482 should it be accessible and otherwise it really is garbage.
1483 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1484 
1485 static GCTrailEntry
early_reset_vars(mark * m,Word top,GCTrailEntry te ARG_LD)1486 early_reset_vars(mark *m, Word top, GCTrailEntry te ARG_LD)
1487 { GCTrailEntry tm = (GCTrailEntry)m->trailtop;
1488   GCTrailEntry te0 = te;
1489   int assignments = 0;
1490   Word gKeep = (LD->frozen_bar > m->globaltop ? LD->frozen_bar : m->globaltop);
1491 
1492   for( ; te >= tm; te-- )		/* early reset of vars */
1493   {
1494 #if O_DESTRUCTIVE_ASSIGNMENT
1495     if ( isTrailVal(te->address) )
1496     { Word tard = val_ptr(te[-1].address);
1497 
1498       if ( tard >= top || (tard >= gKeep && tard < gMax) )
1499       { te->address = 0;
1500 	te--;
1501 	te->address = 0;
1502 	trailcells_deleted += 2;
1503       } else if ( is_marked(tard) )
1504       { Word gp = val_ptr(te->address);
1505 
1506 	assert(onGlobal(gp));
1507 	assert(!is_first(gp));
1508 	if ( !is_marked(gp) )
1509 	{ DEBUG(MSG_GC_ASSIGNMENTS_MARK,
1510 		char b1[64]; char b2[64]; char b3[64];
1511 		Sdprintf("Marking assignment at %s (%s --> %s)\n",
1512 			 print_addr(tard, b1),
1513 			 print_val(*gp, b2),
1514 			 print_val(*tard, b3)));
1515 
1516 	  mark_variable(gp PASS_LD);
1517 	  assert(is_marked(gp));
1518 	}
1519 
1520 	assignments++;
1521 	te--;
1522       } else
1523       { Word gp = val_ptr(te->address);
1524 
1525 	DEBUG(MSG_GC_RESET,
1526 	      char b1[64]; char b2[64]; char b3[64];
1527 	      Sdprintf("Early reset of assignment at %s (%s --> %s)\n",
1528 		       print_addr(tard, b1),
1529 		       print_val(*tard, b2),
1530 		       print_val(*gp, b3)));
1531 
1532 	assert(onGlobal(gp));
1533 	*tard = *gp;
1534 	unmark(tard);
1535 
1536 	te->address = 0;
1537 	te--;
1538 	te->address = 0;
1539 	trailcells_deleted += 2;
1540       }
1541     } else
1542 #endif
1543     { Word tard = val_ptr(te->address);
1544 
1545       if ( tard >= top )		/* above local stack */
1546       { DEBUG(CHK_SECURE, assert(ttag(te[1].address) != TAG_TRAILVAL));
1547 	te->address = 0;
1548 	trailcells_deleted++;
1549       } else if ( tard > gKeep && tard < gMax )
1550       { te->address = 0;
1551 	trailcells_deleted++;
1552       } else if ( !is_marked(tard) )
1553       { DEBUG(MSG_GC_RESET,
1554 	      char b1[64]; char b2[64];
1555 	      Sdprintf("Early reset at %s (%s)\n",
1556 		       print_addr(tard, b1), print_val(*tard, b2)));
1557 	setVar(*tard);
1558 	te->address = 0;
1559 	trailcells_deleted++;
1560       }
1561     }
1562   }
1563 
1564 #if O_DESTRUCTIVE_ASSIGNMENT
1565   if ( assignments >= 1 )
1566     mergeTrailedAssignments(te0, tm, assignments PASS_LD);
1567 #endif
1568 
1569   return te;
1570 }
1571 
1572 
1573 static GCTrailEntry
mark_foreign_frame(FliFrame fr,GCTrailEntry te ARG_LD)1574 mark_foreign_frame(FliFrame fr, GCTrailEntry te ARG_LD)
1575 { DEBUG(CHK_SECURE, assert(fr->magic == FLI_MAGIC));
1576 
1577   if ( isRealMark(fr->mark) )
1578   { te = early_reset_vars(&fr->mark, (Word)fr, te PASS_LD);
1579 
1580     DEBUG(MSG_GC_MARK_FOREIGN, Sdprintf("Marking foreign frame %p\n", fr));
1581     needsRelocation(&fr->mark.trailtop);
1582     check_relocation((Word)&fr->mark.trailtop);
1583     DEBUG(CHK_SECURE, assert(isRealMark(fr->mark)));
1584     alien_into_relocation_chain(&fr->mark.trailtop,
1585 				STG_TRAIL, STG_LOCAL PASS_LD);
1586 
1587   }
1588 
1589   return te;
1590 }
1591 
1592 
1593 #define MARK_ALT_CLAUSES 1		/* also walk and mark alternate clauses */
1594 
1595 		 /*******************************
1596 		 *	     MARK STACKS	*
1597 		 *******************************/
1598 
1599 typedef struct mark_state
1600 { vm_state     *vm_state;		/* Virtual machine locations */
1601   FliFrame	flictx;			/* foreign context for early reset */
1602   GCTrailEntry	reset_entry;		/* Walk trail stack for early reset */
1603 } mark_state;
1604 
1605 
1606 typedef struct walk_state
1607 { LocalFrame frame;			/* processing node */
1608   int flags;				/* general flags */
1609   Code c0;				/* start of code list */
1610   Word envtop;				/* just above environment */
1611   int unmarked;				/* left when marking alt clauses */
1612   bit_vector *active;			/* When marking active */
1613   bit_vector *clear;			/* When marking active */
1614 #ifdef MARK_ALT_CLAUSES
1615   Word ARGP;				/* head unify instructions */
1616   int  adepth;				/* ARGP nesting */
1617 #endif
1618 } walk_state;
1619 
1620 #define GCM_CLEAR	0x1		/* Clear uninitialised data */
1621 #define GCM_ALTCLAUSE	0x2		/* Marking alternative clauses */
1622 #define GCM_ACTIVE	0x4		/* Mark active environment */
1623 #define GCM_CHOICE	0x8		/* Mark active choicepoints */
1624 
1625 #define NO_ADEPTH 1234567
1626 
1627 static void	early_reset_choicepoint(mark_state *state, Choice ch ARG_LD);
1628 static void	mark_alt_clauses(LocalFrame fr, ClauseRef cref ARG_LD);
1629 
1630 
1631 		 /*******************************
1632 		 *	     STATISTICS		*
1633 		 *******************************/
1634 
1635 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1636 NOTE: Compile with  -DGC_COUNTING  to   get  gc_statistics/1  as defined
1637 below. This predicate is NOT THREAD-SAFE!!!
1638 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1639 
1640 #ifdef GC_COUNTING
1641 typedef struct life_count
1642 { int64_t	marked_envs;		/* environments marked */
1643   int64_t	marked_cont;		/* continuations followed */
1644   int64_t	c_scanned;		/* Scanned clauses */
1645   int64_t	vm_scanned;		/* #VM codes scanned */
1646 } life_count;
1647 
1648 static life_count counts;
1649 #define COUNT(f) counts.f++
1650 
1651 static
1652 PRED_IMPL("gc_counts", 1, gc_counts, 0)
1653 { int rc = PL_unify_term(A1,
1654 			 PL_FUNCTOR_CHARS, "gc", 4,
1655 			   PL_INT64, counts.marked_envs,
1656 			   PL_INT64, counts.marked_cont,
1657 			   PL_INT64, counts.c_scanned,
1658 			   PL_INT64, counts.vm_scanned);
1659 
1660   memset(&counts, 0, sizeof(counts));
1661 
1662   return rc;
1663 }
1664 
1665 #else
1666 #define COUNT(f) ((void)0)
1667 #endif
1668 
1669 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1670 mark_local_variable()
1671 
1672 As long as we are a reference link along the local stack, keep marking.
1673 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1674 
1675 static void
mark_local_variable(Word p ARG_LD)1676 mark_local_variable(Word p ARG_LD)
1677 { while ( tagex(*p) == (TAG_REFERENCE|STG_LOCAL) )
1678   { Word p2;
1679 
1680     p2 = unRef(*p);
1681     ldomark(p);
1682     if ( is_marked(p2) )
1683       return;
1684     p = p2;
1685   }
1686 
1687   if ( isGlobalRef(*p) )
1688     mark_variable(p PASS_LD);
1689   else
1690     ldomark(p);
1691 }
1692 
1693 
1694 static void
mark_arguments(LocalFrame fr ARG_LD)1695 mark_arguments(LocalFrame fr ARG_LD)
1696 { Word sp = argFrameP(fr, 0);
1697   int slots = fr->predicate->functor->arity;
1698 
1699   for( ; slots-- > 0; sp++ )
1700   { if ( !is_marked(sp) )
1701       mark_local_variable(sp PASS_LD);
1702   }
1703 }
1704 
1705 
1706 static void
mark_new_arguments(vm_state * state ARG_LD)1707 mark_new_arguments(vm_state *state ARG_LD)
1708 { if ( state->lNext )
1709   { Word sp = argFrameP(state->lNext, 0);
1710     int slots = state->new_args;
1711 
1712     DEBUG(MSG_GC_MARK_VAR,
1713 	  Sdprintf("mark_new_arguments(): %d args from %p\n", slots, sp));
1714 
1715     for( ; slots-- > 0; sp++ )
1716     { DEBUG(CHK_SECURE, assert(*sp != FLI_MAGIC));
1717       if ( !is_marked(sp) )
1718 	mark_local_variable(sp PASS_LD);
1719     }
1720   }
1721 }
1722 
1723 
1724 static void
mark_trie_gen(LocalFrame fr ARG_LD)1725 mark_trie_gen(LocalFrame fr ARG_LD)
1726 { Word   sp = argFrameP(fr, 0);
1727   Clause cl = fr->clause->value.clause;
1728   int    mv = cl->prolog_vars;
1729 
1730   for(; mv-- > 0; sp++)
1731   { if ( !is_marked(sp) )
1732       mark_local_variable(sp PASS_LD);
1733   }
1734 }
1735 
1736 
1737 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1738 walk_and_mark(walk_state *state, Code PC, code end, Code until)
1739     Walk along the byte code starting at PC and continuing until either
1740     it finds instruction `end' or the `until' address in code.  Returns
1741     the next instruction to process,
1742 
1743 See decompileBody for details on handling the branch instructions.
1744 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1745 
1746 static inline void
mark_frame_var(walk_state * state,code v ARG_LD)1747 mark_frame_var(walk_state *state, code v ARG_LD)
1748 { if ( state->active )
1749   { int i = (int)v - sizeof(struct localFrame)/sizeof(word);
1750 
1751     DEBUG(MSG_CONTINUE, Sdprintf("Access %d (%scleared)\n",
1752 				 i, true_bit(state->clear, i) ? "" : "not "));
1753     if ( !true_bit(state->clear, i) )
1754       set_bit(state->active, i);
1755   } else
1756   { Word sp = varFrameP(state->frame, v);
1757 
1758     if ( sp < state->envtop && !is_marked(sp) )
1759     { mark_local_variable(sp PASS_LD);
1760       state->unmarked--;
1761     }
1762   }
1763 }
1764 
1765 
1766 static inline void
clear_frame_var(walk_state * state,code var,Code PC)1767 clear_frame_var(walk_state *state, code var, Code PC)
1768 { if ( state->clear )
1769   { int i = (int)var - sizeof(struct localFrame)/sizeof(word);
1770 
1771     DEBUG(MSG_CONTINUE, Sdprintf("Clear %d\n", i));
1772     set_bit(state->clear, i);
1773   } else if ( (state->flags & GCM_CLEAR) )
1774   { LocalFrame fr = state->frame;
1775     DEBUG(MSG_GC_CLEAR,
1776 	  Sdprintf("Clear var %d at %d\n",
1777 		   var-VAROFFSET(0), (PC-state->c0)-1));
1778 #ifdef O_DEBUG
1779     if ( DEBUGGING(CHK_SECURE) )
1780     { Word vp = varFrameP(fr, PC[0]);
1781 
1782       if ( !isVar(*vp & ~MARK_MASK) )
1783       { Sdprintf("ERROR: [%ld] %s: Wrong clear of var %d, PC=%d\n",
1784 		 levelFrame(fr), predicateName(fr->predicate),
1785 		 var-VAROFFSET(0),
1786 		 (PC-state->c0)-1);
1787       }
1788     } else
1789     { setVar(varFrame(fr, var));
1790     }
1791 #else
1792     setVar(varFrame(fr, var));
1793 #endif
1794   }
1795 }
1796 
1797 
1798 static inline void
clear_choice_mark(walk_state * state,code slot)1799 clear_choice_mark(walk_state *state, code slot)
1800 { if ( (state->flags & GCM_CHOICE) )
1801   { int i = (int)slot - sizeof(struct localFrame)/sizeof(word);
1802     set_bit(state->clear, i);
1803   }
1804 }
1805 
1806 
1807 static inline void
mark_choice_mark(walk_state * state,code slot)1808 mark_choice_mark(walk_state *state, code slot)
1809 { if ( (state->flags & GCM_CHOICE) )
1810   { int i = (int)slot - sizeof(struct localFrame)/sizeof(word);
1811     set_bit(state->active, i);
1812   }
1813 }
1814 
1815 
1816 static inline void
mark_argp(walk_state * state ARG_LD)1817 mark_argp(walk_state *state ARG_LD)
1818 {
1819 #ifdef MARK_ALT_CLAUSES
1820   if ( !(state->flags & GCM_ACTIVE) && state->adepth == 0 )
1821   { if ( state->ARGP < state->envtop && !is_marked(state->ARGP) )
1822     { mark_local_variable(state->ARGP PASS_LD);
1823       state->unmarked--;
1824     }
1825     state->ARGP++;
1826   }
1827 #endif
1828 }
1829 
1830 
1831 static Code
walk_and_mark(walk_state * state,Code PC,code end ARG_LD)1832 walk_and_mark(walk_state *state, Code PC, code end ARG_LD)
1833 { code op;
1834 
1835   COUNT(marked_cont);
1836 
1837   for( ; ; PC += (codeTable[op].arguments))
1838   { op = decode(*PC++);
1839 
1840   again:
1841     DEBUG(MSG_GC_WALK,
1842 	  Sdprintf("\t%s at %d\n", codeTable[op].name, PC-state->c0-1));
1843     COUNT(vm_scanned);
1844     if ( op == end )
1845     { PC--;
1846       return PC;
1847     }
1848 
1849     switch( op )
1850     {
1851 #if O_DEBUGGER
1852       case D_BREAK:
1853 	op = decode(replacedBreak(PC-1));
1854         goto again;
1855 #endif
1856 					/* dynamically sized objects */
1857       case H_STRING:			/* only skip the size of the */
1858       case H_MPZ:
1859       case H_MPQ:
1860 	mark_argp(state PASS_LD);
1861 	/*FALLTHROUGH*/
1862       case B_STRING:			/* string + header */
1863       case A_MPZ:
1864       case B_MPZ:
1865       case A_MPQ:
1866       case B_MPQ:
1867       { word m = *PC;
1868 	PC += wsizeofInd(m)+1;
1869 	assert(codeTable[op].arguments == VM_DYNARGC);
1870 	PC -= VM_DYNARGC;		/* compensate for for-step */
1871 	break;
1872       }
1873 
1874       case I_EXITQUERY:
1875       case I_EXITFACT:
1876       case I_FEXITDET:
1877       case I_FEXITNDET:
1878       case S_TRUSTME:			/* Consider supervisor handling! */
1879       case S_LIST:
1880 	return PC-1;
1881       case S_NEXTCLAUSE:
1882 	mark_alt_clauses(state->frame, state->frame->clause->next PASS_LD);
1883         return PC-1;
1884       case I_FREDO:
1885 	mark_arguments(state->frame PASS_LD);
1886         return PC-1;
1887 
1888       case C_JMP:			/* unconditional jump */
1889 	if ( (state->flags & GCM_ALTCLAUSE) )
1890 	  break;
1891 	PC += (int)PC[0]+1;
1892         op = decode(*PC++);
1893         goto again;
1894 					/* Control-structures */
1895       case C_OR:
1896 	if ( (state->flags & GCM_ALTCLAUSE) )
1897 	  break;
1898       { Code alt = PC+PC[0]+1;
1899 	DEBUG(MSG_GC_WALK, Sdprintf("C_OR at %d\n", PC-state->c0-1));
1900 	PC++;				/* skip <n> */
1901 	walk_and_mark(state, PC, C_JMP PASS_LD);
1902 	PC = alt;
1903 	op = decode(*PC++);
1904         goto again;
1905       }
1906       case C_NOT:
1907 	if ( (state->flags & GCM_ALTCLAUSE) )
1908 	  break;
1909       { Code alt = PC+PC[1]+2;
1910 	DEBUG(MSG_GC_WALK, Sdprintf("C_NOT at %d\n", PC-state->c0-1));
1911 	clear_choice_mark(state, PC[0]);
1912 	PC += 2;			/* skip the two arguments */
1913 	walk_and_mark(state, PC, C_CUT PASS_LD);
1914 	DEBUG(MSG_GC_WALK, Sdprintf("C_NOT-ALT at %d\n", alt-state->c0));
1915 	PC = alt;
1916 	op = decode(*PC++);
1917         goto again;
1918       }
1919       case C_SOFTIF:
1920       case C_IFTHENELSE:
1921       case C_FASTCOND:
1922 	if ( (state->flags & GCM_ALTCLAUSE) )
1923 	  break;
1924       { Code alt = PC+PC[1]+2;
1925 	clear_choice_mark(state, PC[0]);
1926 	DEBUG(MSG_GC_WALK, Sdprintf("C_IFTHENELSE at %d\n", PC-state->c0-1));
1927 	PC += 2;			/* skip the 'MARK' variable and jmp */
1928 	walk_and_mark(state, PC, C_JMP PASS_LD);
1929 	PC = alt;
1930 	op = decode(*PC++);
1931         goto again;
1932       }
1933       case C_IFTHEN:
1934       case C_SOFTIFTHEN:
1935 	if ( (state->flags & GCM_ALTCLAUSE) )
1936 	  break;
1937       { clear_choice_mark(state, PC[0]);
1938 	PC = walk_and_mark(state, PC+1, C_END PASS_LD);
1939 	PC++;				/* skip C_END */
1940 	op = decode(*PC++);
1941         goto again;
1942       }
1943       case C_CUT:
1944       case C_LSCUT:
1945       case C_LCUT:
1946       case C_SOFTCUT:
1947       case C_LCUTIFTHEN:
1948       case C_FASTCUT:
1949 	mark_choice_mark(state, PC[0]);
1950         break;
1951 					/* variable access */
1952 
1953       case B_UNIFY_VAR:			/* Var = Term */
1954 	mark_frame_var(state, PC[0] PASS_LD);
1955         state->adepth = NO_ADEPTH;
1956 	break;
1957       case B_UNIFY_FIRSTVAR:
1958 	state->adepth = NO_ADEPTH;	/* never need to mark over ARGP */
1959         /*FALLTHROUGH*/
1960       case B_FIRSTVAR:
1961       case B_ARGFIRSTVAR:
1962       case A_FIRSTVAR_IS:
1963       case B_UNIFY_FC:
1964       case C_VAR:
1965 	clear_frame_var(state, PC[0], PC);
1966 	break;
1967       case C_VAR_N:
1968       { size_t var = PC[0];
1969 	size_t count = PC[1];
1970 
1971 	while(count--)
1972 	  clear_frame_var(state, var++, PC);
1973 	break;
1974       }
1975       case H_LIST_FF:
1976 	mark_argp(state PASS_LD);
1977         /*FALLTHROUGH*/
1978       case B_UNIFY_FF:
1979 	clear_frame_var(state, PC[0], PC);
1980 	clear_frame_var(state, PC[1], PC);
1981 	break;
1982       case A_ADD_FC:
1983       case B_UNIFY_FV:
1984       case B_UNIFY_VF:
1985 	clear_frame_var(state, PC[0], PC);
1986 	mark_frame_var(state, PC[1] PASS_LD);
1987 	break;
1988       case B_UNIFY_VV:
1989       case B_EQ_VV:
1990       case B_NEQ_VV:
1991 	mark_frame_var(state, PC[0] PASS_LD);
1992         mark_frame_var(state, PC[1] PASS_LD);
1993 	break;
1994       case I_VAR:
1995       case I_NONVAR:
1996       case I_INTEGER:
1997       case I_FLOAT:
1998       case I_NUMBER:
1999       case I_ATOMIC:
2000       case I_ATOM:
2001       case I_STRING:
2002       case I_COMPOUND:
2003       case I_CALLABLE:
2004       case I_CALLCONT:
2005       case I_SHIFT:
2006 	mark_frame_var(state, PC[0] PASS_LD);
2007         break;
2008 
2009       { size_t index;			/* mark variable access */
2010 
2011 	case B_UNIFY_VC:
2012 	case B_EQ_VC:
2013 	case B_NEQ_VC:
2014 	case B_ARGVAR:
2015 	case A_VAR:
2016 	case B_VAR:	    index = *PC;		goto var_common;
2017 	case A_VAR0:
2018 	case B_VAR0:	    index = VAROFFSET(0);	goto var_common;
2019 	case A_VAR1:
2020 	case B_VAR1:	    index = VAROFFSET(1);	goto var_common;
2021 	case A_VAR2:
2022 	case B_VAR2:	    index = VAROFFSET(2);	var_common:
2023 	  mark_frame_var(state, index PASS_LD);
2024 	  break;
2025       }
2026 	case I_CALLCLEANUP:
2027 	  mark_frame_var(state, VAROFFSET(1) PASS_LD); /* main goal */
2028 	  break;
2029 	case I_EXITCLEANUP:
2030 	  mark_frame_var(state, VAROFFSET(2) PASS_LD); /* The ball */
2031 	  mark_frame_var(state, VAROFFSET(3) PASS_LD); /* cleanup goal */
2032 	  break;
2033 	case I_EXITCATCH:
2034 	case I_EXITRESET:
2035 	  mark_frame_var(state, VAROFFSET(1) PASS_LD); /* The ball */
2036 	  mark_frame_var(state, VAROFFSET(2) PASS_LD); /* recovery goal */
2037 	  break;
2038 	case I_CUTCHP:
2039 	  mark_frame_var(state, VAROFFSET(1) PASS_LD); /* choice-point */
2040 	  break;
2041 #ifdef O_CALL_AT_MODULE
2042 	case I_CALLATMV:
2043 	case I_DEPARTATMV:
2044 	  mark_frame_var(state, PC[1] PASS_LD);
2045 	  break;
2046 #endif
2047 #ifdef MARK_ALT_CLAUSES
2048 	case H_FIRSTVAR:
2049 	  if ( (state->flags & GCM_CLEAR) )
2050 	  { clear_frame_var(state, PC[0], PC);
2051 	    break;
2052 	  }
2053 	  mark_argp(state PASS_LD);
2054 	  break;
2055 	case H_VAR:
2056 	  mark_frame_var(state, PC[0] PASS_LD);
2057 	  /*FALLTHROUGH*/
2058 	case H_ATOM:
2059 	case H_SMALLINT:
2060 	case H_NIL:
2061 	case H_INTEGER:
2062 	case H_INT64:
2063 	case H_FLOAT:
2064 	  mark_argp(state PASS_LD);
2065 	  break;
2066 	case H_FUNCTOR:
2067 	case H_LIST:
2068 	  mark_argp(state PASS_LD);
2069 	  /*FALLTHROUGH*/
2070 	case B_FUNCTOR:
2071 	case B_LIST:
2072 	  state->adepth++;
2073 	  break;
2074 	case H_VOID:
2075 	  if ( state->adepth == 0 )
2076 	    state->ARGP++;
2077 	  break;
2078 	case H_VOID_N:
2079 	  if ( state->adepth == 0 )
2080 	    state->ARGP += PC[0];
2081 	  break;
2082 	case H_POP:
2083 	case B_POP:
2084 	  state->adepth--;
2085 	  break;
2086 	case B_UNIFY_EXIT:
2087 	  assert(state->adepth == 0 || state->adepth == NO_ADEPTH);
2088 	  break;
2089 	case I_ENTER:
2090 	  assert(state->adepth==0);
2091 	  break;
2092 #endif /*MARK_ALT_CLAUSES*/
2093     }
2094   }
2095 
2096   return PC;
2097 }
2098 
2099 
2100 void
mark_active_environment(bit_vector * active,LocalFrame fr,Code PC)2101 mark_active_environment(bit_vector *active, LocalFrame fr, Code PC)
2102 { GET_LD
2103   walk_state state;
2104   size_t bv_bytes = sizeof_bitvector(active->size);
2105   char tmp[128];
2106   char *buf;
2107   bit_vector *clear;
2108 
2109   if ( bv_bytes <= sizeof(tmp) )
2110     buf = tmp;
2111   else
2112     buf = PL_malloc(bv_bytes);
2113 
2114   clear = (bit_vector*)buf;
2115   init_bitvector(clear, active->size);
2116 
2117   state.frame  = fr;
2118   state.flags  = GCM_ACTIVE|GCM_CLEAR|GCM_CHOICE;
2119   state.adepth = 0;
2120   state.ARGP   = argFrameP(fr, 0);
2121   state.active = active;
2122   state.clear  = clear;
2123   state.envtop = NULL;
2124   state.c0     = fr->clause->value.clause->codes;
2125 
2126   DEBUG(MSG_GC_WALK,
2127 	Sdprintf("Mark active for %s\n", predicateName(fr->predicate)));
2128 
2129   walk_and_mark(&state, PC, I_EXIT PASS_LD);
2130   if ( buf != tmp )
2131     PL_free(buf);
2132 }
2133 
2134 
2135 #ifdef MARK_ALT_CLAUSES
2136 static void
mark_alt_clauses(LocalFrame fr,ClauseRef cref ARG_LD)2137 mark_alt_clauses(LocalFrame fr, ClauseRef cref ARG_LD)
2138 { Word sp = argFrameP(fr, 0);
2139   int argc = fr->predicate->functor->arity;
2140   int i;
2141   walk_state state;
2142   state.unmarked = 0;
2143 
2144   for(i=0; i<argc; i++ )
2145   { if ( !is_marked(&sp[i]) )
2146       state.unmarked++;
2147   }
2148 
2149   if ( !state.unmarked )
2150     return;
2151 
2152   state.frame	     = fr;
2153   state.flags        = GCM_ALTCLAUSE;
2154   state.adepth       = 0;
2155   state.ARGP	     = argFrameP(fr, 0);
2156   state.active	     = NULL;
2157   state.clear	     = NULL;
2158   state.envtop	     = state.ARGP + argc;
2159 
2160   DEBUG(MSG_GC_WALK,
2161 	Sdprintf("Scanning clauses for %s\n", predicateName(fr->predicate)));
2162   for(; cref && state.unmarked > 0; cref=cref->next)
2163   { if ( visibleClause(cref->value.clause, generationFrame(fr)) )
2164     { COUNT(c_scanned);
2165       state.c0 = cref->value.clause->codes;
2166       DEBUG(MSG_GC_WALK, Sdprintf("Scanning clause %p\n", cref->value.clause));
2167       walk_and_mark(&state, state.c0, I_EXIT PASS_LD);
2168     }
2169 
2170     state.adepth     = 0;
2171     state.ARGP	     = argFrameP(fr, 0);
2172   }
2173 }
2174 
2175 #else /*MARK_ALT_CLAUSES*/
2176 
2177 static void
mark_alt_clauses(LocalFrame fr,ClauseRef cref ARG_LD)2178 mark_alt_clauses(LocalFrame fr, ClauseRef cref ARG_LD)
2179 { mark_arguments(fr PASS_LD);
2180 }
2181 
2182 #endif /*MARK_ALT_CLAUSES*/
2183 
2184 static void
early_reset_choicepoint(mark_state * state,Choice ch ARG_LD)2185 early_reset_choicepoint(mark_state *state, Choice ch ARG_LD)
2186 { LocalFrame fr = ch->frame;
2187   Word top;
2188 
2189   while((char*)state->flictx > (char*)ch)
2190   { FliFrame fli = state->flictx;
2191 
2192     state->reset_entry = mark_foreign_frame(fli, state->reset_entry PASS_LD);
2193     state->flictx = fli->parent;
2194   }
2195 
2196   if ( ch->type == CHP_CLAUSE )
2197   { top = argFrameP(fr, fr->predicate->functor->arity);
2198   } else
2199   { assert(ch->type == CHP_TOP || (void *)ch > (void *)fr);
2200     top = (Word)ch;
2201   }
2202 
2203   state->reset_entry = early_reset_vars(&ch->mark, top, state->reset_entry PASS_LD);
2204   needsRelocation(&ch->mark.trailtop);
2205   alien_into_relocation_chain(&ch->mark.trailtop,
2206 			      STG_TRAIL, STG_LOCAL PASS_LD);
2207   DEBUG(CHK_SECURE, trailtops_marked--);
2208 }
2209 
2210 
2211 static QueryFrame mark_environments(mark_state *state,
2212 				    LocalFrame fr, Code PC ARG_LD);
2213 
2214 static void
mark_choicepoints(mark_state * state,Choice ch ARG_LD)2215 mark_choicepoints(mark_state *state, Choice ch ARG_LD)
2216 { for(; ch; ch=ch->parent)
2217   { early_reset_choicepoint(state, ch PASS_LD);
2218 
2219     switch(ch->type)
2220     { case CHP_JUMP:
2221 	mark_environments(state, ch->frame, ch->value.PC PASS_LD);
2222 	break;
2223       case CHP_CLAUSE:
2224       { LocalFrame fr = ch->frame;
2225 
2226 	mark_alt_clauses(fr, ch->value.clause.cref PASS_LD);
2227         if ( false(fr, FR_MARKED) )
2228 	{ set(fr, FR_MARKED);
2229 	  COUNT(marked_envs);
2230 	  mark_environments(state, fr->parent, fr->programPointer PASS_LD);
2231 	}
2232 	break;
2233       }
2234       case CHP_DEBUG:
2235       case CHP_CATCH:
2236 	mark_environments(state, ch->frame, NULL PASS_LD);
2237 	break;
2238       case CHP_TOP:
2239 	break;
2240     }
2241   }
2242 }
2243 
2244 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2245 (*) We need to mark  the  top   frame  to  deal  with foreign predicates
2246 calling  Prolog  back  that  can  leak    term-handles   of  the  parent
2247 environment. This came from Roberto Bagnara   and was simplified to this
2248 program, which must write foo(0).
2249 
2250 test :- c_bind(X), writeln(X).
2251 bind(X) :- X = foo(0), garbage_collect.
2252 
2253 static foreign_t
2254 bind(term_t arg)
2255 { predicate_t pred = PL_predicate("bind", 1, "user");
2256 
2257   return PL_call_predicate(NULL, PL_Q_NORMAL, pred, arg);
2258 }
2259 
2260 install_t
2261 install()
2262 { PL_register_foreign("c_bind", 1, bind, 0);
2263 }
2264 
2265 (**)  If  we  are  in  head-unification  mode,  (saved)ARGP  are  nicely
2266 relocated. However, we must also ensure that the term in which it points
2267 is not GC-ed. This applies  for   head-arguments  as well as B_UNIFY_VAR
2268 instructions. See get_vmi_state().
2269 
2270 (***) When debugging, we must  avoid   GC-ing  local variables of frames
2271 that  are  watched  by  the  debugger.    FR_WATCHED  is  also  used  by
2272 setup_call_cleanup/3. We avoid full marking here. Maybe we should use an
2273 alternate flag for these two cases?
2274 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2275 
2276 static QueryFrame
mark_environments(mark_state * mstate,LocalFrame fr,Code PC ARG_LD)2277 mark_environments(mark_state *mstate, LocalFrame fr, Code PC ARG_LD)
2278 { QueryFrame qf = NULL;
2279 
2280   while ( fr )
2281   { walk_state state;
2282 
2283     if ( false(fr, FR_MARKED) )
2284     { set(fr, FR_MARKED);
2285       state.flags = GCM_CLEAR;
2286 
2287       COUNT(marked_envs);
2288     } else
2289     { state.flags = 0;
2290     }
2291 
2292     assert(wasFrame(fr));
2293 
2294     if ( true(fr->predicate, P_FOREIGN) || PC == NULL || !fr->clause )
2295     { DEBUG(MSG_GC_MARK_ARGS,
2296 	    Sdprintf("Marking arguments for [%d] %s\n",
2297 		     levelFrame(fr), predicateName(fr->predicate)));
2298       mark_arguments(fr PASS_LD);
2299     } else if ( fr->clause->value.clause->codes[0] == encode(T_TRIE_GEN2) ||
2300 		fr->clause->value.clause->codes[0] == encode(T_TRIE_GEN3) )
2301     { mark_trie_gen(fr PASS_LD);
2302     } else
2303     { Word argp0;
2304       state.frame    = fr;
2305       state.unmarked = slotsInFrame(fr, PC);
2306       state.envtop   = argFrameP(fr, state.unmarked);
2307       state.active   = NULL;
2308       state.clear    = NULL;
2309       state.c0       = fr->clause->value.clause->codes;
2310 
2311       if ( fr == mstate->vm_state->frame &&
2312 	   PC == mstate->vm_state->pc_start_vmi )
2313       { argp0        = mstate->vm_state->argp0;
2314 	state.ARGP   = mstate->vm_state->argp;
2315 	state.adepth = mstate->vm_state->adepth;
2316 	mark_new_arguments(mstate->vm_state PASS_LD);
2317       } else
2318       { argp0 = NULL;
2319       }
2320 
2321       DEBUG(MSG_GC_WALK,
2322 	    Sdprintf("Walking code for [%d] %s from PC=%d\n",
2323 		     levelFrame(fr), predicateName(fr->predicate),
2324 		     PC-state.c0));
2325 
2326       walk_and_mark(&state, PC, I_EXIT PASS_LD);
2327 
2328       if ( argp0 && !is_marked(argp0) )		/* see (**) */
2329       { assert(onStackArea(local, argp0));
2330 	mark_local_variable(argp0 PASS_LD);
2331       }
2332 
2333       if ( true(fr, FR_WATCHED) &&		/* (***) */
2334 	   fr->predicate != PROCEDURE_setup_call_catcher_cleanup4->definition )
2335       { int slots;
2336 	Word sp;
2337 
2338 	slots  = slotsInFrame(fr, PC);
2339 	sp = argFrameP(fr, 0);
2340 	for( ; slots-- > 0; sp++ )
2341 	{ if ( !is_marked(sp) )
2342 	    mark_local_variable(sp PASS_LD);
2343 	}
2344       }
2345     }
2346 
2347     if ( !(state.flags&GCM_CLEAR) )	/* from choicepoint */
2348       return NULL;
2349 
2350     if ( fr->parent )
2351     { PC = fr->programPointer;
2352       fr = fr->parent;
2353     } else
2354     { qf = queryOfFrame(fr);
2355 
2356       if ( qf->saved_environment )
2357 	mark_arguments(qf->saved_environment PASS_LD); /* (*) */
2358 
2359       break;
2360     }
2361   }
2362 
2363   return qf;
2364 }
2365 
2366 
2367 
2368 static QueryFrame
mark_query_stacks(mark_state * state,LocalFrame fr,Choice ch,Code PC ARG_LD)2369 mark_query_stacks(mark_state *state, LocalFrame fr, Choice ch, Code PC ARG_LD)
2370 { QueryFrame qf;
2371 
2372   qf = mark_environments(state, fr, PC PASS_LD);
2373   mark_choicepoints(state, ch PASS_LD);
2374 
2375   return qf;
2376 }
2377 
2378 
2379 static void
mark_stacks(vm_state * vmstate)2380 mark_stacks(vm_state *vmstate)
2381 { GET_LD
2382   QueryFrame qf=NULL;
2383   mark_state state;
2384   vm_state sub_state;
2385   LocalFrame fr = vmstate->frame;
2386   Choice ch     = vmstate->choice;
2387   Code PC       = vmstate->pc_start_vmi;
2388 
2389   memset(&state, 0, sizeof(state));
2390   state.vm_state     = vmstate;
2391   state.reset_entry  = (GCTrailEntry)tTop - 1;
2392   state.flictx       = fli_context;
2393   trailcells_deleted = 0;
2394 
2395   while(fr)
2396   { DEBUG(MSG_GC_MARK_QUERY, Sdprintf("Marking query %p\n", qf));
2397     qf = mark_query_stacks(&state, fr, ch, PC PASS_LD);
2398 
2399     if ( qf->parent )			/* same code in checkStacks() */
2400     { QueryFrame pqf = qf->parent;
2401 
2402       if ( (fr = pqf->registers.fr) )
2403       { get_vmi_state(pqf, &sub_state);
2404 	sub_state.choice = qf->saved_bfr;
2405 
2406 	state.vm_state = &sub_state;
2407 	PC = sub_state.pc_start_vmi;
2408       } else
2409       { fr = qf->saved_environment;
2410 	PC = NULL;
2411       }
2412       ch = qf->saved_bfr;
2413     } else
2414       break;
2415   }
2416 
2417   for( ; state.flictx; state.flictx = state.flictx->parent)
2418     state.reset_entry = mark_foreign_frame(state.flictx,
2419 					   state.reset_entry PASS_LD);
2420 
2421   DEBUG(MSG_GC_STATS,
2422 	Sdprintf("Trail stack garbage: %ld cells\n", trailcells_deleted));
2423 }
2424 
2425 
2426 #if O_DEBUG
2427 static int
cmp_address(const void * vp1,const void * vp2)2428 cmp_address(const void *vp1, const void *vp2)
2429 { Word p1 = *((Word *)vp1);
2430   Word p2 = *((Word *)vp2);
2431 
2432   return p1 > p2 ? 1 : p1 == p2 ? 0 : -1;
2433 }
2434 #endif
2435 
2436 
2437 static void
mark_phase(vm_state * state)2438 mark_phase(vm_state *state)
2439 { GET_LD
2440   total_marked = 0;
2441 
2442   DEBUG(CHK_SECURE, check_marked("Before mark_term_refs()"));
2443   mark_term_refs();
2444   mark_stacks(state);
2445 
2446   DEBUG(CHK_SECURE,
2447 	{ if ( !scan_global(TRUE) )
2448 	    sysError("Global stack corrupted after GC mark-phase");
2449 	  qsort(mark_base, mark_top - mark_base, sizeof(Word), cmp_address);
2450 	});
2451 
2452   DEBUG(MSG_GC_STATS,
2453 	{ intptr_t size = gTop - gBase;
2454 	  Sdprintf("%ld referenced cell; %ld garbage (gTop = %p)\n",
2455 		   total_marked, size - total_marked, gTop);
2456 	});
2457 }
2458 
2459 
2460 		/********************************
2461 		*          COMPACTING           *
2462 		*********************************/
2463 
2464 
2465 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2466 Relocation chain management
2467 
2468 A relocation chain is a linked chain of cells, whose elements all should
2469 point to `dest' after it is unwound.  SWI-Prolog knows about a number of
2470 different pointers.  This routine is supposed  to  restore  the  correct
2471 pointer.  The following types are identified:
2472 
2473     source	types
2474     local	address values (gTop references)
2475 		term, reference and indirect pointers
2476     trail	address values (reset addresses)
2477     global	term, reference and indirect pointers
2478 
2479 To do this, a pointer of the same  type  is  stored  in  the  relocation
2480 chain.
2481 
2482     update_relocation_chain(current, dest)
2483 	This function checks whether current is the head of a relocation
2484 	chain.  As we know `dest' is the place  `current'  is  going  to
2485 	move  to,  we  can reverse the chain and have all pointers in it
2486 	pointing to `dest'.
2487 
2488 	We must clear the `first' bit on the field.
2489 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2490 
2491 static void
update_relocation_chain(Word current,Word dest ARG_LD)2492 update_relocation_chain(Word current, Word dest ARG_LD)
2493 { Word head = current;
2494   word val = get_value(current);
2495 
2496   DEBUG(MSG_GC_RELOC,
2497 	Sdprintf("unwinding relocation chain at %p to %p\n",
2498 		 current, dest));
2499 
2500   do
2501   { int tag;
2502 
2503     unmark_first(current);
2504     current = valPtr(val);
2505     tag = (int)tag(val);
2506     val = get_value(current);
2507     DEBUG(MSG_GC_RELOC,
2508 	  { FliFrame f;
2509 
2510 	    f = addPointer(current, - offset(fliFrame, mark.trailtop));
2511 	    if ( onStack(local, f) && f->magic == FLI_MAGIC )
2512 	      Sdprintf("Updating trail-mark of foreign frame at %p\n", f);
2513 	  });
2514     set_value(current, makePtr(dest, tag PASS_LD));
2515     relocated_cell(current);
2516   } while( is_first(current) );
2517 
2518   set_value(head, val);
2519   relocation_chains--;
2520 }
2521 
2522 
2523 static void
into_relocation_chain(Word current,int stg ARG_LD)2524 into_relocation_chain(Word current, int stg ARG_LD)
2525 { Word head;
2526   word val = get_value(current);
2527 
2528   head = valPtr(val);			/* FIRST/MASK already gone */
2529   set_value(current, get_value(head));
2530   set_value(head, consPtr(current, stg|tag(val)));
2531 
2532   DEBUG(MSG_GC_RELOC,
2533 	Sdprintf("Into relocation chain: %p (head = %p)\n",
2534 		 current, head));
2535 
2536   if ( is_first(head) )
2537     mark_first(current);
2538   else
2539   { mark_first(head);
2540     relocation_chains++;
2541   }
2542 
2543   relocation_cells++;
2544 }
2545 
2546 
2547 static void
alien_into_relocation_chain(void * addr,int orgst,int stg ARG_LD)2548 alien_into_relocation_chain(void *addr, int orgst, int stg ARG_LD)
2549 { void **ptr = (void **)addr;
2550 
2551   *ptr = (void *)consPtr(*ptr, orgst);
2552   into_relocation_chain(addr, stg PASS_LD);
2553 
2554   alien_relocations++;
2555 }
2556 
2557 
2558 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2559 Trail stack compacting.
2560 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2561 
2562 static void
compact_trail(void)2563 compact_trail(void)
2564 { GET_LD
2565   GCTrailEntry dest, current;
2566 
2567 	/* compact the trail stack */
2568   for( dest = current = (GCTrailEntry)tBase; current < (GCTrailEntry)tTop; )
2569   { if ( is_first(&current->address) )
2570       update_relocation_chain(&current->address, &dest->address PASS_LD);
2571 #if O_DEBUG
2572     else if ( DEBUGGING(CHK_SECURE) )
2573     { void *chk;
2574       if ( (chk = lookupHTable(check_table, current)) &&
2575 	   chk == RELOC_NEEDS )
2576         sysError("%p was supposed to be relocated (*= %p)",
2577 		 current, current->address);
2578     }
2579 #endif
2580 
2581     if ( current->address )
2582       *dest++ = *current++;
2583     else
2584       current++;
2585   }
2586   if ( is_first(&current->address) )
2587     update_relocation_chain(&current->address, &dest->address PASS_LD);
2588 
2589   tTop = (TrailEntry)dest;
2590 
2591   if ( relocated_cells != relocation_cells )
2592     sysError("After trail: relocation cells = %ld; relocated_cells = %ld\n",
2593 	     relocation_cells, relocated_cells);
2594 }
2595 
2596 
2597 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2598 {tag,untag}_trail() are used to turn  the   native  pointers used on the
2599 trail-stack into tagged ones as  used  on   the  other  stacks,  to make
2600 pointer reversal in the relocation chains uniform.
2601 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2602 
2603 static void
tag_trail(ARG1_LD)2604 tag_trail(ARG1_LD)
2605 { TrailEntry te;
2606 
2607   for( te = tTop; --te >= tBase; )
2608   { Word p = te->address;
2609     int stg;
2610 
2611     if ( isTrailVal(p) )
2612     { Word p2 = trailValP(p);
2613 
2614       DEBUG(CHK_SECURE, assert(onStack(global, p2)));
2615       te->address = (Word)consPtr(p2, STG_GLOBAL|TAG_TRAILVAL);
2616       //DEBUG(SECURE_CHK, assert(te == tBase || !isTrailVal(te[-1].address)));
2617     } else
2618     { if ( onLocal(te->address) )
2619       { stg = STG_LOCAL;
2620       } else
2621       { DEBUG(CHK_SECURE, assert(onGlobalArea(te->address)));
2622 	stg = STG_GLOBAL;
2623       }
2624 
2625       te->address = (Word)consPtr(te->address, stg);
2626     }
2627   }
2628 }
2629 
2630 
2631 static void
untag_trail(ARG1_LD)2632 untag_trail(ARG1_LD)
2633 { TrailEntry te;
2634 
2635   for(te = tBase; te < tTop; te++)
2636   { if ( te->address )
2637     { word mask = ttag(te->address);
2638 
2639       te->address = (Word)((word)valPtr((word)te->address)|mask);
2640 #ifdef O_ATTVAR
2641       if ( isTrailVal(te->address) )
2642       { word w = trailVal(te->address);
2643 
2644 	if ( isAttVar(w) )
2645 	{ Word avp = te[-1].address;
2646 
2647 	  DEBUG(CHK_SECURE, assert(on_attvar_chain(avp)));
2648 	  if ( !isAttVar(*avp) )
2649 	    *(avp) |= MARK_MASK;
2650 	}
2651       }
2652 #endif
2653     }
2654   }
2655 }
2656 
2657 #ifdef O_ATTVAR
2658 
2659 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2660 Remove dead cells from the attvar  administration.   This  is a chain of
2661 variable references located just below each attvar. An attvar is dead if
2662 the value is no longer a TAG_ATTVAR   reference  and there is no trailed
2663 assignment for it.
2664 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2665 
2666 static int
is_dead_attvar(Word p ARG_LD)2667 is_dead_attvar(Word p ARG_LD)
2668 { word w = *p;
2669 
2670   if ( (w & MARK_MASK) )
2671   { *p = (w & ~MARK_MASK);
2672     return FALSE;
2673   }
2674   if ( isAttVar(w) )
2675     return FALSE;
2676 
2677   return TRUE;
2678 }
2679 
2680 
2681 static void
clean_attvar_chain(ARG1_LD)2682 clean_attvar_chain(ARG1_LD)
2683 { Word p, last = NULL, next;
2684 #ifdef O_DEBUG
2685   size_t cleaned = 0;
2686 #endif
2687 
2688   for(p = LD->attvar.attvars; p; p = next)
2689   { Word avp  = p+1;
2690 
2691     next = isRef(*p) ? unRef(*p) : NULL;
2692 
2693     if ( is_dead_attvar(avp PASS_LD) )
2694     { if ( last )
2695 	*last = *p;
2696       else
2697 	LD->attvar.attvars = next;
2698 #ifdef O_DEBUG
2699       cleaned++;
2700 #endif
2701     } else
2702       last = p;
2703   }
2704 
2705   DEBUG(MSG_ATTVAR_LINK,
2706 	if ( cleaned )
2707 	  Sdprintf("Cleaned %ld attvars\n", cleaned));
2708 }
2709 
2710 #endif /*ATTVAR*/
2711 
2712 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2713 Make a hole. This is used by functions   doing a scan on the global data
2714 after marking. By creating a large cell   (disguised  as a string) other
2715 functions doing a scan can skip large portions.
2716 
2717 bottom points to the bottom of the  garbage   and  top to the top *cell*
2718 that is garbage.  I.e., the total size of the cell is (top+1)-bottom.
2719 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2720 
2721 #define MAX_STRLEN wsizeofInd(~(word)0)
2722 
2723 static Word
make_gc_hole(Word bottom,Word top)2724 make_gc_hole(Word bottom, Word top)
2725 { if ( top - bottom > 4 )
2726   { size_t wsize = top - bottom - 1;
2727     Word bt = bottom;
2728     word hdr;
2729 
2730     while(wsize > MAX_STRLEN)
2731     { Word t1  = bt+MAX_STRLEN+1;
2732 
2733       hdr = mkIndHdr(MAX_STRLEN, TAG_STRING);
2734       *t1 = *bt = hdr;
2735       DEBUG(MSG_GC_HOLE,
2736 	    Sdprintf("Created Garbage hole %p..%p\n", bt, t1+1));
2737       bt = t1+1;
2738       wsize = top - bt - 1;
2739     }
2740 
2741     hdr = mkIndHdr(wsize, TAG_STRING); /* limited by size of string? */
2742     *top = *bt = hdr;
2743 
2744     DEBUG(MSG_GC_HOLE,
2745 	  Sdprintf("Created Garbage hole %p..%p, size %ld\n",
2746 		   bt, top+1, (long)wsize));
2747   }
2748 
2749   return bottom;
2750 }
2751 
2752 
2753 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2754 Sweep a mark. *m is a top-of-global   pointer,  i.e. it points the first
2755 free place in the global stack. Simply   updating is not good enough, as
2756 this part may be garbage. Hence, we  have   to  scan  until we find real
2757 data.
2758 
2759 Note that initPrologStacks writes a dummy   marked cell below the global
2760 stack, so this routine needs not to check   for the bottom of the global
2761 stack. This almost doubles the performance of this critical routine.
2762 
2763 (*) This function does a check for  the first non-garbage cell, which is
2764 a linear scan. If the are many   marks (choice-points and foreign marks)
2765 and a lot  of  garbage,  this   becomes  very  costly.  Therefore, after
2766 skipping a region the region  is  filled   with  variables  that cary as
2767 offset the location of the  target   non-garbage  location.  If scanning
2768 finds one of these cells, we simply fetch the value and go to `done'.
2769 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2770 
2771 #define consVar(w) (((intptr_t)(w)<<LMASK_BITS) | TAG_VAR)
2772 #define valVar(w)  ((intptr_t)(w) >> LMASK_BITS)
2773 
2774 static void
sweep_global_mark(Word * m ARG_LD)2775 sweep_global_mark(Word *m ARG_LD)
2776 { Word gm;
2777 
2778   DEBUG(CHK_SECURE, assert(onStack(local, m)));
2779   gm = *m;
2780   if ( is_marked_or_first(gm-1) )
2781     goto done;				/* quit common easy case */
2782 
2783   for(;;)
2784   { Word prev = gm-1;
2785 
2786     while( !(*prev & (MARK_MASK|FIRST_MASK|STG_LOCAL)) )
2787     { if ( tag(*prev) == TAG_VAR && *prev != 0 )
2788       { gm = gBase + valVar(*prev);
2789 	goto done;			/* (*) */
2790       }
2791       prev--;
2792     }
2793     gm = prev+1;
2794 
2795     if ( is_marked_or_first(prev) )
2796     {
2797     found:
2798       { size_t off = gm-gBase;
2799 	word w = consVar(off);
2800 	Word p;
2801 
2802 	for(p = gm+1; p<(*m); p++)
2803 	  *p = w;			/* (*) */
2804       }
2805 
2806     done:
2807       *m = gm;
2808       DEBUG(MSG_GC_RELOC, Sdprintf("gTop mark from choice point: "));
2809       needsRelocation(m);
2810       check_relocation((Word)m);
2811       alien_into_relocation_chain(m, STG_GLOBAL, STG_LOCAL PASS_LD);
2812 
2813       return;
2814     } else				/* a large cell */
2815     { size_t offset;
2816 
2817       DEBUG(CHK_SECURE, assert(storage(*prev) == STG_LOCAL));
2818       offset = wsizeofInd(*prev)+1;	/* = offset for a large cell */
2819       prev -= offset;
2820       if ( is_marked_or_first(prev) )
2821 	goto found;
2822     }
2823     gm = prev;
2824   }
2825 }
2826 
2827 
2828 static inline void
sweep_mark(mark * m ARG_LD)2829 sweep_mark(mark *m ARG_LD)
2830 { marks_swept++;
2831   sweep_global_mark(&m->globaltop PASS_LD);
2832   if ( m->saved_bar > gTop )
2833     m->saved_bar = gTop;
2834   sweep_global_mark(&m->saved_bar PASS_LD);
2835 }
2836 
2837 
2838 static void
sweep_foreign()2839 sweep_foreign()
2840 { GET_LD
2841   FliFrame fr = fli_context;
2842 
2843   for( ; fr; fr = fr->parent )
2844   { Word sp = refFliP(fr, 0);
2845     int n = fr->size;
2846 
2847     DEBUG(CHK_SECURE, assert(fr->magic == FLI_MAGIC));
2848 
2849     if ( isRealMark(fr->mark) )
2850       sweep_mark(&fr->mark PASS_LD);
2851     for( ; n-- > 0; sp++ )
2852     { if ( is_marked(sp) )
2853       {	unmark(sp);
2854 	if ( isGlobalRef(get_value(sp)) )
2855 	{ processLocal(sp);
2856 	  check_relocation(sp);
2857 	  into_relocation_chain(sp, STG_LOCAL PASS_LD);
2858 	}
2859       }
2860     }
2861   }
2862 }
2863 
2864 
2865 static void
unsweep_mark(mark * m ARG_LD)2866 unsweep_mark(mark *m ARG_LD)
2867 { m->trailtop  = (TrailEntry)valPtr2((word)m->trailtop,  STG_TRAIL);
2868   m->globaltop = valPtr2((word)m->globaltop, STG_GLOBAL);
2869   m->saved_bar = valPtr2((word)m->saved_bar, STG_GLOBAL);
2870 
2871   DEBUG(CHK_SECURE, check_mark(m));
2872 
2873   marks_unswept++;
2874 }
2875 
2876 
2877 static void
unsweep_foreign(ARG1_LD)2878 unsweep_foreign(ARG1_LD)
2879 { FliFrame fr = fli_context;
2880 
2881   for( ; fr; fr = fr->parent )
2882   { if ( isRealMark(fr->mark) )
2883       unsweep_mark(&fr->mark PASS_LD);
2884   }
2885 }
2886 
2887 
2888 static void
unsweep_choicepoints(Choice ch ARG_LD)2889 unsweep_choicepoints(Choice ch ARG_LD)
2890 { for( ; ch ; ch = ch->parent)
2891     unsweep_mark(&ch->mark PASS_LD);
2892 }
2893 
2894 
2895 static QueryFrame
unsweep_environments(LocalFrame fr)2896 unsweep_environments(LocalFrame fr)
2897 { while(fr->parent)
2898     fr = fr->parent;
2899 
2900   return queryOfFrame(fr);
2901 }
2902 
2903 
2904 static void
unsweep_stacks(vm_state * state ARG_LD)2905 unsweep_stacks(vm_state *state ARG_LD)
2906 { QueryFrame query;
2907   LocalFrame fr = state->frame;
2908   Choice ch = state->choice;
2909 
2910   for( ; fr; fr = query->saved_environment, ch = query->saved_bfr )
2911   { query = unsweep_environments(fr);
2912     unsweep_choicepoints(ch PASS_LD);
2913   }
2914 }
2915 
2916 
2917 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2918 Sweeping the local and trail stack to insert necessary pointers  in  the
2919 relocation chains.
2920 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2921 
2922 static void
sweep_trail(void)2923 sweep_trail(void)
2924 { GET_LD
2925   GCTrailEntry te = (GCTrailEntry)tTop - 1;
2926 
2927   for( ; te >= (GCTrailEntry)tBase; te-- )
2928   { if ( te->address )
2929     {
2930 #ifdef O_DESTRUCTIVE_ASSIGNMENT
2931       if ( ttag(te->address) == TAG_TRAILVAL )
2932       { needsRelocation(&te->address);
2933 	check_relocation(&te->address);
2934 	into_relocation_chain(&te->address, STG_TRAIL PASS_LD);
2935       } else
2936 #endif
2937       if ( storage(te->address) == STG_GLOBAL )
2938       { needsRelocation(&te->address);
2939 	check_relocation(&te->address);
2940 	into_relocation_chain(&te->address, STG_TRAIL PASS_LD);
2941       }
2942     }
2943   }
2944 }
2945 
2946 
2947 
2948 static void
sweep_frame(LocalFrame fr,int slots ARG_LD)2949 sweep_frame(LocalFrame fr, int slots ARG_LD)
2950 { Word sp;
2951 
2952   sp = argFrameP(fr, 0);
2953   for( ; slots > 0; slots--, sp++ )
2954   { if ( is_marked(sp) )
2955     { unmark(sp);
2956       if ( isGlobalRef(get_value(sp)) )
2957       { processLocal(sp);
2958 	check_relocation(sp);
2959 	into_relocation_chain(sp, STG_LOCAL PASS_LD);
2960       }
2961     } else
2962     { word w = *sp;
2963 
2964       if ( isGlobalRef(w) ||
2965 	   (isAtom(w) && is_volatile_atom(w)) )
2966       { DEBUG(MSG_GC_SWEEP, char b[64];
2967 	      Sdprintf("[%ld] %s: GC VAR(%d) (=%s)\n",
2968 		       levelFrame(fr), predicateName(fr->predicate),
2969 		       sp-argFrameP(fr, 0),
2970 		       print_val(w, b)));
2971 	*sp = ATOM_garbage_collected;
2972       }
2973     }
2974   }
2975 }
2976 
2977 
2978 static QueryFrame
sweep_environments(LocalFrame fr,Code PC)2979 sweep_environments(LocalFrame fr, Code PC)
2980 { GET_LD
2981 
2982   if ( !fr )
2983     return NULL;
2984 
2985   for( ; ; )
2986   { int slots;
2987 
2988     if ( false(fr, FR_MARKED) )
2989       return NULL;
2990     clear(fr, FR_MARKED);
2991 
2992     slots = slotsInFrame(fr, PC);
2993 
2994     DEBUG(MSG_GC_SWEEP,
2995 	  Sdprintf("Sweep %d arguments for [%d] %s\n",
2996 		   slots, levelFrame(fr), predicateName(fr->predicate)));
2997 
2998     sweep_frame(fr, slots PASS_LD);
2999 
3000     if ( fr->parent )
3001     { PC = fr->programPointer;
3002       fr = fr->parent;
3003     } else
3004     { QueryFrame qf = queryOfFrame(fr);
3005 
3006       return qf;
3007     }
3008   }
3009 }
3010 
3011 
3012 static void
sweep_choicepoints(Choice ch ARG_LD)3013 sweep_choicepoints(Choice ch ARG_LD)
3014 { for( ; ch ; ch = ch->parent)
3015   { sweep_environments(ch->frame,
3016 		       ch->type == CHP_JUMP ? ch->value.PC : NULL);
3017     sweep_mark(&ch->mark PASS_LD);
3018   }
3019 }
3020 
3021 
3022 static void
sweep_new_arguments(vm_state * state ARG_LD)3023 sweep_new_arguments(vm_state *state ARG_LD)
3024 { if ( state->lNext )
3025   { Word sp = argFrameP(state->lNext, 0);
3026     int slots = state->new_args;
3027 
3028     for( ; slots-- > 0; sp++ )
3029     { assert(is_marked(sp));
3030       unmark(sp);
3031       if ( isGlobalRef(get_value(sp)) )
3032       { processLocal(sp);
3033 	check_relocation(sp);
3034 	into_relocation_chain(sp, STG_LOCAL PASS_LD);
3035       }
3036     }
3037   }
3038 }
3039 
3040 
3041 static void
sweep_stacks(vm_state * state)3042 sweep_stacks(vm_state *state)
3043 { GET_LD
3044   LocalFrame fr = state->frame;
3045   Choice ch = state->choice;
3046   Code PC = state->pc_start_vmi;
3047 
3048   sweep_new_arguments(state PASS_LD);
3049 
3050   while( fr )
3051   { QueryFrame qf = sweep_environments(fr, PC);
3052     vm_state sub_state;
3053 
3054     assert(qf->magic == QID_MAGIC);
3055 
3056     sweep_choicepoints(ch PASS_LD);
3057     if ( qf->parent )
3058     { QueryFrame pqf = qf->parent;
3059 
3060       if ( (fr = pqf->registers.fr) )
3061       { get_vmi_state(pqf, &sub_state);
3062 	PC = sub_state.pc_start_vmi;
3063 	sweep_new_arguments(&sub_state PASS_LD);
3064       } else
3065       { fr = qf->saved_environment;
3066 	PC = NULL;
3067       }
3068       ch = qf->saved_bfr;
3069     } else
3070       break;
3071   }
3072 
3073   if ( local_marked != 0 )
3074   {
3075 #ifdef O_DEBUG
3076     if ( DEBUGGING(CHK_SECURE) )
3077     { TableEnum e = newTableEnum(local_table);
3078       Word addr;
3079 
3080       Sdprintf("FATAL: unprocessed local variables:\n");
3081 
3082       while( advanceTableEnum(e, (void**)&addr, NULL) )
3083       { char buf1[64];
3084 	char buf2[64];
3085 
3086 	Sdprintf("\t%s (*= %s)\n", print_addr(addr, buf1), print_val(*addr, buf2));
3087       }
3088 
3089       freeTableEnum(e);
3090     }
3091 #endif
3092     sysError("local_marked = %ld", local_marked);
3093   }
3094 }
3095 
3096 
3097 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3098 All preparations have been made now, and the actual  compacting  of  the
3099 global  stack  may  start.   The  marking phase has calculated the total
3100 number of words (cells) in the global stack that are non-garbage.
3101 
3102 In the first phase, we will  walk  along  the  global  stack  from  it's
3103 current  top towards the bottom.  During this phase, `current' refers to
3104 the current element we are processing, while `dest' refers to the  place
3105 this  element  will  be  after  the compacting phase is completed.  This
3106 invariant is central and should be maintained carefully while processing
3107 alien objects as strings and reals, which happen to have a  non-standard
3108 size.
3109 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3110 
3111 static bool
is_downward_ref(Word p ARG_LD)3112 is_downward_ref(Word p ARG_LD)
3113 { word val = get_value(p);
3114 
3115   switch(tag(val))
3116   { case TAG_INTEGER:
3117       if ( storage(val) == STG_INLINE )
3118 	fail;
3119     case TAG_ATTVAR:
3120     case TAG_STRING:
3121     case TAG_FLOAT:
3122     case TAG_REFERENCE:
3123     case TAG_COMPOUND:
3124     { Word d = val_ptr(val);
3125 
3126       DEBUG(CHK_SECURE, assert(d >= gBase));
3127 
3128       return d < p;
3129     }
3130   }
3131 
3132   fail;
3133 }
3134 
3135 
3136 static bool
is_upward_ref(Word p ARG_LD)3137 is_upward_ref(Word p ARG_LD)
3138 { word val = get_value(p);
3139 
3140   switch(tag(val))
3141   { case TAG_INTEGER:
3142       if ( storage(val) == STG_INLINE )
3143 	fail;
3144     case TAG_ATTVAR:
3145     case TAG_STRING:
3146     case TAG_FLOAT:
3147     case TAG_REFERENCE:
3148     case TAG_COMPOUND:
3149     { Word d = val_ptr(val);
3150 
3151       DEBUG(CHK_SECURE, assert(d < gTop));
3152 
3153       return d > p;
3154     }
3155   }
3156 
3157   fail;
3158 }
3159 
3160 
3161 #if O_DEBUG
3162 
3163 static int
check_marked(const char * s)3164 check_marked(const char *s)
3165 { GET_LD
3166   intptr_t m = 0;
3167   Word current;
3168   intptr_t cells = 0;
3169 
3170   for( current = gBase; current < gTop; current += (offset_cell(current)+1) )
3171   { cells++;
3172     if ( is_marked(current) )
3173     { m += (offset_cell(current)+1);
3174     }
3175   }
3176 
3177   if ( m == total_marked )
3178     return TRUE;
3179 
3180   if ( m != total_marked )
3181     Sdprintf("**** ERROR: size: %ld != %ld (%s) ****\n",
3182 	     m, total_marked, s);
3183 
3184   return FALSE;
3185 }
3186 
3187 #endif /* O_DEBUG */
3188 
3189 
3190 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3191 current points to the bottom of the  first garbage cell. Skip downwards,
3192 returning a pointer to the bottom of the   garbage  or the bottom of the
3193 global stack. If the found garbage  hole   is  big enough, create a cell
3194 that represents a large garbage string,  so   the  up-phase  can skip it
3195 quickly.
3196 
3197 Note that below the bottom of the stack   there  is a dummy marked cell.
3198 See also sweep_global_mark().
3199 
3200 It looks tempting to use the  down-references   in  GC-ed  areas left by
3201 sweep_global_mark(), but this does not work   because these cells can be
3202 inserted into new relocation chains while  sweeping the remainder of the
3203 data-areas :-( I tried, but this caused  a crash in Back52. After adding
3204 a check in into_relocation_chain() I discovered   that the above was the
3205 reason for the failure.
3206 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3207 
3208 static Word
downskip_combine_garbage(Word current,Word dest ARG_LD)3209 downskip_combine_garbage(Word current, Word dest ARG_LD)
3210 { Word top_gc = current + offset_cell(current);
3211 
3212   for(current-- ; ; current-- )
3213   { if ( (*current & (MARK_MASK|FIRST_MASK|STG_LOCAL)) )
3214     { if ( is_marked(current) )
3215       { DEBUG(MSG_GC_HOLE, Sdprintf("Normal-non-GC cell at %p\n", current));
3216 	return make_gc_hole(current+1, top_gc);
3217       } else if ( is_first(current) )
3218       { update_relocation_chain(current, dest PASS_LD);
3219       } else					/* large cell */
3220       { size_t offset;
3221 
3222 	DEBUG(CHK_SECURE, assert(storage(*current) == STG_LOCAL));
3223 	offset = wsizeofInd(*current)+1;	/* = offset for a large cell */
3224 	current -= offset;			/* start large cell */
3225 	if ( is_marked(current) )
3226 	{ DEBUG(MSG_GC_HOLE,
3227 		Sdprintf("Large-non-GC cell at %p, size %d\n",
3228 			 current, offset+1));
3229 	  return make_gc_hole(current+offset+1, top_gc);
3230 	} else if ( is_first(current) )
3231 	{ update_relocation_chain(current, dest PASS_LD);
3232 	}
3233       }
3234     }
3235   }
3236 
3237   return make_gc_hole(gBase, top_gc);
3238 }
3239 
3240 
3241 static void
compact_global(void)3242 compact_global(void)
3243 { GET_LD
3244   Word dest, current;
3245   Word base = gBase, top;
3246 #if O_DEBUG
3247   Word *v = mark_top;
3248 #endif
3249 
3250   DEBUG(MSG_GC_PROGRESS, Sdprintf("Scanning global stack downwards\n"));
3251 
3252   dest = base + total_marked;			/* first FREE cell */
3253   for( current = gTop; current >= base; current-- )
3254   { if ( is_marked(current) )
3255     { marked_large_cell:
3256       DEBUG(CHK_SECURE,
3257 	    { if ( current != *--v )
3258 		sysError("Marked cell at %p (*= %p); gTop = %p; should be %p",
3259 			 current, *current, gTop, *v);
3260 	    });
3261       dest--;
3262       DEBUG(MSG_GC_RELOC,
3263 	    Sdprintf("Marked cell at %p (dest = %p)\n", current, dest));
3264       if ( is_first(current) )
3265 	update_relocation_chain(current, dest PASS_LD);
3266       if ( is_downward_ref(current PASS_LD) )
3267       { check_relocation(current);
3268 	into_relocation_chain(current, STG_GLOBAL PASS_LD);
3269       }
3270     } else if ( is_first(current) )
3271     { first_large_cell:
3272       update_relocation_chain(current, dest PASS_LD);	/* gTop refs from marks */
3273     } else if ( storage(*current) == STG_LOCAL ) /* large cell */
3274     { size_t offset = offset_cell(current);
3275 
3276       assert(offset > 0);
3277       current -= offset;		/* start large cell */
3278       if ( is_marked(current) )
3279       { dest -= offset;
3280 	goto marked_large_cell;
3281       } else if ( is_first(current) )
3282       { goto first_large_cell;
3283       }	else
3284       { DEBUG(MSG_GC_HOLE, Sdprintf("Downskip from indirect\n"));
3285 	current = downskip_combine_garbage(current, dest PASS_LD);
3286       }
3287     } else
3288     { DEBUG(MSG_GC_HOLE, Sdprintf("Downskip from normal cell\n"));
3289       current = downskip_combine_garbage(current, dest PASS_LD);
3290     }
3291   }
3292 
3293   DEBUG(CHK_SECURE,
3294 	{ if ( v != mark_base )
3295 	  { for( v--; v >= mark_base; v-- )
3296 	    { Sdprintf("Expected marked cell at %p, (*= 0x%lx)\n", *v, **v);
3297 	    }
3298 	    sysError("v = %p; mark_base = %p", v, mark_base);
3299 	  }
3300 	});
3301 
3302   if ( dest != base )
3303     sysError("Mismatch in down phase: dest = %p, gBase = %p\n",
3304 	     dest, gBase);
3305   if ( relocation_cells != relocated_cells )
3306   { DEBUG(CHK_SECURE, printNotRelocated());
3307     sysError("After down phase: relocation_cells = %ld; relocated_cells = %ld",
3308 	     relocation_cells, relocated_cells);
3309   }
3310 
3311   DEBUG(CHK_SECURE, check_marked("Before up"));
3312   DEBUG(CHK_SECURE, relocated_check=FALSE);	/* see do_relocated_cell() */
3313   DEBUG(MSG_GC_PROGRESS, Sdprintf("Scanning global stack upwards\n"));
3314 
3315   dest = base;
3316   top = gTop;
3317   for(current = gBase; current < top; )
3318   { if ( is_marked(current) )
3319     { intptr_t l, n;
3320 
3321       if ( is_first(current) )
3322 	update_relocation_chain(current, dest PASS_LD);
3323 
3324       if ( (l = offset_cell(current)) == 0 )	/* normal cells */
3325       { *dest = *current;
3326         if ( is_upward_ref(current PASS_LD) )
3327 	{ check_relocation(current);
3328           into_relocation_chain(dest, STG_GLOBAL PASS_LD);
3329 	}
3330 	unmark(dest);
3331 	dest++;
3332 	current++;
3333       } else					/* indirect values */
3334       { Word cdest, ccurrent;
3335 
3336 	l++;
3337 
3338 	for( cdest=dest, ccurrent=current, n=0; n < l; n++ )
3339 	  *cdest++ = *ccurrent++;
3340 
3341 	unmark(dest);
3342 	dest += l;
3343 	current += l;
3344       }
3345 
3346     } else
3347     { DEBUG(MSG_GC_HOLE,
3348 	    if ( offset_cell(current) > 2 )
3349 	      Sdprintf("Skipping garbage cell %p..%p, size %d\n",
3350 		       current, current + offset_cell(current),
3351 		       offset_cell(current)-1));
3352       current += offset_cell(current) + 1;
3353     }
3354   }
3355 
3356   if ( dest != gBase + total_marked )
3357     sysError("Mismatch in up phase: dest = %p, gBase+total_marked = %p\n",
3358 	     dest, gBase + total_marked );
3359 
3360   DEBUG(CHK_SECURE,
3361 	{ Word p = dest;		/* clear top of stack */
3362 	  while(p < gTop)
3363 	    *p++ = 0xbfbfbfbfL;
3364 	});
3365 
3366   gTop = dest;
3367 }
3368 
3369 
3370 static void
collect_phase(vm_state * state,Word * saved_bar_at)3371 collect_phase(vm_state *state, Word *saved_bar_at)
3372 { GET_LD
3373 
3374   DEBUG(CHK_SECURE, check_marked("Start collect"));
3375 
3376   DEBUG(MSG_GC_PROGRESS, Sdprintf("Sweeping foreign references\n"));
3377   sweep_foreign();
3378   DEBUG(MSG_GC_PROGRESS, Sdprintf("Sweeping trail stack\n"));
3379   sweep_trail();
3380   DEBUG(MSG_GC_PROGRESS, Sdprintf("Sweeping local stack\n"));
3381   sweep_stacks(state);
3382   if ( saved_bar_at )
3383   { DEBUG(2, Sdprintf("Sweeping frozen bar\n"));
3384     sweep_global_mark(saved_bar_at PASS_LD);
3385   }
3386   DEBUG(MSG_GC_PROGRESS, Sdprintf("Compacting global stack\n"));
3387   compact_global();
3388 
3389   unsweep_foreign(PASS_LD1);
3390   unsweep_stacks(state PASS_LD);
3391 
3392   assert(marks_swept==marks_unswept);
3393   if ( relocation_chains != 0 )
3394     sysError("relocation chains = %ld", relocation_chains);
3395   if ( relocated_cells != relocation_cells ||
3396        relocated_cells != needs_relocation )
3397     sysError("relocation cells = %ld; relocated_cells = %ld, "
3398 	     "needs_relocation = %ld\n\t",
3399 	     relocation_cells, relocated_cells, needs_relocation);
3400 }
3401 
3402 		 /*******************************
3403 		 *	      VM-STATE		*
3404 		 *******************************/
3405 
3406 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3407 When using SAVE_REGISTERS(qid) in pl-vmi.c, the   PC  is either pointing
3408 inside or pointing to the next instruction.   Here, we find the start of
3409 the instruction for SHIFT/GC. We assume that   if  this is a first-write
3410 instruction,  the  writing  has  not  yet  been    done.   If  it  is  a
3411 read-instruction,  we  often  have  to  be  able  to  redo  the  read to
3412 compensate  for  the  possible  shift  inside   the  code  protected  by
3413 SAVE_REGISTERS().
3414 
3415 The situation is more complicated. We need to know the depth in which we
3416 are in *_functor...i_pop sequences. We always need to mark all arguments
3417 of the first frame (well, this can be more subtle, but I really doubt we
3418 want to try).
3419 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3420 
3421 
3422 static void
setStartOfVMI(vm_state * state)3423 setStartOfVMI(vm_state *state)
3424 { LocalFrame fr = state->frame;
3425 
3426   if ( fr->clause && false(fr->predicate, P_FOREIGN) && state->pc )
3427   { Clause clause = fr->clause->value.clause;
3428     Code PC, ep, next;
3429 
3430     if ( fr->predicate == PROCEDURE_dcall1->definition )
3431       state->in_body = TRUE;		/* There is no head code */
3432 
3433     PC = clause->codes;
3434     ep = PC + clause->code_size;
3435 
3436     for( ; PC < ep; PC = next )
3437     { code op;
3438 
3439       next = stepPC(PC);
3440 
3441       if ( next >= state->pc )
3442       {
3443 #ifdef O_DEBUG
3444         size_t where  = PC - clause->codes;
3445 	size_t where0 = state->pc - clause->codes;
3446 
3447 	{ GET_LD
3448 	  if ( truePrologFlag(PLFLAG_TRACE_GC) )
3449 	  { Sdprintf("At PC=%ld(%ld) of "
3450 		     "%d-th clause of %s (ARGP=%d; adepth=%d)\n",
3451 		     where, where0,
3452 		     clauseNo(clause, 0),
3453 		     predicateName(fr->predicate),
3454 		     (state->argp - argFrameP(fr, 0)),
3455 		     state->adepth);
3456 	  }
3457 	}
3458 #endif
3459 
3460 	state->pc_start_vmi = PC;
3461 	return;
3462       }
3463 
3464       op = fetchop(PC);
3465       switch(op)
3466       { case H_STRING:
3467 	case H_MPZ:
3468 	case H_LIST_FF:
3469 	case H_FIRSTVAR:
3470 	case H_VAR:
3471 	case H_ATOM:
3472 	case H_SMALLINT:
3473 	case H_NIL:
3474 	case H_INTEGER:
3475 	case H_INT64:
3476 	case H_FLOAT:
3477 	case H_VOID:
3478 	  if ( state->adepth == 0 )
3479 	    state->argp++;
3480 	  break;
3481 	case H_VOID_N:
3482 	  if ( state->adepth == 0 )
3483 	    state->argp += PC[1];
3484 	  break;
3485 
3486 	case B_UNIFY_VAR:
3487 	case B_UNIFY_FIRSTVAR:
3488 	  state->argp = varFrameP(state->frame, PC[1]);
3489 	  assert(state->adepth == 0);
3490 	  break;
3491 	case H_FUNCTOR:
3492 	case H_LIST:
3493 	  if ( state->adepth == 0 )
3494 	    state->argp0 = state->argp++;
3495 	  /*FALLTHROUGH*/
3496 	case B_FUNCTOR:
3497 	case B_LIST:
3498 	  state->adepth++;
3499 	  break;
3500 	case H_POP:
3501 	case B_POP:
3502 	  if ( --state->adepth == 0 )
3503 	    state->argp0 = NULL;
3504 	  break;
3505 	case B_UNIFY_EXIT:
3506 	  assert(state->adepth == 0);
3507 	  break;
3508 	case I_ENTER:
3509 	  state->in_body = TRUE;
3510 	  assert(state->adepth==0);
3511       }
3512     }
3513   }
3514 
3515   state->pc_start_vmi = NULL;
3516 }
3517 
3518 
3519 #if O_DEBUG || defined(O_MAINTENANCE)
3520 static Code
startOfVMI(QueryFrame qf)3521 startOfVMI(QueryFrame qf)
3522 { vm_state state;
3523 
3524   state.frame  = qf->registers.fr;
3525   state.adepth = 0;
3526   state.argp   = argFrameP(state.frame, 0);
3527   state.argp0  = NULL;
3528   state.pc     = qf->registers.pc;
3529 
3530   setStartOfVMI(&state);
3531 
3532   return state.pc_start_vmi;
3533 }
3534 #endif
3535 
3536 
3537 static void
get_vmi_state(QueryFrame qf,vm_state * state)3538 get_vmi_state(QueryFrame qf, vm_state *state)
3539 { GET_LD
3540 
3541   state->choice	     = LD->choicepoints;
3542   state->lSave	     = lTop;
3543   state->in_body     = FALSE;
3544   state->adepth	     = 0;
3545   state->new_args    = 0;
3546   state->lNext       = NULL;
3547 
3548   if ( qf && qf->registers.fr )
3549   { LocalFrame qlTop;
3550 
3551     state->frame     = qf->registers.fr;
3552 
3553     if ( qf->next_environment )
3554       qlTop = qf->next_environment;
3555     else
3556       qlTop = lTop;
3557 
3558     if ( qlTop <= state->frame )
3559     { int arity = state->frame->predicate->functor->arity;
3560       qlTop = (LocalFrame)argFrameP(state->frame, arity);
3561       assert(!state->frame->clause);
3562     }
3563 
3564     state->argp		= argFrameP(state->frame, 0);
3565     state->argp0	= NULL;
3566     state->pc           = qf->registers.pc;
3567     state->save_argp    = (state->frame->clause != NULL);
3568     setStartOfVMI(state);
3569 
3570     if ( state->in_body )
3571     { Word ap = qf->registers.argp;
3572       Word *at = aTop;
3573       Word *ab = qf->aSave;
3574 
3575       for(;;)
3576       { if ( ap > (Word)lBase )
3577 	{ assert(ap >= argFrameP(state->frame, 0));
3578 
3579 	  if ( ap > argFrameP(qlTop, 0) )
3580 	  { state->new_args = (int)(ap - argFrameP(qlTop, 0));
3581 	    state->lNext = qlTop;
3582 	    if ( (LocalFrame)ap > lTop )
3583 	      lTop = (LocalFrame)ap;
3584 	  }
3585 	  break;
3586 	}
3587 	if ( at > ab )
3588 	{ uintptr_t uwrite = 0x1;	/* TBD: Share with def in pl-wam.c */
3589 	  ap = *--at;
3590 	  ap = (Word)((intptr_t)ap&~uwrite); /* see H_POP */
3591 	} else
3592 	  break;
3593       }
3594     }
3595   } else
3596   { state->frame        = environment_frame;
3597     state->pc           = NULL;
3598     state->pc_start_vmi = NULL;
3599     state->save_argp	= FALSE;
3600     if ( state->frame)
3601       state->argp       = argFrameP(state->frame, 0);
3602   }
3603 }
3604 
3605 
3606 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3607 Note that we need to restore lTop if   we  are called from the body mode
3608 because lTop is pointing to the new stack frame.
3609 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3610 
3611 static void
restore_vmi_state(vm_state * state)3612 restore_vmi_state(vm_state *state)
3613 { GET_LD
3614 
3615   lTop = state->lSave;
3616 }
3617 
3618 
3619 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3620 Used in D_BREAK to safely set lTop,  so the debugger won't overwrite the
3621 stack-frame.
3622 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3623 
3624 void
setLTopInBody(void)3625 setLTopInBody(void)
3626 { GET_LD
3627   vm_state state;
3628 
3629   get_vmi_state(LD->query, &state);
3630 }
3631 
3632 
3633 		/********************************
3634 		*	    GC's MAIN           *
3635 		*********************************/
3636 
3637 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3638 If s == NULL, consider all stacks
3639 
3640 (*) Do not  consider  GC  if  there   are  no  inferences.  This  avoids
3641 repetetive GC calls while building large   structures  from foreign code
3642 that calls PL_handle_signals() from time to   time  to enable interrupts
3643 and call GC.
3644 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3645 
3646 int
considerGarbageCollect(Stack s)3647 considerGarbageCollect(Stack s)
3648 { GET_LD
3649 
3650   if ( truePrologFlag(PLFLAG_GC) )
3651   { if ( PL_pending(SIG_GC) )
3652       return TRUE;
3653 
3654     if ( s == NULL || s == &GD->combined_stack )
3655     { return (considerGarbageCollect((Stack)&LD->stacks.global) ||
3656 	      considerGarbageCollect((Stack)&LD->stacks.trail));
3657     } else
3658     { if ( s->gc )
3659       { size_t used  = usedStackP(s);	/* amount in actual use */
3660 	size_t limit = sizeStackP(&GD->combined_stack) - usedStack(local);
3661 	size_t space = limit > used ? limit - used : 0;
3662 	size_t low   = usedStack(local) + s->small;
3663 
3664 	if ( s == (Stack)&LD->stacks.global )
3665 	  low += usedStack(trail);
3666 	else
3667 	  low += usedStack(global)/8;
3668 
3669 	if ( LD->gc.inferences == LD->statistics.inferences &&
3670 	     !LD->exception.processing )
3671 	{ s->gced_size = used;		/* (*) */
3672 	  return FALSE;
3673 	}
3674 
3675 	if ( used > s->factor*s->gced_size + low )
3676 	{ DEBUG(MSG_GC_SCHEDULE,
3677 		Sdprintf("GC: request on %s "
3678 			 "(used=%zd, factor=%d, gced_size=%zd, low=%zd)\n",
3679 			 s->name, used, s->factor, s->gced_size, s->small));
3680 	} else if ( space < limit/8 &&
3681 		    used > s->gced_size + limit/32 )
3682 	{ DEBUG(MSG_GC_SCHEDULE,
3683 		Sdprintf("GC: request for %s on low space "
3684 			 "(used=%zd, limit=%zd, gced_size=%zd)\n",
3685 			 s->name, used, limit, s->gced_size));
3686 	} else
3687 	  return FALSE;
3688 
3689 	LD->gc.stats.request = (s == (Stack)&LD->stacks.global ?
3690 				GC_GLOBAL_REQUEST : GC_TRAIL_REQUEST);
3691 
3692 	return PL_raise(SIG_GC);
3693       }
3694     }
3695   }
3696 
3697   return FALSE;
3698 }
3699 
3700 void
call_tune_gc_hook(void)3701 call_tune_gc_hook(void)
3702 { Procedure proc = PROCEDURE_tune_gc3;
3703 
3704   if ( isDefinedProcedure(proc) )
3705   { GET_LD
3706     fid_t fid;
3707 
3708     if ( (fid = PL_open_foreign_frame()) )
3709     { term_t av = PL_new_term_refs(3);
3710       gc_stats *stats = &LD->gc.stats;
3711       gc_stat *last   = last_gc_stats(stats);
3712       gc_stat *aggr   = &stats->aggr[STAT_PREV_INDEX(stats->aggr_index)];
3713 
3714       if ( PL_unify_float(av+0, last->gc_time) &&
3715 	   PL_unify_float(av+1, gc_percentage(last)) &&
3716 	   PL_unify_float(av+2, gc_percentage(aggr)) )
3717 	PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION, proc, av);
3718 
3719       PL_close_foreign_frame(fid);
3720     }
3721   }
3722 }
3723 
3724 
3725 #if O_DEBUG || defined(O_MAINTENANCE)
3726 #define INTBITS (sizeof(int)*8)
3727 #define REGISTER_STARTS 0x2
3728 
3729 #if O_DEBUG
3730 static void
alloc_start_map()3731 alloc_start_map()
3732 { GET_LD
3733   size_t gsize = gTop+1-gBase;
3734   size_t ints = (gsize+INTBITS-1)/INTBITS;
3735 
3736   start_map = malloc(ints*sizeof(int));
3737   memset(start_map, 0, ints*sizeof(int));
3738 }
3739 #endif
3740 
3741 static void
set_start(Word m ARG_LD)3742 set_start(Word m ARG_LD)
3743 { size_t i = m-gBase;
3744   int bit = i % INTBITS;
3745   size_t at  = i / INTBITS;
3746 
3747   start_map[at] |= 1<<(bit-1);
3748 }
3749 
3750 
3751 static int
is_start(Word m ARG_LD)3752 is_start(Word m ARG_LD)
3753 { size_t i = m-gBase;
3754   int bit = i % INTBITS;
3755   size_t at  = i / INTBITS;
3756 
3757   return (start_map[at] & 1<<(bit-1)) != 0;
3758 }
3759 
3760 
3761 bool
scan_global(int flags)3762 scan_global(int flags)
3763 { GET_LD
3764   Word current, next;
3765   int errors = 0;
3766   intptr_t cells = 0;
3767   int marked = (flags & TRUE);
3768   int regstart = start_map && (flags & REGISTER_STARTS) != 0;
3769 
3770   for( current = gBase; current < gTop; current += (offset_cell(current)+1) )
3771   { size_t offset;
3772 
3773     if ( regstart )
3774       set_start(current PASS_LD);
3775     cells++;
3776 
3777     if ( tagex(*current) == (TAG_VAR|STG_RESERVED) )
3778       Sdprintf("read varref at %p\n", current);
3779 
3780     if ( (!marked && is_marked(current)) || is_first(current) )
3781     { char pbuf[256];
3782       char vbuf[256];
3783 
3784       Sdprintf("!Illegal cell in global stack (up) at %s (*= %s)\n",
3785 	       print_addr(current, pbuf), print_val(*current, vbuf));
3786       trap_gdb();
3787 
3788       if ( ++errors > 10 )
3789       { Sdprintf("...\n");
3790         break;
3791       }
3792     }
3793 
3794     offset = offset_cell(current);
3795     next = current+offset+1;
3796     if ( offset > 0 )
3797     { if ( offset_cell(next-1) != offset )
3798       { errors++;
3799 	Sdprintf("ERROR: Illegal indirect cell on global stack at %p-%p\n"
3800 		 "       tag=%d, offset=%ld\n",
3801 		 current, next, tag(*current), (long)offset);
3802 	trap_gdb();
3803       }
3804     } else if ( !marked )
3805     { if ( isRef(*current) )
3806       { if ( !onStack(global, unRef(*current)) )
3807 	{ char b1[64], b2[64];
3808 
3809 	  Sdprintf("ERROR: ref at %s not on global (*=%s)\n",
3810 		   print_addr(current, b1), print_val(*current, b2));
3811 	  trap_gdb();
3812 	}
3813       }
3814     }
3815   }
3816   if ( regstart )
3817     set_start(gTop PASS_LD);
3818 
3819   for( current = gTop - 1; current >= gBase; current-- )
3820   { cells--;
3821     current -= offset_cell(current);
3822     if ( (!marked && is_marked(current)) || is_first(current) )
3823     { Sdprintf("!Illegal cell in global stack (down) at %p (*= %p)\n",
3824 	       current, *current);
3825       if ( ++errors > 10 )
3826       { Sdprintf("...\n");
3827         break;
3828       }
3829     }
3830   }
3831 
3832   if ( !errors && cells != 0 )
3833     sysError("Different count of cells upwards and downwards: %ld\n", cells);
3834 
3835   return errors == 0;
3836 }
3837 
3838 
3839 static void
check_mark(mark * m)3840 check_mark(mark *m)
3841 { GET_LD
3842 
3843   assert(onTrailArea(m->trailtop));
3844   assert(onGlobalArea(m->globaltop));
3845   assert(onGlobalArea(m->saved_bar));
3846   assert(m->saved_bar <= m->globaltop);
3847   if ( start_map )
3848   { assert(is_start(m->globaltop PASS_LD));
3849     assert(is_start(m->saved_bar PASS_LD));
3850   }
3851 }
3852 
3853 
3854 static QueryFrame
check_environments(LocalFrame fr,Code PC,Word key)3855 check_environments(LocalFrame fr, Code PC, Word key)
3856 { GET_LD
3857 
3858   if ( fr == NULL )
3859     return NULL;
3860 
3861   assert(wasFrame(fr));
3862 
3863   for(;;)
3864   { int slots, n;
3865     Word sp;
3866 
3867     if ( true(fr, FR_MARKED) )
3868       return NULL;			/* from choicepoints only */
3869     set(fr, FR_MARKED);
3870     local_frames++;
3871     clearUninitialisedVarsFrame(fr, PC);
3872 
3873     assert(onStack(local, fr));
3874 
3875     DEBUG(MSG_GC_CHECK,
3876 	  Sdprintf("Check [%ld] %s (PC=%d):",
3877 		   levelFrame(fr),
3878 		   predicateName(fr->predicate),
3879 		   (false(fr->predicate, P_FOREIGN) && PC)
3880 		   ? (PC-fr->clause->value.clause->codes)
3881 		   : 0));
3882 
3883     slots = slotsInFrame(fr, PC);
3884     sp = argFrameP(fr, 0);
3885     for( n=0; n < slots; n++ )
3886     { *key += checkData(&sp[n]);
3887     }
3888     DEBUG(MSG_GC_CHECK, Sdprintf(" 0x%lx\n", key));
3889 
3890     PC = fr->programPointer;
3891     if ( fr->parent )
3892       fr = fr->parent;
3893     else
3894     { QueryFrame qf = queryOfFrame(fr);
3895       DEBUG(MSG_GC_CHECK,
3896 	    Sdprintf("*** Query %s\n", predicateName(qf->frame.predicate)));
3897       return qf;
3898     }
3899   }
3900 }
3901 
3902 
3903 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3904 Unfortunately the key returned by check_choicepoints() is not constant
3905 due to `early reset' optimisation.
3906 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3907 
3908 static word
check_choicepoints(Choice ch)3909 check_choicepoints(Choice ch)
3910 { GET_LD
3911   word key = 0L;
3912 
3913   for( ; ch; ch = ch->parent )
3914   { if ( !ch->parent )
3915       assert(ch->type == CHP_TOP);
3916     choice_count++;
3917     check_mark(&ch->mark);
3918     check_environments(ch->frame,
3919 		       ch->type == CHP_JUMP ? ch->value.PC : NULL,
3920 		       &key);
3921   }
3922 
3923   return key;
3924 }
3925 
3926 
3927 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3928 (*) argument_stack_to_term_refs() uses TAG_ATTVAR
3929 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3930 
3931 word
check_foreign(void)3932 check_foreign(void)
3933 { GET_LD
3934   FliFrame ff;
3935   word key = 0L;
3936 
3937   for(ff = fli_context; ff; ff = ff->parent )
3938   { Word sp = refFliP(ff, 0);
3939     int n = ff->size;
3940 
3941     assert(ff->magic == FLI_MAGIC);
3942     if ( ff->parent )
3943     { assert(ff->parent < ff);
3944       assert(onStack(local, ff->parent));
3945     }
3946 
3947     for(n=0 ; n < ff->size; n++ )
3948       key += checkDataEx(&sp[n], CHK_DATA_NOATTVAR_CHAIN); /* see (*) */
3949 
3950     if ( isRealMark(ff->mark) )
3951       check_mark(&ff->mark);
3952   }
3953 
3954   return key;
3955 }
3956 
3957 
3958 #ifdef O_DESTRUCTIVE_ASSIGNMENT
3959 static word
check_trail(void)3960 check_trail(void)
3961 { GET_LD
3962   TrailEntry te = tTop - 1;
3963   word key = 0;
3964 
3965   for( ; te >= tBase; te-- )
3966   { Word gp;
3967 
3968     if ( isTrailVal(te->address) )
3969     { gp = trailValP(te->address);
3970 
3971       assert(onGlobal(gp));
3972       key += checkDataEx(gp, CHK_DATA_NOATTVAR_CHAIN);
3973       assert(te > tBase);
3974       te--;
3975       assert(!isTrailVal(te->address));
3976 #ifdef O_DEBUG
3977     } else if ( DEBUGGING(CHK_SECURE) )
3978     { if ( onGlobalArea(te->address) )
3979       { if ( !onStack(global, te->address) )
3980 	{ char b1[64], b2[64], b3[64];
3981 
3982 	  Sdprintf("Trail entry at %s not on global stack: %s (*=%s)\n",
3983 		   print_addr((Word)te, b1),
3984 		   print_addr(te->address, b2),
3985 		   print_val(*te->address, b3));
3986 	}
3987       }
3988 #endif
3989     }
3990   }
3991 
3992   return key;
3993 }
3994 #endif /*O_DESTRUCTIVE_ASSIGNMENT*/
3995 
3996 
3997 static word
check_new_arguments(vm_state * state)3998 check_new_arguments(vm_state *state)
3999 { word key = 0L;
4000 
4001   if ( state->lNext )
4002   { Word sp = argFrameP(state->lNext, 0);
4003     int slots = state->new_args;
4004 
4005     for( ; slots-- > 0; sp++ )
4006       key += checkData(sp);
4007   }
4008 
4009   return key;
4010 }
4011 
4012 #define HAVE_CHECK_STACKS 1
4013 
4014 word
checkStacks(void * state_ptr)4015 checkStacks(void *state_ptr)
4016 { GET_LD
4017   LocalFrame fr;
4018   Choice ch;
4019   QueryFrame qf;
4020   Code PC;
4021   word key = 0L;
4022   vm_state state_buf;
4023   vm_state *state;
4024 
4025   if ( state_ptr )
4026   { state = state_ptr;
4027   } else
4028   { state = &state_buf;
4029     get_vmi_state(LD->query, state);
4030   }
4031 
4032   assert(scan_global(FALSE));
4033   if ( LD->attvar.attvars )
4034     checkData(LD->attvar.attvars);
4035 
4036   local_frames = 0;
4037   choice_count = 0;
4038 
4039   key += check_new_arguments(state);
4040   fr = state->frame;
4041   ch = state->choice;
4042   PC = state->pc_start_vmi;
4043   while(fr)
4044   { qf = check_environments(fr, PC, &key);
4045     assert(qf->magic == QID_MAGIC);
4046 
4047     DEBUG(MSG_GC_CHECK, Sdprintf("%ld\n", key));
4048     check_choicepoints(ch);		/* Do not update key; see above */
4049     if ( qf->parent )			/* same code in mark_stacks() */
4050     { QueryFrame pqf = qf->parent;
4051 
4052       assert(pqf->magic == QID_MAGIC);
4053       if ( (fr = pqf->registers.fr) )
4054       { PC = startOfVMI(pqf);
4055       } else
4056       { fr = qf->saved_environment;
4057 	PC = NULL;
4058       }
4059       ch = qf->saved_bfr;
4060     } else
4061       break;
4062   }
4063 
4064   DEBUG(CHK_SECURE, trailtops_marked = choice_count);
4065 
4066   unmark_stacks(LD, state->frame, state->choice, FR_MARKED);
4067 
4068   assert(local_frames == 0);
4069   assert(choice_count == 0);
4070 
4071   key += check_foreign();
4072   DEBUG(MSG_GC_CHECK, Sdprintf("Foreign: %ld\n", key));
4073 #ifdef O_DESTRUCTIVE_ASSIGNMENT
4074   /*key +=*/ check_trail();
4075 #endif
4076 
4077   if ( state == &state_buf )
4078     restore_vmi_state(state);
4079 
4080   DEBUG(MSG_GC_CHECK, Sdprintf("Final: %ld\n", key));
4081   return key;
4082 }
4083 
4084 
4085 static
4086 PRED_IMPL("$check_stacks", 1, check_stacks, 0)
4087 { char *s = NULL;
4088 
4089   if ( PL_get_atom_chars(A1, &s) )
4090     Sdprintf("[thread %d] Checking stacks [%s] ...",
4091 	     PL_thread_self(), s);
4092 
4093   checkStacks(NULL);
4094   if ( s )
4095      Sdprintf(" (done)\n");
4096 
4097   succeed;
4098 }
4099 
4100 #endif /* O_DEBUG */
4101 
4102 int
PL_check_stacks(void)4103 PL_check_stacks(void)
4104 {
4105 #ifdef HAVE_CHECK_STACKS
4106   (void)checkStacks(NULL);
4107   return TRUE;
4108 #else
4109   return FALSE;
4110 #endif
4111 }
4112 
4113 
4114 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4115 About synchronisation with atom-gc (AGC). GC can run fully concurrent in
4116 different threads as it only  affects   the  runtime stacks. AGC however
4117 must sweep the other threads. It can only do so if these are in a fairly
4118 sane   state,   which   isn't   the   case    during   GC.   The   mutex
4119 LD->thread.scan_lock is used to avoid GC during AGC.
4120 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4121 
4122 static void
enterGC(ARG1_LD)4123 enterGC(ARG1_LD)
4124 {
4125 #ifdef O_PLMT
4126   if ( !LD->gc.active )
4127     simpleMutexLock(&LD->thread.scan_lock);
4128   LD->gc.active++;
4129 #endif
4130 }
4131 
4132 static void
leaveGC(ARG1_LD)4133 leaveGC(ARG1_LD)
4134 {
4135 #ifdef O_PLMT
4136   if ( --LD->gc.active == 0 )
4137     simpleMutexUnlock(&LD->thread.scan_lock);
4138 #endif
4139 }
4140 
4141 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4142 Returns: < 0: (local) overflow; TRUE: ok; FALSE: shifted;
4143 
4144 If gcEnsureSpace() returns overflow or out-of-stack, it has restored the
4145 given vm-state.
4146 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4147 
4148 static int
gcEnsureSpace(vm_state * state ARG_LD)4149 gcEnsureSpace(vm_state *state ARG_LD)
4150 { int rc = TRUE;
4151   size_t lneeded = 0;
4152 
4153   if ( LD->gvar.grefs )
4154     lneeded += sizeof(struct fliFrame) + LD->gvar.grefs*sizeof(word);
4155   if ( LD->frozen_bar )
4156     lneeded += sizeof(Word);
4157   if ( state->save_argp )
4158     lneeded += sizeof(struct fliFrame) + (aTop+1-aBase)*sizeof(word);
4159   if ( LD->attvar.call_residue_vars_count && LD->attvar.attvars )
4160   { size_t protect = count_need_protection_attvars(PASS_LD1);
4161     lneeded += sizeof(struct fliFrame) + protect*sizeof(word);
4162   }
4163 
4164   if ( (char*)lTop + lneeded > (char*)lMax )
4165   { if ( (char*)lTop + lneeded > (char*)lMax + LD->stacks.local.spare )
4166     { int rc2;
4167 
4168       restore_vmi_state(state);
4169       if ( (rc2=growLocalSpace__LD(lneeded, ALLOW_SHIFT PASS_LD)) != TRUE )
4170 	return rc2;
4171       rc = FALSE;
4172     } else
4173     { enableSpareStack((Stack)&LD->stacks.local, TRUE);
4174     }
4175   }
4176 
4177   return rc;
4178 }
4179 
4180 
4181 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4182 garbageCollect() returns one of TRUE (ok),   FALSE (blocked or exception
4183 in printMessage()) or *_OVERFLOW if the   local  stack cannot accomodate
4184 the term-references for saving ARGP and   global variables or the stacks
4185 remain too tight after running GC and  the stacks cannot be extended due
4186 to the stack_limit.
4187 
4188 (*) We call trimStacks()  to  reactivate   the  `spare  stacks'  and, if
4189 LD->trim_stack_requested is TRUE, to shrink the  stacks (this happens at
4190 the end of  handling  a  stack  overflow   exception).  This  is  a  bit
4191 complicated:
4192 
4193   - We must call trimStacks() after unblockGC(), otherwise the stacks
4194     cannot be shifted.
4195   - We must include ARGP in lTop when in `body' mode.  To do this, we
4196     save the value computed by get_vmi_state(). We cannot use
4197     get_vmi_state()/restore_vmi_state() because these do not anticipate
4198     a stack shift.
4199   - We must do unblockSignals() afterwards to avoid signal handling to
4200     mess with the computed stack values.
4201 
4202 Thanks to Keri Harris for figuring out why   we must include ARGP in our
4203 lTop.
4204 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4205 
4206 int
garbageCollect(gc_reason_t reason)4207 garbageCollect(gc_reason_t reason)
4208 { GET_LD
4209   vm_state state;
4210   LocalFrame safeLTop;			/* include ARGP in body mode */
4211   term_t preShiftLTop;			/* safe over trimStacks() (shift) */
4212   int verbose = truePrologFlag(PLFLAG_TRACE_GC) && !LD->in_print_message;
4213   int no_mark_bar;
4214   int rc;
4215   fid_t gvars, astack, attvars;
4216   Word *saved_bar_at;
4217 #ifdef O_PROFILE
4218   struct call_node *prof_node = NULL;
4219 #endif
4220   gc_stat *stats;
4221 
4222   END_PROF();
4223   START_PROF(P_GC, "P_GC");
4224 
4225   if ( gc_status.blocked || !truePrologFlag(PLFLAG_GC) )
4226     return FALSE;
4227 
4228   gc_stat_start(&LD->gc.stats, reason PASS_LD);
4229 
4230   assert(LD->fast_condition == NULL);
4231 
4232 #ifdef O_MAINTENANCE
4233   save_backtrace("GC");
4234 #endif
4235 
4236   if ( verbose )
4237     Sdprintf("%% GC: ");
4238 
4239   get_vmi_state(LD->query, &state);
4240   safeLTop = lTop;
4241   if ( (rc=gcEnsureSpace(&state PASS_LD)) < 0 )
4242   { return rc;
4243   } else if ( rc == FALSE )		/* shifted; reload */
4244   { get_vmi_state(LD->query, &state);
4245   }
4246 
4247   enterGC(PASS_LD1);
4248 #ifndef UNBLOCKED_GC
4249   blockSignals(&LD->gc.saved_sigmask);
4250 #endif
4251   blockGC(0 PASS_LD);			/* avoid recursion due to */
4252   PL_clearsig(SIG_GC);
4253 
4254   gc_status.active = TRUE;
4255 
4256   if ( (no_mark_bar=(LD->mark_bar == NO_MARK_BAR)) )
4257     LD->mark_bar = gTop;		/* otherwise we cannot relocate */
4258 
4259 #ifdef O_PROFILE
4260   if ( LD->profile.active )
4261     prof_node = profCall(GD->procedures.dgarbage_collect1->definition PASS_LD);
4262 #endif
4263 
4264 #if O_DEBUG
4265   if ( DEBUGGING(CHK_SECURE) )
4266   { alloc_start_map();
4267     if ( !scan_global(FALSE|REGISTER_STARTS) )
4268       sysError("Stack not ok at gc entry");
4269     checkStacks(&state);
4270     free(start_map);
4271     start_map = NULL;
4272 
4273     if ( check_table == NULL )
4274     { check_table = newHTable(256);
4275       local_table = newHTable(256);
4276     } else
4277     { clearHTable(check_table);
4278       clearHTable(local_table);
4279     }
4280 
4281     mark_base = mark_top = malloc(usedStack(global));
4282     relocated_check = TRUE;
4283   }
4284 #endif
4285 
4286   needs_relocation  = 0;
4287   relocation_chains = 0;
4288   relocation_cells  = 0;
4289   relocated_cells   = 0;
4290   local_marked	    = 0;
4291   marks_swept	    = 0;
4292   marks_unswept	    = 0;
4293   LD->gc.marked_attvars = FALSE;
4294 
4295   setVar(*gTop);	/* always one space; see initPrologStacks() */
4296   tTop->address = 0;	/* gMax-- and tMax-- */
4297 
4298   attvars = link_attvars(PASS_LD1);
4299   astack = argument_stack_to_term_refs(&state);
4300   gvars = gvars_to_term_refs(&saved_bar_at);
4301   save_grefs(PASS_LD1);
4302   DEBUG(CHK_SECURE, check_foreign());
4303   tag_trail(PASS_LD1);
4304   mark_phase(&state);
4305 
4306   DEBUG(MSG_GC_PROGRESS, Sdprintf("Compacting trail\n"));
4307   compact_trail();
4308   collect_phase(&state, saved_bar_at);
4309   restore_grefs(PASS_LD1);
4310   untag_trail(PASS_LD1);
4311   clean_attvar_chain(PASS_LD1);
4312 
4313   term_refs_to_gvars(gvars, saved_bar_at);
4314   term_refs_to_argument_stack(&state, astack);
4315   restore_attvars(attvars PASS_LD);
4316 
4317   assert(LD->mark_bar <= gTop);
4318 
4319   DEBUG(CHK_SECURE,
4320 	{ assert(trailtops_marked == 0);
4321 	  if ( !scan_global(FALSE) )
4322 	    sysError("Stack not ok after gc; gTop = %p", gTop);
4323 	  free(mark_base);
4324 	});
4325 
4326   DEBUG(CHK_SECURE,
4327 	{ memset(gTop, 0xFB, (char*)gMax-(char*)gTop);
4328 	  memset(tTop, 0xFB, (char*)tMax-(char*)tTop);
4329 	  checkStacks(&state);
4330 	});
4331 
4332 #ifdef O_PROFILE
4333   if ( prof_node && LD->profile.active )
4334     profExit(prof_node PASS_LD);
4335 #endif
4336 
4337   restore_vmi_state(&state);
4338   assert(!LD->query ||
4339 	 !LD->query->registers.fr ||
4340 	 state.frame == LD->query->registers.fr);
4341   if ( no_mark_bar )
4342     LD->mark_bar = NO_MARK_BAR;
4343   gc_status.active = FALSE;
4344   unblockGC(0 PASS_LD);
4345   LD->gc.inferences = LD->statistics.inferences;
4346 
4347   preShiftLTop = consTermRef(lTop);		/* see (*) above */
4348   lTop = safeLTop;
4349   trimStacks(LD->trim_stack_requested PASS_LD);
4350   lTop = (LocalFrame)valTermRef(preShiftLTop);
4351 
4352 #ifndef UNBLOCKED_GC
4353   unblockSignals(&LD->gc.saved_sigmask);
4354 #endif
4355   leaveGC(PASS_LD1);
4356 
4357   stats = gc_stat_end(&LD->gc.stats PASS_LD);
4358 
4359   if ( verbose )
4360     Sdprintf("gained (g+t) %zd+%zd in %.3f sec; used %zd+%zd; free %zd+%zd\n",
4361 	     stats->global_before - stats->global_after,
4362 	     stats->trail_before  - stats->trail_after,
4363 	     stats->gc_time,
4364 	     stats->global_after, stats->trail_after,
4365 	     roomStack(global), roomStack(trail));
4366 
4367   return shiftTightStacks();
4368 }
4369 
4370 word
pl_garbage_collect(term_t d)4371 pl_garbage_collect(term_t d)
4372 {
4373 #if O_DEBUG
4374   int ol = GD->debug_level;
4375   int nl;
4376 
4377   if ( d )
4378   { if ( !PL_get_integer_ex(d, &nl) )
4379       fail;
4380     GD->debug_level = nl;
4381   }
4382 #endif
4383   garbageCollect(GC_USER);
4384 #if O_DEBUG
4385   GD->debug_level = ol;
4386 #endif
4387   succeed;
4388 }
4389 
4390 
4391 void
blockGC(int flags ARG_LD)4392 blockGC(int flags ARG_LD)
4393 { if ( !(flags & ALLOW_GC) )
4394     gc_status.blocked++;
4395   if ( !(flags & ALLOW_SHIFT) )
4396     LD->shift_status.blocked++;
4397 }
4398 
4399 
4400 void
unblockGC(int flags ARG_LD)4401 unblockGC(int flags ARG_LD)
4402 { if ( !(flags & ALLOW_GC) )
4403     gc_status.blocked--;
4404   if ( !(flags & ALLOW_SHIFT) )
4405     LD->shift_status.blocked--;
4406 }
4407 
4408 
4409 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4410 makeMoreStackSpace(int overflow, int flags)
4411 
4412 Used in loops where the  low-level   implementation  does  not allow for
4413 stack-shifts.  Returns TRUE or FALSE and raises an exception.
4414 
4415 (*) growStacks() may return  TRUE  without   having  created  more stack
4416 space. This can  occur  when  if   a  'tight-stacks'  situation  when we
4417 generally have roomStackP(s)  >  1   and  thus  nextStackSize()  returns
4418 sizeStackP(s). i.e. we can't increase the stacks  but the 1 byte request
4419 is seen as satisfiable.
4420 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4421 
4422 int
makeMoreStackSpace(int overflow,int flags)4423 makeMoreStackSpace(int overflow, int flags)
4424 { GET_LD
4425   Stack s = NULL;
4426   unsigned int gc_reason = 0;
4427 
4428   switch(overflow)
4429   { case LOCAL_OVERFLOW:  s = (Stack)&LD->stacks.local;  break;
4430     case GLOBAL_OVERFLOW: s = (Stack)&LD->stacks.global;
4431 			  gc_reason = GC_GLOBAL_OVERFLOW;
4432 			  break;
4433     case TRAIL_OVERFLOW:  s = (Stack)&LD->stacks.trail;
4434 			  gc_reason = GC_TRAIL_OVERFLOW;
4435 			  break;
4436     case MEMORY_OVERFLOW: return raiseStackOverflow(overflow);
4437   }
4438 
4439   if ( LD->exception.processing && s && enableSpareStack(s, TRUE) )
4440     return TRUE;
4441 
4442   if ( LD->gc.inferences != LD->statistics.inferences &&
4443        (flags & ALLOW_GC) &&
4444        gc_reason &&
4445        garbageCollect(gc_reason) )
4446     return TRUE;
4447 
4448   if ( (flags & (ALLOW_SHIFT|ALLOW_GC)) )
4449   { size_t l=0, g=0, t=0;
4450     size_t oldsize;
4451     int rc;
4452 
4453     switch(overflow)
4454     { case LOCAL_OVERFLOW:  l = 1; break;
4455       case GLOBAL_OVERFLOW: g = 1; break;
4456       case TRAIL_OVERFLOW:  t = 1; break;
4457       default:
4458 	return raiseStackOverflow(overflow);
4459     }
4460 
4461     oldsize = sizeStackP(s);
4462 
4463     if ( (rc = growStacks(l, g, t)) == TRUE )
4464     { size_t newsize = sizeStackP(s);
4465 
4466       if ( newsize > oldsize )		/* See (*) */
4467         return rc;
4468     } else if ( rc < 0 )
4469       return raiseStackOverflow(rc);
4470   }
4471 
4472   return raiseStackOverflow(overflow);
4473 }
4474 
4475 
4476 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4477 int f_ensureStackSpace__LD(size_t gcell, size_t tcells int flags ARG_LD)
4478 
4479 Makes sure we have the requested amount of space on the global stack
4480 and trail stack. If the space is not available
4481 
4482   1. If allowed, try GC
4483   2. If GC or SHIFT is allowed, try shifting the stacks
4484   3. Use the spare stack and raise a GC request.
4485 
4486 Returns TRUE, FALSE or *_OVERFLOW
4487 
4488 Normally called through the inline function ensureStackSpace__LD() and
4489 the macros ensureTrailSpace() and ensureGlobalSpace()
4490 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4491 
4492 int
f_ensureStackSpace__LD(size_t gcells,size_t tcells,int flags ARG_LD)4493 f_ensureStackSpace__LD(size_t gcells, size_t tcells, int flags ARG_LD)
4494 { if ( gTop+gcells <= gMax && tTop+tcells <= tMax )
4495     return TRUE;
4496 
4497   if ( LD->gc.active )
4498   { enableSpareStack((Stack)&LD->stacks.global, TRUE);
4499     enableSpareStack((Stack)&LD->stacks.trail,  TRUE);
4500 
4501     if ( gTop+gcells <= gMax && tTop+tcells <= tMax )
4502       return TRUE;
4503   }
4504 
4505   if ( flags )
4506   { size_t gmin;
4507     size_t tmin;
4508     int rc;
4509 
4510     if ( (flags & ALLOW_GC) && considerGarbageCollect(NULL) )
4511     { if ( (rc=garbageCollect(GC_GLOBAL_OVERFLOW)) != TRUE )
4512 	return rc;
4513 
4514       if ( gTop+gcells <= gMax && tTop+tcells <= tMax )
4515 	return TRUE;
4516     }
4517 
4518     /* Consider a stack-shift.  ALLOW_GC implies ALLOW_SHIFT */
4519 
4520     if ( gTop+gcells > gMax || tight((Stack)&LD->stacks.global PASS_LD) )
4521       gmin = gcells*sizeof(word);
4522     else
4523       gmin = 0;
4524 
4525     if ( tTop+tcells > tMax || tight((Stack)&LD->stacks.trail PASS_LD) )
4526       tmin = tcells*sizeof(struct trail_entry);
4527     else
4528       tmin = 0;
4529 
4530     if ( (rc=growStacks(0, gmin, tmin)) != TRUE )
4531       return rc;
4532     if ( gTop+gcells <= gMax && tTop+tcells <= tMax )
4533       return TRUE;
4534   }
4535 
4536   if ( gTop+gcells > gMax )
4537     return GLOBAL_OVERFLOW;
4538   else
4539     return TRAIL_OVERFLOW;
4540 }
4541 
4542 
4543 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4544 growLocalSpace__LD() ensures sufficient local  stack   space.  User code
4545 typically calls the inlined ensureLocalSpace().
4546 
4547 NOTE: This is often called from ENSURE_LOCAL_SPACE(), while already lTop
4548 > lMax. The stack-shifter must be able to deal with this.
4549 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4550 
4551 int
growLocalSpace__LD(size_t bytes,int flags ARG_LD)4552 growLocalSpace__LD(size_t bytes, int flags ARG_LD)
4553 { if ( addPointer(lTop, bytes) <= (void*)lMax )
4554     return TRUE;
4555 
4556   if ( LD->exception.processing || LD->gc.status.active == TRUE )
4557   { enableSpareStack((Stack)&LD->stacks.local, TRUE);
4558     if ( addPointer(lTop, bytes) <= (void*)lMax )
4559       return TRUE;
4560   }
4561 
4562   if ( !flags )
4563     goto nospace;
4564 
4565   growStacks(bytes, 0, 0);
4566   if ( addPointer(lTop, bytes) <= (void*)lMax )
4567     return TRUE;
4568 
4569 nospace:
4570   return LOCAL_OVERFLOW;
4571 }
4572 
4573 
4574 		 /*******************************
4575 		 *	   STACK-SHIFTER	*
4576 		 *******************************/
4577 
4578 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4579 Update the Prolog runtime stacks presuming they have shifted by the
4580 the specified offset.
4581 
4582 Memory management description.
4583 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4584 
4585 #ifdef O_DEBUG
4586 extern char *chp_chars(Choice ch);
4587 #endif
4588 
4589 #define update_pointer(p, offset) \
4590 	do { if ( *p ) *p = addPointer(*p,offset); } while(0)
4591 
4592 
4593 		 /*******************************
4594 		 *	   LOCAL STACK		*
4595 		 *******************************/
4596 
4597 static void
update_mark(mark * m,intptr_t gs,intptr_t ts)4598 update_mark(mark *m, intptr_t gs, intptr_t ts)
4599 { if ( ts )
4600     update_pointer(&m->trailtop, ts);
4601   if ( gs )
4602   { update_pointer(&m->globaltop, gs);
4603     update_pointer(&m->saved_bar, gs);
4604   }
4605 }
4606 
4607 
4608 /* Update pointer if it contains a pointer in the local stack.  Used for
4609    updating PC, as this might point to a locally compiled clause by
4610    I_USERCALL0.
4611 */
4612 
4613 static inline void
update_local_pointer(Code * p,intptr_t ls)4614 update_local_pointer(Code *p, intptr_t ls)
4615 { GET_LD
4616 
4617   if ( onStackArea(local, *p) )
4618   { DEBUG(MSG_SHIFT_POINTER, Sdprintf(" (local ptr %p)", *p));
4619     update_pointer(p, ls);
4620   }
4621 }
4622 
4623 
4624 static inline void
update_lg_pointer(Word * p,intptr_t ls,intptr_t gs ARG_LD)4625 update_lg_pointer(Word *p, intptr_t ls, intptr_t gs ARG_LD)
4626 { if ( onStackArea(local, *p) )
4627   { update_pointer(p, ls);
4628   } else if ( onGlobalArea(*p) )
4629   { update_pointer(p, gs);
4630   }
4631 }
4632 
4633 
4634 static QueryFrame
update_environments(LocalFrame fr,intptr_t ls,intptr_t gs)4635 update_environments(LocalFrame fr, intptr_t ls, intptr_t gs)
4636 { GET_LD
4637   if ( fr == NULL )
4638     return NULL;
4639 
4640   for(;;)
4641   { assert(inShiftedArea(local, ls, fr));
4642 
4643     if ( true(fr, FR_MARKED) )
4644       return NULL;			/* from choicepoints only */
4645     set(fr, FR_MARKED);
4646     local_frames++;
4647 
4648     DEBUG(MSG_SHIFT_FRAME,
4649 	  Sdprintf("Shifting frame %p [%ld] %s ... ",
4650 		   fr, levelFrame(fr), predicateName(fr->predicate)));
4651 
4652     if ( ls )				/* update frame pointers */
4653     { update_pointer(&fr->parent, ls);
4654 
4655       update_local_pointer(&fr->programPointer, ls);
4656 					/* I_USERCALL0 compiled clause */
4657       if ( fr->clause )
4658       { if ( fr->predicate == PROCEDURE_dcall1->definition )
4659 	{ assert(onStackArea(local, fr->clause));
4660 	  update_pointer(&fr->clause, ls);
4661 	  update_pointer(&fr->clause->value.clause, ls);
4662 	} else
4663 	{ if ( onStackArea(local, fr->clause) ) /* reset/shift. See call_continuation/1 */
4664 	    update_pointer(&fr->clause, ls);
4665 	}
4666       }
4667 
4668       DEBUG(MSG_SHIFT_FRAME, Sdprintf("ok\n"));
4669     }
4670 
4671     if ( fr->parent )
4672       fr = fr->parent;
4673     else				/* Prolog --> C --> Prolog calls */
4674     { QueryFrame query = queryOfFrame(fr);
4675 
4676       if ( ls )
4677       { update_pointer(&query->parent, ls);
4678         update_pointer(&query->saved_bfr, ls);
4679         update_pointer(&query->saved_ltop, ls);
4680 	update_pointer(&query->saved_environment, ls);
4681 	update_pointer(&query->next_environment, ls);
4682 	update_pointer(&query->registers.fr, ls);
4683 	update_local_pointer(&query->registers.pc, ls);
4684       }
4685       if ( ls || gs )
4686       { update_lg_pointer(&query->registers.argp, ls, gs PASS_LD);
4687       }
4688 
4689       return query;
4690     }
4691   }
4692 }
4693 
4694 
4695 static void
update_choicepoints(Choice ch,intptr_t ls,intptr_t gs,intptr_t ts)4696 update_choicepoints(Choice ch, intptr_t ls, intptr_t gs, intptr_t ts)
4697 { GET_LD
4698 
4699   for( ; ch; ch = ch->parent )
4700   { if ( ls )
4701     { update_pointer(&ch->frame, ls);
4702       update_pointer(&ch->parent, ls);
4703       if ( ch->type == CHP_JUMP )
4704 	update_local_pointer(&ch->value.PC, ls);
4705     }
4706     update_mark(&ch->mark, gs, ts);
4707 
4708     DEBUG(MSG_SHIFT_FRAME, Sdprintf("Updated %s for %s ... ",
4709 		      chp_chars(ch),
4710 		      predicateName(ch->frame->predicate)));
4711 
4712     update_environments(ch->frame, ls, gs);
4713     choice_count++;
4714     DEBUG(MSG_SHIFT_FRAME, Sdprintf("ok\n"));
4715   }
4716 }
4717 
4718 
4719 		 /*******************************
4720 		 *	  ARGUMENT STACK	*
4721 		 *******************************/
4722 
4723 static void
update_argument(intptr_t ls,intptr_t gs)4724 update_argument(intptr_t ls, intptr_t gs)
4725 { GET_LD
4726   Word *p = aBase;
4727   Word *t = aTop;
4728 
4729   for( ; p < t; p++ )
4730   { Word ptr = *p;
4731 
4732     DEBUG(CHK_SECURE, assert(onGlobal(ptr) || onLocal(ptr)));
4733 
4734     if ( ptr > (Word)lBase )
4735       *p = addPointer(ptr, ls);
4736     else
4737       *p = addPointer(ptr, gs);
4738   }
4739 }
4740 
4741 
4742 		 /*******************************
4743 		 *	  TRAIL STACK	*
4744 		 *******************************/
4745 
4746 static void
update_trail(TrailEntry tb,intptr_t ls,intptr_t gs)4747 update_trail(TrailEntry tb, intptr_t ls, intptr_t gs)
4748 { GET_LD
4749   TrailEntry p = tb;			/* new base */
4750   TrailEntry t = tb+(tTop-tBase);	/* new top */
4751 
4752   for( ; p < t; p++ )
4753   { if ( onGlobal(trailValP(p->address)) )
4754     { update_pointer(&p->address, gs);
4755     } else
4756     { assert(onLocal(p->address));
4757       update_pointer(&p->address, ls);
4758     }
4759   }
4760 }
4761 
4762 
4763 		 /*******************************
4764 		 *	  FOREIGN FRAMES	*
4765 		 *******************************/
4766 
4767 static void
update_foreign(intptr_t ts,intptr_t ls,intptr_t gs)4768 update_foreign(intptr_t ts, intptr_t ls, intptr_t gs)
4769 { GET_LD
4770   FliFrame fr = addPointer(fli_context, ls);
4771 
4772   for( ; fr; fr = fr->parent )
4773   { if ( isRealMark(fr->mark) )
4774       update_mark(&fr->mark, gs, ts);
4775     update_pointer(&fr->parent, ls);
4776   }
4777 }
4778 
4779 
4780 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4781 Update global variables. As our pointers   areoffsets  to the stacks, we
4782 don't actually need to update the variables   themselves.  We do need to
4783 update the frozen bar however.
4784 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4785 
4786 static void
update_gvars(intptr_t gs)4787 update_gvars(intptr_t gs)
4788 { GET_LD
4789 
4790   if ( LD->frozen_bar )
4791   { update_pointer(&LD->frozen_bar, gs);
4792   }
4793   if ( LD->attvar.attvars )
4794   { update_pointer(&LD->attvar.attvars, gs);
4795   }
4796 }
4797 
4798 
4799 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4800 Entry-point.   Update the  stacks to  reflect  their current  positions.
4801 This function should be called *after*  the  stacks have been relocated.
4802 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4803 
4804 #define updateStackHeader(name, offset) \
4805   { LD->stacks.name.base    = addPointer(LD->stacks.name.base,    offset); \
4806     LD->stacks.name.top     = addPointer(LD->stacks.name.top,     offset); \
4807     LD->stacks.name.max     = addPointer(LD->stacks.name.max,     offset); \
4808   }
4809 
4810 
4811 static void
update_stacks(vm_state * state,void * lb,void * gb,void * tb)4812 update_stacks(vm_state *state, void *lb, void *gb, void *tb)
4813 { GET_LD
4814   intptr_t ls, gs, ts;
4815 
4816   ls = (intptr_t) lb - (intptr_t) lBase;
4817   gs = (intptr_t) gb - (intptr_t) gBase;
4818   ts = (intptr_t) tb - (intptr_t) tBase;
4819 
4820   DEBUG(MSG_SHIFT_PROGRESS,
4821 	Sdprintf("update_stacks(): ls+gs+ts = %ld %ld %ld\n", ls, gs, ts));
4822 
4823   if ( ls || gs || ts )
4824   { LocalFrame fr;
4825     Choice ch;
4826     QueryFrame qf;
4827 
4828     local_frames = 0;
4829     choice_count = 0;
4830 
4831     if ( ls )
4832     {					/* sometimes on local stack */
4833       update_local_pointer(&state->pc, ls);
4834       update_local_pointer(&state->pc_start_vmi, ls);
4835 					/* always on local stack */
4836       update_pointer(&state->frame, ls);
4837       update_pointer(&state->choice, ls);
4838       update_pointer(&state->lSave, ls);
4839       update_pointer(&state->lNext, ls);
4840       update_pointer(&LD->query, ls);
4841       update_local_pointer(&LD->fast_condition, ls);
4842     }
4843 
4844     for( fr = state->frame,
4845 	 ch = state->choice
4846        ; fr
4847        ;
4848        )
4849     { qf = update_environments(fr, ls, gs);
4850       assert(qf->magic == QID_MAGIC);
4851 
4852       update_choicepoints(ch, ls, gs, ts);
4853 
4854       if ( qf->parent )
4855       { QueryFrame pqf = qf->parent;
4856 
4857 	if ( (fr = pqf->registers.fr) )
4858 	{ fr = addPointer(fr, ls);	/* parent is not yet shifted */
4859 	} else
4860 	{ fr = qf->saved_environment;
4861 	}
4862 	ch = qf->saved_bfr;
4863       } else
4864 	break;
4865     }
4866 
4867     DEBUG(MSG_SHIFT_PROGRESS,
4868 	  Sdprintf("%d frames, %d choice-points ...\n",
4869 		   local_frames, choice_count));
4870 
4871     unmark_stacks(LD, state->frame, state->choice, FR_MARKED);
4872 
4873     assert(local_frames == 0);
4874     assert(choice_count == 0);
4875 
4876     if ( gs || ls )
4877     { update_argument(ls, gs);
4878       update_trail(tb, ls, gs);
4879     }
4880     update_foreign(ts, ls, gs);
4881     if ( gs )
4882       update_gvars(gs);
4883 
4884     updateStackHeader(local,  ls);
4885     updateStackHeader(global, gs);
4886     updateStackHeader(trail,  ts);
4887 
4888     base_addresses[STG_LOCAL]  = (uintptr_t)lBase;
4889     base_addresses[STG_GLOBAL] = (uintptr_t)(gBase-1); /* MARK_MASK */
4890     base_addresses[STG_TRAIL]  = (uintptr_t)tBase;
4891   }
4892 
4893   if ( ls )
4894   { update_pointer(&LD->environment,         ls);
4895     update_pointer(&LD->foreign_environment, ls);
4896     update_pointer(&LD->choicepoints,        ls);
4897   }
4898   if ( gs && LD->mark_bar != NO_MARK_BAR )
4899   { update_pointer(&LD->mark_bar, gs);
4900   }
4901 }
4902 
4903 
4904 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4905 nextStackSize() computes the size to use for s, given it should at least
4906 have minfree space after the stack  expansion.   We  want stacks to grow
4907 along a fixed set of sizes to maximize reuse of abandoned stacks.
4908 
4909 Note that we allocate local and  global   stacks  in one chunk, so their
4910 combined size should come from a fixed maximum.
4911 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4912 
4913 #undef K
4914 #undef MB
4915 #undef GB
4916 #define  K * 1024
4917 #define MB * (1024L * 1024L)
4918 #define GB * (1024L * 1024L * 1024L)
4919 
4920 size_t
nextStackSizeAbove(size_t n)4921 nextStackSizeAbove(size_t n)
4922 { size_t size;
4923 
4924 #ifdef O_DEBUG
4925   if ( DEBUGGING(CHK_SECURE) )
4926   { static int got_incr = FALSE;
4927     static size_t increment = 0;
4928 
4929     if ( !got_incr )
4930     { char *incr = getenv("PL_STACK_INCREMENT"); /* 1: random */
4931 
4932       if ( incr )
4933         increment = atol(incr);
4934       got_incr = TRUE;
4935     }
4936 
4937     if ( increment )
4938     { size_t sz;
4939 
4940       if ( increment == 1 )
4941       {
4942 #ifdef __WINDOWS__
4943 	sz = n+rand()%10000;
4944 #else
4945         GET_LD
4946 	sz = n+rand_r(&LD->gc.incr_seed)%10000;
4947 #endif
4948       } else
4949       { sz = n+increment;
4950       }
4951 
4952       return sz & ~(size_t)(sizeof(word)-1); /* align on words */
4953     }
4954   }
4955 #endif
4956 
4957   size = (size_t)2 << MSB(n);
4958   if ( size < SMALLSTACK )
4959     size = SMALLSTACK;
4960 					/* enforce real limit */
4961   if ( size > (size_t)(MAXTAGGEDPTR+1) )
4962     size = (size_t)(MAXTAGGEDPTR+1);
4963   if ( size < n )
4964     return 0;				/* still too small */
4965 
4966   return size;
4967 }
4968 
4969 
4970 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4971 Return next size for the stack that ensures minfree bytes of free space.
4972 We add another s->min_free to give some freedom.
4973 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4974 
4975 size_t
nextStackSize(Stack s,size_t minfree)4976 nextStackSize(Stack s, size_t minfree)
4977 { size_t size;
4978 
4979   if ( minfree == GROW_TRIM )
4980   { size = nextStackSizeAbove(usedStackP(s) + s->min_free + s->def_spare);
4981     if ( size > (size_t)sizeStackP(s) )
4982       size = sizeStackP(s);
4983   } else
4984   { size_t needed = sizeStackP(s) + minfree + s->min_free + s->def_spare;
4985 
4986     if ( s->top > s->max )
4987       needed += (char*)s->top - (char*)s->max;
4988 
4989     size = nextStackSizeAbove(needed);
4990   }
4991 
4992   return size;
4993 }
4994 
4995 
4996 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4997 Stack shifter entry point. The arguments l, g and t request expansion of
4998 the local, global and trail-stacks. Non-0 versions   ask the stack to be
4999 modified. Positive values enlarge the stack to the next size that has at
5000 least the specified value free space (i.e. min-free).
5001 
5002 GROW_TRIM cause the stack to  shrink  to   the  value  nearest above the
5003 current usage and the minimum free stack.
5004 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5005 
5006 static int
new_stack_size(Stack s,size_t request,size_t * newsize)5007 new_stack_size(Stack s, size_t request, size_t *newsize)
5008 { if ( request )
5009   { size_t new;
5010 
5011     if ( !(new = nextStackSize(s, request)) )
5012       return s->overflow_id;
5013     *newsize = new;
5014 
5015     return TRUE;
5016   } else
5017   { *newsize = sizeStackP(s);
5018 
5019     return FALSE;
5020   }
5021 }
5022 
5023 
5024 static size_t
needStack(Stack s ARG_LD)5025 needStack(Stack s ARG_LD)
5026 { return usedStackP(s) + s->min_free + s->def_spare;
5027 }
5028 
5029 
5030 static int
grow_stacks(size_t l,size_t g,size_t t ARG_LD)5031 grow_stacks(size_t l, size_t g, size_t t ARG_LD)
5032 { sigset_t mask;
5033   size_t lsize=0, gsize=0, tsize=0;
5034   vm_state state;
5035   Stack fatal = NULL;	/* stack we couldn't expand due to lack of memory */
5036   int rc;
5037 #if O_DEBUG
5038   word key=0;
5039 #endif
5040 
5041   if ( !(l || g || t) )
5042     return TRUE;			/* not a real request */
5043 
5044   if ( LD->shift_status.blocked )
5045     return FALSE;
5046 
5047   if ( (rc=new_stack_size((Stack)&LD->stacks.trail,  t, &tsize))<0 ||
5048        (rc=new_stack_size((Stack)&LD->stacks.global, g, &gsize))<0 ||
5049        (rc=new_stack_size((Stack)&LD->stacks.local,  l, &lsize))<0 )
5050   { return rc;
5051   } else
5052   { if ( tsize + gsize + lsize > LD->stacks.limit )
5053     { size_t ulocal  = needStack((Stack)&LD->stacks.local PASS_LD)  + l;
5054       size_t uglobal = needStack((Stack)&LD->stacks.global PASS_LD) + g;
5055       size_t utrail  = needStack((Stack)&LD->stacks.trail PASS_LD)  + t +
5056 		       uglobal/GLOBAL_TRAIL_RATIO;
5057       size_t need    = ulocal + utrail + uglobal;
5058       size_t limit   = LD->stacks.limit;
5059       size_t minav   = limit/4;
5060       size_t space;
5061 
5062       DEBUG(MSG_STACK_OVERFLOW,
5063 	    Sdprintf("Reached stack-limit; need (l+g+t) %zd+%zd+%zd=%zd; limit = %zd\n",
5064 		     ulocal, uglobal, utrail, need, LD->stacks.limit));
5065 
5066       if ( LD->in_print_message )
5067       { limit += 1024*1024;
5068 	minav = 0;
5069       }
5070 
5071       if ( limit > need && (space=limit-need) > minav )
5072       { gsize = uglobal + uglobal * space/need;
5073 	tsize = utrail  + utrail  * space/need;
5074 	lsize = ulocal  + ulocal  * space/need;
5075 
5076 	gsize = ROUND(gsize, 4096);
5077 	tsize = ROUND(tsize, 4096);
5078 	lsize = ROUND(lsize, 4096);
5079 
5080 	DEBUG(MSG_STACK_OVERFLOW, Sdprintf(" --> l:g:t = %zd:%zd:%zd\n",
5081 					   lsize, gsize, tsize));
5082       } else
5083       { DEBUG(MSG_STACK_OVERFLOW, Sdprintf("Got stack overflow;\n"));
5084 	return STACK_OVERFLOW;
5085       }
5086     }
5087   }
5088 
5089   l = (sizeStack(local)  != lsize);
5090   g = (sizeStack(global) != gsize);
5091   t = (sizeStack(trail)  != tsize);
5092 
5093   if ( !(l || g || t) )
5094     return TRUE;
5095 
5096   enterGC(PASS_LD1);			/* atom-gc synchronisation */
5097   blockSignals(&mask);
5098   blockGC(0 PASS_LD);			/* avoid recursion due to */
5099   PL_clearsig(SIG_GC);
5100 
5101   get_vmi_state(LD->query, &state);
5102   DEBUG(CHK_SECURE,
5103 	{ gBase++;
5104 	  checkStacks(&state);
5105 	  gBase--;
5106 	});
5107 
5108   { TrailEntry tb = tBase;
5109     Word gb = gBase;
5110     LocalFrame lb = lBase;
5111     double time, time0 = ThreadCPUTime(LD, CPU_USER);
5112     int verbose = truePrologFlag(PLFLAG_TRACE_GC);
5113 
5114     DEBUG(MSG_SHIFT, verbose = TRUE);
5115 
5116     if ( verbose )
5117     { const char *prefix;
5118       int tid = PL_thread_self();
5119 
5120       if ( Serror->position && Serror->position->linepos > 0 )
5121 	prefix = "\n% ";
5122       else
5123 	prefix = "% ";
5124 
5125       if ( tid != 1 )
5126 	Sdprintf("%s[%d] SHIFT: l:g:t = %ld:%ld:%ld ...",
5127 		 prefix, tid, (long)l, (long)g, (long)t);
5128       else
5129 	Sdprintf("%sSHIFT: l:g:t = %ld:%ld:%ld ...",
5130 		 prefix, (long)l, (long)g, (long)t);
5131     }
5132 
5133     DEBUG(CHK_SECURE,
5134 	  { gBase++;
5135 	    if ( !scan_global(FALSE) )
5136 	      sysError("Stack not ok at shift entry");
5137 	    key = checkStacks(&state);
5138 	    gBase--;
5139 	  });
5140 
5141     if ( t )
5142     { void *nw;
5143 
5144       tsize = stack_nrealloc(tb, tsize);
5145       if ( (nw = stack_realloc(tb, tsize)) )
5146       { LD->shift_status.trail_shifts++;
5147 	tb = nw;
5148       } else
5149       { fatal = (Stack)&LD->stacks.trail;
5150 	tsize = sizeStack(trail);
5151       }
5152     }
5153 
5154     if ( g || l )
5155     { size_t ogsize, olsize;
5156       void *nw;
5157 
5158       assert(*gb == MARK_MASK);		/* see initPrologStacks() */
5159       ogsize = sizeStack(global);
5160       olsize = sizeStack(local);
5161       assert(lb == addPointer(gb, ogsize));
5162 
5163       gsize = stack_nrealloc(gb, lsize + gsize)-lsize;
5164       g = (ogsize != gsize);
5165 
5166       if ( gsize < ogsize )		/* TBD: Only copy life-part */
5167 	memmove(addPointer(gb, gsize), lb, olsize);
5168 
5169       if ( (nw = stack_realloc(gb, lsize + gsize)) )
5170       { if ( g )
5171 	  LD->shift_status.global_shifts++;
5172 	if ( l )
5173 	  LD->shift_status.local_shifts++;
5174 
5175 	gb = nw;
5176 	lb = addPointer(gb, gsize);
5177 	if ( gsize > ogsize )
5178 	{ size_t copy = olsize;
5179 
5180 	  if ( lsize < olsize )
5181 	    copy = lsize;
5182 	  memmove(lb, addPointer(gb, ogsize), copy);
5183 	}
5184       } else				/* realloc failed; restore */
5185       { if ( g )
5186 	  fatal = (Stack)&LD->stacks.global;
5187 	else
5188 	  fatal = (Stack)&LD->stacks.local;
5189 
5190 	if ( gsize < ogsize )
5191 	  memmove(lb, addPointer(gb, gsize), olsize);
5192 
5193 	gsize = sizeStack(global);
5194 	lsize = sizeStack(local);
5195 	DEBUG(MSG_STACK_OVERFLOW, Sdprintf("realloc() failed\n"));
5196       }
5197     }
5198 
5199 #define PrintStackParms(stack, name, newbase, newsize) \
5200 	{ void *newmax = addPointer(newbase, newsize); \
5201 	  Sdprintf("%-6s: %p ... %p --> ", \
5202 		   name, \
5203 		   LD->stacks.stack.base, \
5204 		   LD->stacks.stack.max); \
5205 	  if ( LD->stacks.stack.base == newbase && \
5206 	       (void*)LD->stacks.stack.max == newmax ) \
5207 	  { Sdprintf("(no change)\n"); \
5208 	  } else \
5209 	  { Sdprintf("%p ... %p\n", newbase, newmax); \
5210 	  } \
5211 	}
5212 
5213     if ( verbose )
5214     { DEBUG(0, { Sputchar('\n');
5215 		 PrintStackParms(global, "global", gb, gsize);
5216 		 PrintStackParms(local, "local", lb, lsize);
5217 		 PrintStackParms(trail, "trail", tb, tsize);
5218 	       });
5219     }
5220 
5221     gBase++; gb++;
5222     update_stacks(&state, lb, gb, tb);
5223     gBase--; gb--;
5224 
5225     LD->stacks.local.max  = addPointer(LD->stacks.local.base,  lsize);
5226     LD->stacks.global.max = addPointer(LD->stacks.global.base, gsize);
5227     LD->stacks.trail.max  = addPointer(LD->stacks.trail.base,  tsize);
5228 
5229     time = ThreadCPUTime(LD, CPU_USER) - time0;
5230     LD->shift_status.time += time;
5231     DEBUG(CHK_SECURE,
5232 	  { gBase++;
5233 	    if ( checkStacks(&state) != key )
5234 	    { Sdprintf("Stack checksum failure\n");
5235 	      trap_gdb();
5236 	    }
5237 	    gBase--;
5238 	  });
5239     if ( verbose )
5240     { Sdprintf("l+g+t = %lld+%lld+%lld (%.3f sec)\n",
5241 	       (int64_t)lsize, (int64_t)gsize, (int64_t)tsize, time);
5242     }
5243   }
5244 
5245   DEBUG(CHK_SECURE,
5246 	{ gBase++;
5247 	  checkStacks(&state);
5248 	  gBase--;
5249 	});
5250   restore_vmi_state(&state);
5251   unblockGC(0 PASS_LD);
5252   unblockSignals(&mask);
5253   leaveGC(PASS_LD1);
5254 
5255   if ( fatal )
5256     return fatal->overflow_id;
5257 
5258   return TRUE;
5259 }
5260 
5261 
5262 static void
include_spare_stack(void * ptr,size_t * request)5263 include_spare_stack(void *ptr, size_t *request)
5264 { Stack s = ptr;
5265 
5266   if ( *request )
5267   { if ( *request != GROW_TRIM )
5268       *request += s->def_spare - s->spare;
5269     else if ( roomStackP(s) < s->def_spare )
5270       *request = s->def_spare;
5271   }
5272 
5273   if ( s->spare )
5274   { s->max = addPointer(s->max, s->spare);
5275     s->spare = 0;
5276   }
5277 }
5278 
5279 
5280 static void
reenable_spare_stack(void * ptr,int rc)5281 reenable_spare_stack(void *ptr, int rc)
5282 { Stack s = ptr;
5283 
5284   if ( roomStackP(s) >=	s->def_spare || (rc != TRUE) )
5285     trim_stack(s);
5286   else
5287     Sdprintf("Could not reenable %s-stack\n", s->name);
5288 }
5289 
5290 
5291 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5292 Note that the trail can have  references   to  unused  stack. We set the
5293 references to point to a  dummy  variable,   so  no  harm  will be done.
5294 Setting  it  to  NULL  would  require  a    test  in  Undo(),  which  is
5295 time-critical. trim_stacks normally isn't. This precaution is explicitly
5296 required for the trimStacks() that result from a stack-overflow.
5297 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5298 
5299 int
growStacks(size_t l,size_t g,size_t t)5300 growStacks(size_t l, size_t g, size_t t)
5301 { GET_LD
5302   int rc;
5303   LocalFrame olb = lBase;
5304   LocalFrame olm = lMax;
5305   Word ogb = gBase;
5306   Word ogm = gMax;
5307 
5308 #ifdef O_MAINTENANCE
5309   save_backtrace("SHIFT");
5310 #endif
5311 
5312   include_spare_stack(&LD->stacks.local,  &l);
5313   include_spare_stack(&LD->stacks.global, &g);
5314   include_spare_stack(&LD->stacks.trail,  &t);
5315 
5316   gBase--; gMax++; tMax++;
5317   rc = grow_stacks(l, g, t PASS_LD);
5318   gBase++; gMax--; tMax--;
5319 
5320   reenable_spare_stack(&LD->stacks.trail,  rc);
5321   reenable_spare_stack(&LD->stacks.global, rc);
5322   reenable_spare_stack(&LD->stacks.local,  rc);
5323 
5324   if ( olb != lBase || olm != lMax || ogb != gBase || ogm != gMax )
5325   { TrailEntry te;
5326 
5327     for(te = tTop; --te >= tBase; )
5328     { Word p = te->address;
5329 
5330       if ( isTrailVal(p) )
5331 	continue;
5332 
5333       if ( !onStack(local, p) && !onStack(global, p) )
5334       { te->address = valTermRef(LD->trim.dummy);
5335       }
5336     }
5337   }
5338 
5339   return rc;
5340 }
5341 
5342 
5343 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5344 (*) Some programs have a lot of global and hardly any trail requirement.
5345 This means we gets lots of GCs for trail, which works fine, but they are
5346 expensive due to the size of the global stack. As long as we do not have
5347 generational GC, we make the trail free space proportional to the global
5348 stack usage. This too isn't ideal; it is possible that simply nothing is
5349 trailed and therefore it can be low.   Ideally, I think that the margins
5350 should depend on the percentage of the   time spent in GC's triggered by
5351 the stack. One of the problems we are   faced with is that not all OS'es
5352 allow us to get per-thread CPU statistics.
5353 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5354 
5355 static size_t
tight(Stack s ARG_LD)5356 tight(Stack s ARG_LD)
5357 { size_t min_room  = sizeStackP(s)/3;
5358   size_t spare_gap = s->def_spare - s->spare;
5359 
5360   if ( s == (Stack)&LD->stacks.trail )	/* See (*) */
5361   { min_room += sizeStack(global)/GLOBAL_TRAIL_RATIO;
5362     DEBUG(MSG_GC_SCHEDULE, Sdprintf("Trail min_room = %ld\n", min_room));
5363   }
5364 
5365   if ( min_room < s->min_free )
5366     min_room = s->min_free;
5367 
5368   if ( (size_t)roomStackP(s) < min_room + spare_gap )
5369     return GROW_TIGHT;
5370 
5371   return 0;
5372 }
5373 
5374 
5375 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5376 Return TRUE on success or *_OVERFLOW when out of space.
5377 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5378 
5379 int
shiftTightStacks(void)5380 shiftTightStacks(void)
5381 { GET_LD
5382   size_t l = tight((Stack)&LD->stacks.local PASS_LD);
5383   size_t g = tight((Stack)&LD->stacks.global PASS_LD);
5384   size_t t = tight((Stack)&LD->stacks.trail PASS_LD);
5385 
5386   if ( (l|g|t) )
5387     return growStacks(l, g, t);
5388 
5389   return TRUE;
5390 }
5391 
5392 
5393 #ifdef O_ATOMGC
5394 
5395 		 /*******************************
5396 		 *	      ATOM-GC		*
5397 		 *******************************/
5398 
5399 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5400 The  routine  markAtomsOnStacks(PL_local_data_t  *ld)  marks  all  atoms
5401 reachable from  the global stack, local stack and term-references  using
5402 markAtom().  It  is  designed  to  allow  for asynchronous calling, even
5403 from different threads (hence the argument).
5404 
5405 Asynchronous calling is in general not  possible,   but  here we make an
5406 exception. markAtom() is supposed  to  test   for  and  silently  ignore
5407 non-atoms. Basically, this implies we can   mark a few atoms incorrectly
5408 from the interrupted frame, but in   the context of multi-threading this
5409 is a small price to pay.
5410 
5411 Otherwise  this  routine  is  fairly  trivial.   It  is  modelled  after
5412 checkStacks(), a simple routine for  checking stack-consistency that has
5413 to walk along all reachable data as well.
5414 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5415 
5416 static void
markAtomsOnGlobalStack(PL_local_data_t * ld)5417 markAtomsOnGlobalStack(PL_local_data_t *ld)
5418 { Word gbase = ld->stacks.global.base;
5419   Word gtop  = ld->stacks.global.top;
5420   Word current;
5421   word w;
5422 
5423 #ifdef O_DEBUG_ATOMGC
5424   DEBUG(MSG_AGC,
5425 	if ( atomLogFd )
5426 	  Sfprintf(atomLogFd, "Mark global %p..%p\n", gbase, gtop));
5427 #endif
5428 
5429   for(current = gbase; current < gtop; current += (offset_word(w)+1) )
5430   { w = *current;
5431 
5432     if ( isAtom(w) )
5433       markAtom(w);
5434   }
5435 }
5436 
5437 static void
markAtomsOnLocalStack(PL_local_data_t * ld)5438 markAtomsOnLocalStack(PL_local_data_t *ld)
5439 { Word lbase = (Word)ld->stacks.local.base;
5440   Word ltop  = (Word)ld->stacks.local.top;
5441   Word lmax  = (Word)ld->stacks.local.max;
5442   Word lend  = ltop+LOCAL_MARGIN < lmax ? ltop+LOCAL_MARGIN : lmax;
5443   Word current;
5444 
5445   for(current = lbase; current < lend; current++ )
5446   { word w = *current;
5447 
5448     if ( isAtom(w) )
5449       markAtom(w);
5450   }
5451 }
5452 
5453 
5454 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5455 markAtomsOnStacks()  is  called   asynchronously    (Unix)   or  between
5456 SuspendThread()/ResumeThread() from another thread in  Windows. Its task
5457 is to mark all atoms that  are   references  from  the Prolog stacks. It
5458 should not make any assumptions  on   the  initialised  variables in the
5459 stack-frames, but it is allowed to mark atoms from uninitialised data as
5460 this causes some atoms not to  be   GC-ed  this  time (maybe better next
5461 time).
5462 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5463 
5464 void
markAtomsOnStacks(PL_local_data_t * ld)5465 markAtomsOnStacks(PL_local_data_t *ld)
5466 { assert(!ld->gc.status.active);
5467 
5468   if ( !ld->magic )
5469     return;				/* avoid AGC on finished threads */
5470 
5471   DEBUG(MSG_AGC, save_backtrace("AGC"));
5472 #ifdef O_MAINTENANCE
5473   save_backtrace("AGC");
5474 #endif
5475 #ifdef O_DEBUG_ATOMGC
5476   DEBUG(MSG_AGC,
5477 	if ( atomLogFd )
5478 	  Sfprintf(atomLogFd, "Mark atoms.unregistering\n"));
5479 #endif
5480   markAtom(ld->atoms.unregistering);	/* see PL_unregister_atom() */
5481   markAtomsOnLocalStack(ld);
5482   markAtomsOnGlobalStack(ld);
5483   markAtomsFindall(ld);
5484 #ifdef O_PLMT
5485   markAtomsThreadMessageQueue(ld);
5486 #endif
5487 }
5488 
5489 #endif /*O_ATOMGC*/
5490 
5491 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5492 Find the latest generation at which a predicate is being used.
5493 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5494 
5495 #ifdef O_CLAUSEGC
5496 
5497 static inline int
is_pointer_like(void * ptr)5498 is_pointer_like(void *ptr)
5499 {
5500 #if SIZEOF_VOIDP == 4
5501   intptr_t mask = 0x3;
5502 #elif SIZEOF_VOIDP == 8
5503   intptr_t mask = 0x7;
5504 #else
5505 #error "Unknown pointer size"
5506 #endif
5507   return ptr && ((intptr_t)ptr&mask) == 0;
5508 }
5509 
5510 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5511 (*) Note that unlike for markAtomsOnLocalStack(), we do not need to look
5512 behind the official top of the stack   as frames are never written above
5513 lTop. If anything is added, it will  be   at  a  newer generation, so we
5514 don't care.
5515 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5516 
5517 void
markPredicatesInEnvironments(PL_local_data_t * ld)5518 markPredicatesInEnvironments(PL_local_data_t *ld)
5519 { GET_LD
5520   Word lbase, lend, current;
5521 
5522   lbase = (Word)ld->stacks.local.base;
5523   lend  = (Word)ld->stacks.local.top;		/* see (*) */
5524   for(current = lbase; current < lend; current++ )
5525   { LocalFrame fr = (LocalFrame)current;
5526 
5527     if ( isFrame(fr) )
5528     { DirtyDefInfo ddi;
5529       Definition def = fr->predicate;
5530 
5531       if ( is_pointer_like(def) &&
5532 	   (ddi=lookupHTable(GD->procedures.dirty, def)) )
5533       { gen_t gen = generationFrame(fr);
5534 
5535 	ddi_add_access_gen(ddi, gen);
5536       }
5537     }
5538   }
5539 
5540   ld->clauses.erased_skipped = 0;
5541   markAccessedPredicates(ld);
5542 }
5543 
5544 #endif /*O_CLAUSEGC*/
5545 
5546 
5547 		 /*******************************
5548 		 *	    PREDICATES		*
5549 		 *******************************/
5550 
5551 BeginPredDefs(gc)
5552   PRED_DEF("$gc_statistics", 5, gc_statistics, 0)
5553 #if O_DEBUG || defined(O_MAINTENANCE)
5554   PRED_DEF("$check_stacks", 1, check_stacks, 0)
5555 #endif
5556 #ifdef GC_COUNTING
5557   PRED_DEF("gc_counts", 1, gc_counts, 0)
5558 #endif
5559 EndPredDefs
5560