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(¤t->address) )
2570 update_relocation_chain(¤t->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(¤t->address) )
2587 update_relocation_chain(¤t->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