1 /* -----------------------------------------------------------------------------
2 * $Id: GC.c,v 1.44 1999/02/26 13:36:12 simonm Exp $
4 * (c) The GHC Team 1998-1999
6 * Generational garbage collector
8 * ---------------------------------------------------------------------------*/
14 #include "StoragePriv.h"
17 #include "SchedAPI.h" /* for ReverCAFs prototype */
20 #include "BlockAlloc.h"
22 #include "DebugProf.h"
25 #include "StablePriv.h"
29 /* STATIC OBJECT LIST.
32 * We maintain a linked list of static objects that are still live.
33 * The requirements for this list are:
35 * - we need to scan the list while adding to it, in order to
36 * scavenge all the static objects (in the same way that
37 * breadth-first scavenging works for dynamic objects).
39 * - we need to be able to tell whether an object is already on
40 * the list, to break loops.
42 * Each static object has a "static link field", which we use for
43 * linking objects on to the list. We use a stack-type list, consing
44 * objects on the front as they are added (this means that the
45 * scavenge phase is depth-first, not breadth-first, but that
48 * A separate list is kept for objects that have been scavenged
49 * already - this is so that we can zero all the marks afterwards.
51 * An object is on the list if its static link field is non-zero; this
52 * means that we have to mark the end of the list with '1', not NULL.
54 * Extra notes for generational GC:
56 * Each generation has a static object list associated with it. When
57 * collecting generations up to N, we treat the static object lists
58 * from generations > N as roots.
60 * We build up a static object list while collecting generations 0..N,
61 * which is then appended to the static object list of generation N+1.
63 StgClosure* static_objects; /* live static objects */
64 StgClosure* scavenged_static_objects; /* static objects scavenged so far */
66 /* N is the oldest generation being collected, where the generations
67 * are numbered starting at 0. A major GC (indicated by the major_gc
68 * flag) is when we're collecting all generations. We only attempt to
69 * deal with static objects and GC CAFs when doing a major GC.
72 static rtsBool major_gc;
74 /* Youngest generation that objects should be evacuated to in
75 * evacuate(). (Logically an argument to evacuate, but it's static
76 * a lot of the time so we optimise it into a global variable).
82 static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
83 static rtsBool weak_done; /* all done for this pass */
85 /* Flag indicating failure to evacuate an object to the desired
88 static rtsBool failed_to_evac;
90 /* Old to-space (used for two-space collector only)
94 /* Data used for allocation area sizing.
96 lnat new_blocks; /* blocks allocated during this GC */
97 lnat g0s0_pcnt_kept = 30; /* percentage of g0s0 live at last minor GC */
99 /* -----------------------------------------------------------------------------
100 Static function declarations
101 -------------------------------------------------------------------------- */
103 static StgClosure * evacuate ( StgClosure *q );
104 static void zero_static_object_list ( StgClosure* first_static );
105 static void zero_mutable_list ( StgMutClosure *first );
106 static void revert_dead_CAFs ( void );
108 static rtsBool traverse_weak_ptr_list ( void );
109 static void cleanup_weak_ptr_list ( void );
111 static void scavenge_stack ( StgPtr p, StgPtr stack_end );
112 static void scavenge_large ( step *step );
113 static void scavenge ( step *step );
114 static void scavenge_static ( void );
115 static void scavenge_mutable_list ( generation *g );
116 static void scavenge_mut_once_list ( generation *g );
119 static void gcCAFs ( void );
122 /* -----------------------------------------------------------------------------
125 For garbage collecting generation N (and all younger generations):
127 - follow all pointers in the root set. the root set includes all
128 mutable objects in all steps in all generations.
130 - for each pointer, evacuate the object it points to into either
131 + to-space in the next higher step in that generation, if one exists,
132 + if the object's generation == N, then evacuate it to the next
133 generation if one exists, or else to-space in the current
135 + if the object's generation < N, then evacuate it to to-space
136 in the next generation.
138 - repeatedly scavenge to-space from each step in each generation
139 being collected until no more objects can be evacuated.
141 - free from-space in each step, and set from-space = to-space.
143 -------------------------------------------------------------------------- */
145 void GarbageCollect(void (*get_roots)(void))
149 lnat live, allocated, collected = 0, copied = 0;
153 CostCentreStack *prev_CCS;
156 /* tell the stats department that we've started a GC */
159 /* attribute any costs to CCS_GC */
165 /* We might have been called from Haskell land by _ccall_GC, in
166 * which case we need to call threadPaused() because the scheduler
167 * won't have done it.
169 if (CurrentTSO) { threadPaused(CurrentTSO); }
171 /* Approximate how much we allocated: number of blocks in the
172 * nursery + blocks allocated via allocate() - unused nusery blocks.
173 * This leaves a little slop at the end of each block, and doesn't
174 * take into account large objects (ToDo).
176 allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
177 for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
178 allocated -= BLOCK_SIZE_W;
181 /* Figure out which generation to collect
184 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
185 if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
189 major_gc = (N == RtsFlags.GcFlags.generations-1);
191 /* check stack sanity *before* GC (ToDo: check all threads) */
192 /*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
193 IF_DEBUG(sanity, checkFreeListSanity());
195 /* Initialise the static object lists
197 static_objects = END_OF_STATIC_LIST;
198 scavenged_static_objects = END_OF_STATIC_LIST;
200 /* zero the mutable list for the oldest generation (see comment by
201 * zero_mutable_list below).
204 zero_mutable_list(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
207 /* Save the old to-space if we're doing a two-space collection
209 if (RtsFlags.GcFlags.generations == 1) {
210 old_to_space = g0s0->to_space;
211 g0s0->to_space = NULL;
214 /* Keep a count of how many new blocks we allocated during this GC
215 * (used for resizing the allocation area, later).
219 /* Initialise to-space in all the generations/steps that we're
222 for (g = 0; g <= N; g++) {
223 generations[g].mut_once_list = END_MUT_LIST;
224 generations[g].mut_list = END_MUT_LIST;
226 for (s = 0; s < generations[g].n_steps; s++) {
228 /* generation 0, step 0 doesn't need to-space */
229 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
233 /* Get a free block for to-space. Extra blocks will be chained on
237 step = &generations[g].steps[s];
238 ASSERT(step->gen->no == g);
239 ASSERT(step->hp ? Bdescr(step->hp)->step == step : rtsTrue);
240 bd->gen = &generations[g];
243 bd->evacuated = 1; /* it's a to-space block */
244 step->hp = bd->start;
245 step->hpLim = step->hp + BLOCK_SIZE_W;
249 step->scan = bd->start;
251 step->new_large_objects = NULL;
252 step->scavenged_large_objects = NULL;
254 /* mark the large objects as not evacuated yet */
255 for (bd = step->large_objects; bd; bd = bd->link) {
261 /* make sure the older generations have at least one block to
262 * allocate into (this makes things easier for copy(), see below.
264 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
265 for (s = 0; s < generations[g].n_steps; s++) {
266 step = &generations[g].steps[s];
267 if (step->hp_bd == NULL) {
269 bd->gen = &generations[g];
272 bd->evacuated = 0; /* *not* a to-space block */
273 step->hp = bd->start;
274 step->hpLim = step->hp + BLOCK_SIZE_W;
280 /* Set the scan pointer for older generations: remember we
281 * still have to scavenge objects that have been promoted. */
282 step->scan = step->hp;
283 step->scan_bd = step->hp_bd;
284 step->to_space = NULL;
286 step->new_large_objects = NULL;
287 step->scavenged_large_objects = NULL;
291 /* -----------------------------------------------------------------------
292 * follow all the roots that we know about:
293 * - mutable lists from each generation > N
294 * we want to *scavenge* these roots, not evacuate them: they're not
295 * going to move in this GC.
296 * Also: do them in reverse generation order. This is because we
297 * often want to promote objects that are pointed to by older
298 * generations early, so we don't have to repeatedly copy them.
299 * Doing the generations in reverse order ensures that we don't end
300 * up in the situation where we want to evac an object to gen 3 and
301 * it has already been evaced to gen 2.
305 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
306 generations[g].saved_mut_list = generations[g].mut_list;
307 generations[g].mut_list = END_MUT_LIST;
310 /* Do the mut-once lists first */
311 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
312 scavenge_mut_once_list(&generations[g]);
314 for (st = generations[g].n_steps-1; st >= 0; st--) {
315 scavenge(&generations[g].steps[st]);
319 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
320 scavenge_mutable_list(&generations[g]);
322 for (st = generations[g].n_steps-1; st >= 0; st--) {
323 scavenge(&generations[g].steps[st]);
328 /* follow all the roots that the application knows about.
333 /* And don't forget to mark the TSO if we got here direct from
336 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
339 /* Mark the weak pointer list, and prepare to detect dead weak
342 old_weak_ptr_list = weak_ptr_list;
343 weak_ptr_list = NULL;
344 weak_done = rtsFalse;
346 /* Mark the stable pointer table.
348 markStablePtrTable(major_gc);
352 /* ToDo: To fix the caf leak, we need to make the commented out
353 * parts of this code do something sensible - as described in
356 extern void markHugsObjects(void);
358 /* ToDo: This (undefined) function should contain the scavenge
359 * loop immediately below this block of code - but I'm not sure
360 * enough of the details to do this myself.
362 scavengeEverything();
363 /* revert dead CAFs and update enteredCAFs list */
368 /* This will keep the CAFs and the attached BCOs alive
369 * but the values will have been reverted
371 scavengeEverything();
376 /* -------------------------------------------------------------------------
377 * Repeatedly scavenge all the areas we know about until there's no
378 * more scavenging to be done.
385 /* scavenge static objects */
386 if (major_gc && static_objects != END_OF_STATIC_LIST) {
390 /* When scavenging the older generations: Objects may have been
391 * evacuated from generations <= N into older generations, and we
392 * need to scavenge these objects. We're going to try to ensure that
393 * any evacuations that occur move the objects into at least the
394 * same generation as the object being scavenged, otherwise we
395 * have to create new entries on the mutable list for the older
399 /* scavenge each step in generations 0..maxgen */
403 for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
404 for (st = generations[gen].n_steps-1; st >= 0 ; st--) {
405 if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
408 step = &generations[gen].steps[st];
410 if (step->hp_bd != step->scan_bd || step->scan < step->hp) {
415 if (step->new_large_objects != NULL) {
416 scavenge_large(step);
423 if (flag) { goto loop; }
425 /* must be last... */
426 if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
431 /* Final traversal of the weak pointer list (see comment by
432 * cleanUpWeakPtrList below).
434 cleanup_weak_ptr_list();
436 /* Now see which stable names are still alive.
438 gcStablePtrTable(major_gc);
440 /* Set the maximum blocks for the oldest generation, based on twice
441 * the amount of live data now, adjusted to fit the maximum heap
444 * This is an approximation, since in the worst case we'll need
445 * twice the amount of live data plus whatever space the other
448 if (RtsFlags.GcFlags.generations > 1) {
450 oldest_gen->max_blocks =
451 stg_max(oldest_gen->steps[0].to_blocks * RtsFlags.GcFlags.oldGenFactor,
452 RtsFlags.GcFlags.minOldGenSize);
453 if (oldest_gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
454 oldest_gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
455 if (((int)oldest_gen->max_blocks -
456 (int)oldest_gen->steps[0].to_blocks) <
457 (RtsFlags.GcFlags.pcFreeHeap *
458 RtsFlags.GcFlags.maxHeapSize / 200)) {
465 /* run through all the generations/steps and tidy up
467 copied = new_blocks * BLOCK_SIZE_W;
468 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
471 generations[g].collections++; /* for stats */
474 for (s = 0; s < generations[g].n_steps; s++) {
476 step = &generations[g].steps[s];
478 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
479 /* Tidy the end of the to-space chains */
480 step->hp_bd->free = step->hp;
481 step->hp_bd->link = NULL;
482 /* stats information: how much we copied */
484 copied -= step->hp_bd->start + BLOCK_SIZE_W -
489 /* for generations we collected... */
492 collected += step->n_blocks * BLOCK_SIZE_W; /* for stats */
494 /* free old memory and shift to-space into from-space for all
495 * the collected steps (except the allocation area). These
496 * freed blocks will probaby be quickly recycled.
498 if (!(g == 0 && s == 0)) {
499 freeChain(step->blocks);
500 step->blocks = step->to_space;
501 step->n_blocks = step->to_blocks;
502 step->to_space = NULL;
504 for (bd = step->blocks; bd != NULL; bd = bd->link) {
505 bd->evacuated = 0; /* now from-space */
509 /* LARGE OBJECTS. The current live large objects are chained on
510 * scavenged_large, having been moved during garbage
511 * collection from large_objects. Any objects left on
512 * large_objects list are therefore dead, so we free them here.
514 for (bd = step->large_objects; bd != NULL; bd = next) {
519 for (bd = step->scavenged_large_objects; bd != NULL; bd = bd->link) {
522 step->large_objects = step->scavenged_large_objects;
524 /* Set the maximum blocks for this generation, interpolating
525 * between the maximum size of the oldest and youngest
528 * max_blocks = oldgen_max_blocks * G
529 * ----------------------
534 generations[g].max_blocks = (oldest_gen->max_blocks * g)
535 / (RtsFlags.GcFlags.generations-1);
537 generations[g].max_blocks = oldest_gen->max_blocks;
540 /* for older generations... */
543 /* For older generations, we need to append the
544 * scavenged_large_object list (i.e. large objects that have been
545 * promoted during this GC) to the large_object list for that step.
547 for (bd = step->scavenged_large_objects; bd; bd = next) {
550 dbl_link_onto(bd, &step->large_objects);
553 /* add the new blocks we promoted during this GC */
554 step->n_blocks += step->to_blocks;
559 /* Guess the amount of live data for stats. */
562 /* Free the small objects allocated via allocate(), since this will
563 * all have been copied into G0S1 now.
565 if (small_alloc_list != NULL) {
566 freeChain(small_alloc_list);
568 small_alloc_list = NULL;
572 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
574 /* Two-space collector:
575 * Free the old to-space, and estimate the amount of live data.
577 if (RtsFlags.GcFlags.generations == 1) {
580 if (old_to_space != NULL) {
581 freeChain(old_to_space);
583 for (bd = g0s0->to_space; bd != NULL; bd = bd->link) {
584 bd->evacuated = 0; /* now from-space */
587 /* For a two-space collector, we need to resize the nursery. */
589 /* set up a new nursery. Allocate a nursery size based on a
590 * function of the amount of live data (currently a factor of 2,
591 * should be configurable (ToDo)). Use the blocks from the old
592 * nursery if possible, freeing up any left over blocks.
594 * If we get near the maximum heap size, then adjust our nursery
595 * size accordingly. If the nursery is the same size as the live
596 * data (L), then we need 3L bytes. We can reduce the size of the
597 * nursery to bring the required memory down near 2L bytes.
599 * A normal 2-space collector would need 4L bytes to give the same
600 * performance we get from 3L bytes, reducing to the same
601 * performance at 2L bytes.
603 blocks = g0s0->to_blocks;
605 if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
606 RtsFlags.GcFlags.maxHeapSize ) {
607 int adjusted_blocks; /* signed on purpose */
610 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
611 IF_DEBUG(gc, fprintf(stderr, "Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %d\n", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
612 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
613 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
616 blocks = adjusted_blocks;
619 blocks *= RtsFlags.GcFlags.oldGenFactor;
620 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
621 blocks = RtsFlags.GcFlags.minAllocAreaSize;
624 resizeNursery(blocks);
627 /* Generational collector:
628 * If the user has given us a suggested heap size, adjust our
629 * allocation area to make best use of the memory available.
632 if (RtsFlags.GcFlags.heapSizeSuggestion) {
634 nat needed = calcNeeded(); /* approx blocks needed at next GC */
636 /* Guess how much will be live in generation 0 step 0 next time.
637 * A good approximation is the obtained by finding the
638 * percentage of g0s0 that was live at the last minor GC.
641 g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
644 /* Estimate a size for the allocation area based on the
645 * information available. We might end up going slightly under
646 * or over the suggested heap size, but we should be pretty
649 * Formula: suggested - needed
650 * ----------------------------
651 * 1 + g0s0_pcnt_kept/100
653 * where 'needed' is the amount of memory needed at the next
654 * collection for collecting all steps except g0s0.
657 (((int)RtsFlags.GcFlags.heapSizeSuggestion - (int)needed) * 100) /
658 (100 + (int)g0s0_pcnt_kept);
660 if (blocks < (int)RtsFlags.GcFlags.minAllocAreaSize) {
661 blocks = RtsFlags.GcFlags.minAllocAreaSize;
664 resizeNursery((nat)blocks);
668 /* revert dead CAFs and update enteredCAFs list */
671 /* mark the garbage collected CAFs as dead */
673 if (major_gc) { gcCAFs(); }
676 /* zero the scavenged static object list */
678 zero_static_object_list(scavenged_static_objects);
683 for (bd = g0s0->blocks; bd; bd = bd->link) {
684 bd->free = bd->start;
685 ASSERT(bd->gen == g0);
686 ASSERT(bd->step == g0s0);
687 IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
689 current_nursery = g0s0->blocks;
691 /* start any pending finalizers */
692 scheduleFinalizers(old_weak_ptr_list);
694 /* check sanity after GC */
695 IF_DEBUG(sanity, checkSanity(N));
697 /* extra GC trace info */
698 IF_DEBUG(gc, stat_describe_gens());
701 /* symbol-table based profiling */
702 /* heapCensus(to_space); */ /* ToDo */
705 /* restore enclosing cost centre */
710 /* check for memory leaks if sanity checking is on */
711 IF_DEBUG(sanity, memInventory());
713 /* ok, GC over: tell the stats department what happened. */
714 stat_endGC(allocated, collected, live, copied, N);
717 /* -----------------------------------------------------------------------------
720 traverse_weak_ptr_list is called possibly many times during garbage
721 collection. It returns a flag indicating whether it did any work
722 (i.e. called evacuate on any live pointers).
724 Invariant: traverse_weak_ptr_list is called when the heap is in an
725 idempotent state. That means that there are no pending
726 evacuate/scavenge operations. This invariant helps the weak
727 pointer code decide which weak pointers are dead - if there are no
728 new live weak pointers, then all the currently unreachable ones are
731 For generational GC: we just don't try to finalize weak pointers in
732 older generations than the one we're collecting. This could
733 probably be optimised by keeping per-generation lists of weak
734 pointers, but for a few weak pointers this scheme will work.
735 -------------------------------------------------------------------------- */
738 traverse_weak_ptr_list(void)
740 StgWeak *w, **last_w, *next_w;
742 rtsBool flag = rtsFalse;
744 if (weak_done) { return rtsFalse; }
746 /* doesn't matter where we evacuate values/finalizers to, since
747 * these pointers are treated as roots (iff the keys are alive).
751 last_w = &old_weak_ptr_list;
752 for (w = old_weak_ptr_list; w; w = next_w) {
754 /* First, this weak pointer might have been evacuated. If so,
755 * remove the forwarding pointer from the weak_ptr_list.
757 if (get_itbl(w)->type == EVACUATED) {
758 w = (StgWeak *)((StgEvacuated *)w)->evacuee;
761 ASSERT(get_itbl(w)->type == WEAK);
763 /* Now, check whether the key is reachable.
765 if ((new = isAlive(w->key))) {
767 /* evacuate the value and finalizer */
768 w->value = evacuate(w->value);
769 w->finalizer = evacuate(w->finalizer);
770 /* remove this weak ptr from the old_weak_ptr list */
772 /* and put it on the new weak ptr list */
774 w->link = weak_ptr_list;
777 IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
787 /* If we didn't make any changes, then we can go round and kill all
788 * the dead weak pointers. The old_weak_ptr list is used as a list
789 * of pending finalizers later on.
791 if (flag == rtsFalse) {
792 for (w = old_weak_ptr_list; w; w = w->link) {
793 w->value = evacuate(w->value);
794 w->finalizer = evacuate(w->finalizer);
802 /* -----------------------------------------------------------------------------
803 After GC, the live weak pointer list may have forwarding pointers
804 on it, because a weak pointer object was evacuated after being
805 moved to the live weak pointer list. We remove those forwarding
808 Also, we don't consider weak pointer objects to be reachable, but
809 we must nevertheless consider them to be "live" and retain them.
810 Therefore any weak pointer objects which haven't as yet been
811 evacuated need to be evacuated now.
812 -------------------------------------------------------------------------- */
815 cleanup_weak_ptr_list ( void )
817 StgWeak *w, **last_w;
819 last_w = &weak_ptr_list;
820 for (w = weak_ptr_list; w; w = w->link) {
822 if (get_itbl(w)->type == EVACUATED) {
823 w = (StgWeak *)((StgEvacuated *)w)->evacuee;
827 if (Bdescr((P_)w)->evacuated == 0) {
828 (StgClosure *)w = evacuate((StgClosure *)w);
835 /* -----------------------------------------------------------------------------
836 isAlive determines whether the given closure is still alive (after
837 a garbage collection) or not. It returns the new address of the
838 closure if it is alive, or NULL otherwise.
839 -------------------------------------------------------------------------- */
842 isAlive(StgClosure *p)
850 /* ToDo: for static closures, check the static link field.
851 * Problem here is that we sometimes don't set the link field, eg.
852 * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
855 /* ignore closures in generations that we're not collecting. */
856 if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
860 switch (info->type) {
865 case IND_OLDGEN: /* rely on compatible layout with StgInd */
866 case IND_OLDGEN_PERM:
867 /* follow indirections */
868 p = ((StgInd *)p)->indirectee;
873 return ((StgEvacuated *)p)->evacuee;
883 MarkRoot(StgClosure *root)
885 return evacuate(root);
888 static void addBlock(step *step)
890 bdescr *bd = allocBlock();
894 if (step->gen->no <= N) {
900 step->hp_bd->free = step->hp;
901 step->hp_bd->link = bd;
902 step->hp = bd->start;
903 step->hpLim = step->hp + BLOCK_SIZE_W;
909 static __inline__ void
910 upd_evacuee(StgClosure *p, StgClosure *dest)
912 p->header.info = &EVACUATED_info;
913 ((StgEvacuated *)p)->evacuee = dest;
916 static __inline__ StgClosure *
917 copy(StgClosure *src, nat size, step *step)
921 TICK_GC_WORDS_COPIED(size);
922 /* Find out where we're going, using the handy "to" pointer in
923 * the step of the source object. If it turns out we need to
924 * evacuate to an older generation, adjust it here (see comment
927 if (step->gen->no < evac_gen) {
928 #ifdef NO_EAGER_PROMOTION
929 failed_to_evac = rtsTrue;
931 step = &generations[evac_gen].steps[0];
935 /* chain a new block onto the to-space for the destination step if
938 if (step->hp + size >= step->hpLim) {
942 for(to = step->hp, from = (P_)src; size>0; --size) {
948 upd_evacuee(src,(StgClosure *)dest);
949 return (StgClosure *)dest;
952 /* Special version of copy() for when we only want to copy the info
953 * pointer of an object, but reserve some padding after it. This is
954 * used to optimise evacuation of BLACKHOLEs.
957 static __inline__ StgClosure *
958 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
962 TICK_GC_WORDS_COPIED(size_to_copy);
963 if (step->gen->no < evac_gen) {
964 #ifdef NO_EAGER_PROMOTION
965 failed_to_evac = rtsTrue;
967 step = &generations[evac_gen].steps[0];
971 if (step->hp + size_to_reserve >= step->hpLim) {
975 for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
980 step->hp += size_to_reserve;
981 upd_evacuee(src,(StgClosure *)dest);
982 return (StgClosure *)dest;
985 /* -----------------------------------------------------------------------------
986 Evacuate a large object
988 This just consists of removing the object from the (doubly-linked)
989 large_alloc_list, and linking it on to the (singly-linked)
990 new_large_objects list, from where it will be scavenged later.
992 Convention: bd->evacuated is /= 0 for a large object that has been
993 evacuated, or 0 otherwise.
994 -------------------------------------------------------------------------- */
997 evacuate_large(StgPtr p, rtsBool mutable)
999 bdescr *bd = Bdescr(p);
1002 /* should point to the beginning of the block */
1003 ASSERT(((W_)p & BLOCK_MASK) == 0);
1005 /* already evacuated? */
1006 if (bd->evacuated) {
1007 /* Don't forget to set the failed_to_evac flag if we didn't get
1008 * the desired destination (see comments in evacuate()).
1010 if (bd->gen->no < evac_gen) {
1011 failed_to_evac = rtsTrue;
1012 TICK_GC_FAILED_PROMOTION();
1018 /* remove from large_object list */
1020 bd->back->link = bd->link;
1021 } else { /* first object in the list */
1022 step->large_objects = bd->link;
1025 bd->link->back = bd->back;
1028 /* link it on to the evacuated large object list of the destination step
1030 step = bd->step->to;
1031 if (step->gen->no < evac_gen) {
1032 #ifdef NO_EAGER_PROMOTION
1033 failed_to_evac = rtsTrue;
1035 step = &generations[evac_gen].steps[0];
1040 bd->gen = step->gen;
1041 bd->link = step->new_large_objects;
1042 step->new_large_objects = bd;
1046 recordMutable((StgMutClosure *)p);
1050 /* -----------------------------------------------------------------------------
1051 Adding a MUT_CONS to an older generation.
1053 This is necessary from time to time when we end up with an
1054 old-to-new generation pointer in a non-mutable object. We defer
1055 the promotion until the next GC.
1056 -------------------------------------------------------------------------- */
1059 mkMutCons(StgClosure *ptr, generation *gen)
1064 step = &gen->steps[0];
1066 /* chain a new block onto the to-space for the destination step if
1069 if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
1073 q = (StgMutVar *)step->hp;
1074 step->hp += sizeofW(StgMutVar);
1076 SET_HDR(q,&MUT_CONS_info,CCS_GC);
1078 recordOldToNewPtrs((StgMutClosure *)q);
1080 return (StgClosure *)q;
1083 /* -----------------------------------------------------------------------------
1086 This is called (eventually) for every live object in the system.
1088 The caller to evacuate specifies a desired generation in the
1089 evac_gen global variable. The following conditions apply to
1090 evacuating an object which resides in generation M when we're
1091 collecting up to generation N
1095 else evac to step->to
1097 if M < evac_gen evac to evac_gen, step 0
1099 if the object is already evacuated, then we check which generation
1102 if M >= evac_gen do nothing
1103 if M < evac_gen set failed_to_evac flag to indicate that we
1104 didn't manage to evacuate this object into evac_gen.
1106 -------------------------------------------------------------------------- */
1110 evacuate(StgClosure *q)
1115 const StgInfoTable *info;
1118 if (!LOOKS_LIKE_STATIC(q)) {
1120 if (bd->gen->no > N) {
1121 /* Can't evacuate this object, because it's in a generation
1122 * older than the ones we're collecting. Let's hope that it's
1123 * in evac_gen or older, or we will have to make an IND_OLDGEN object.
1125 if (bd->gen->no < evac_gen) {
1127 failed_to_evac = rtsTrue;
1128 TICK_GC_FAILED_PROMOTION();
1132 step = bd->step->to;
1135 /* make sure the info pointer is into text space */
1136 ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1137 || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1140 switch (info -> type) {
1143 return copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
1146 ASSERT(q->header.info != &MUT_CONS_info);
1148 to = copy(q,sizeW_fromITBL(info),step);
1149 recordMutable((StgMutClosure *)to);
1156 return copy(q,sizeofW(StgHeader)+1,step);
1158 case THUNK_1_0: /* here because of MIN_UPD_SIZE */
1163 #ifdef NO_PROMOTE_THUNKS
1164 if (bd->gen->no == 0 &&
1165 bd->step->no != 0 &&
1166 bd->step->no == bd->gen->n_steps-1) {
1170 return copy(q,sizeofW(StgHeader)+2,step);
1178 return copy(q,sizeofW(StgHeader)+2,step);
1184 case IND_OLDGEN_PERM:
1190 return copy(q,sizeW_fromITBL(info),step);
1194 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1197 to = copy(q,BLACKHOLE_sizeW(),step);
1198 recordMutable((StgMutClosure *)to);
1201 case THUNK_SELECTOR:
1203 const StgInfoTable* selectee_info;
1204 StgClosure* selectee = ((StgSelector*)q)->selectee;
1207 selectee_info = get_itbl(selectee);
1208 switch (selectee_info->type) {
1217 StgNat32 offset = info->layout.selector_offset;
1219 /* check that the size is in range */
1221 (StgNat32)(selectee_info->layout.payload.ptrs +
1222 selectee_info->layout.payload.nptrs));
1224 /* perform the selection! */
1225 q = selectee->payload[offset];
1227 /* if we're already in to-space, there's no need to continue
1228 * with the evacuation, just update the source address with
1229 * a pointer to the (evacuated) constructor field.
1231 if (IS_USER_PTR(q)) {
1232 bdescr *bd = Bdescr((P_)q);
1233 if (bd->evacuated) {
1234 if (bd->gen->no < evac_gen) {
1235 failed_to_evac = rtsTrue;
1236 TICK_GC_FAILED_PROMOTION();
1242 /* otherwise, carry on and evacuate this constructor field,
1243 * (but not the constructor itself)
1252 case IND_OLDGEN_PERM:
1253 selectee = stgCast(StgInd *,selectee)->indirectee;
1257 selectee = stgCast(StgCAF *,selectee)->value;
1261 selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1271 case THUNK_SELECTOR:
1272 /* aargh - do recursively???? */
1277 /* not evaluated yet */
1281 barf("evacuate: THUNK_SELECTOR: strange selectee");
1284 return copy(q,THUNK_SELECTOR_sizeW(),step);
1288 /* follow chains of indirections, don't evacuate them */
1289 q = ((StgInd*)q)->indirectee;
1292 /* ToDo: optimise STATIC_LINK for known cases.
1293 - FUN_STATIC : payload[0]
1294 - THUNK_STATIC : payload[1]
1295 - IND_STATIC : payload[1]
1299 if (info->srt_len == 0) { /* small optimisation */
1305 /* don't want to evacuate these, but we do want to follow pointers
1306 * from SRTs - see scavenge_static.
1309 /* put the object on the static list, if necessary.
1311 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1312 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1313 static_objects = (StgClosure *)q;
1317 case CONSTR_INTLIKE:
1318 case CONSTR_CHARLIKE:
1319 case CONSTR_NOCAF_STATIC:
1320 /* no need to put these on the static linked list, they don't need
1335 /* shouldn't see these */
1336 barf("evacuate: stack frame\n");
1340 /* these are special - the payload is a copy of a chunk of stack,
1342 return copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1345 /* Already evacuated, just return the forwarding address.
1346 * HOWEVER: if the requested destination generation (evac_gen) is
1347 * older than the actual generation (because the object was
1348 * already evacuated to a younger generation) then we have to
1349 * set the failed_to_evac flag to indicate that we couldn't
1350 * manage to promote the object to the desired generation.
1352 if (evac_gen > 0) { /* optimisation */
1353 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1354 if (Bdescr((P_)p)->gen->no < evac_gen) {
1355 /* fprintf(stderr,"evac failed!\n");*/
1356 failed_to_evac = rtsTrue;
1357 TICK_GC_FAILED_PROMOTION();
1360 return ((StgEvacuated*)q)->evacuee;
1364 nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1366 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1367 evacuate_large((P_)q, rtsFalse);
1370 /* just copy the block */
1371 return copy(q,size,step);
1376 case MUT_ARR_PTRS_FROZEN:
1378 nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1380 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1381 evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1384 /* just copy the block */
1385 to = copy(q,size,step);
1386 if (info->type == MUT_ARR_PTRS) {
1387 recordMutable((StgMutClosure *)to);
1395 StgTSO *tso = stgCast(StgTSO *,q);
1396 nat size = tso_sizeW(tso);
1399 /* Large TSOs don't get moved, so no relocation is required.
1401 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1402 evacuate_large((P_)q, rtsTrue);
1405 /* To evacuate a small TSO, we need to relocate the update frame
1409 StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1411 diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1413 /* relocate the stack pointers... */
1414 new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1415 new_tso->sp = (StgPtr)new_tso->sp + diff;
1416 new_tso->splim = (StgPtr)new_tso->splim + diff;
1418 relocate_TSO(tso, new_tso);
1420 recordMutable((StgMutClosure *)new_tso);
1421 return (StgClosure *)new_tso;
1427 fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1431 barf("evacuate: strange closure type");
1437 /* -----------------------------------------------------------------------------
1438 relocate_TSO is called just after a TSO has been copied from src to
1439 dest. It adjusts the update frame list for the new location.
1440 -------------------------------------------------------------------------- */
1443 relocate_TSO(StgTSO *src, StgTSO *dest)
1450 diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1454 while ((P_)su < dest->stack + dest->stack_size) {
1455 switch (get_itbl(su)->type) {
1457 /* GCC actually manages to common up these three cases! */
1460 su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1465 cf = (StgCatchFrame *)su;
1466 cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1471 sf = (StgSeqFrame *)su;
1472 sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1481 barf("relocate_TSO");
1490 scavenge_srt(const StgInfoTable *info)
1492 StgClosure **srt, **srt_end;
1494 /* evacuate the SRT. If srt_len is zero, then there isn't an
1495 * srt field in the info table. That's ok, because we'll
1496 * never dereference it.
1498 srt = stgCast(StgClosure **,info->srt);
1499 srt_end = srt + info->srt_len;
1500 for (; srt < srt_end; srt++) {
1505 /* -----------------------------------------------------------------------------
1506 Scavenge a given step until there are no more objects in this step
1509 evac_gen is set by the caller to be either zero (for a step in a
1510 generation < N) or G where G is the generation of the step being
1513 We sometimes temporarily change evac_gen back to zero if we're
1514 scavenging a mutable object where early promotion isn't such a good
1516 -------------------------------------------------------------------------- */
1520 scavenge(step *step)
1523 const StgInfoTable *info;
1525 nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1530 failed_to_evac = rtsFalse;
1532 /* scavenge phase - standard breadth-first scavenging of the
1536 while (bd != step->hp_bd || p < step->hp) {
1538 /* If we're at the end of this block, move on to the next block */
1539 if (bd != step->hp_bd && p == bd->free) {
1545 q = p; /* save ptr to object */
1547 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1548 || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1550 info = get_itbl((StgClosure *)p);
1551 switch (info -> type) {
1555 StgBCO* bco = stgCast(StgBCO*,p);
1557 for (i = 0; i < bco->n_ptrs; i++) {
1558 bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1560 p += bco_sizeW(bco);
1565 /* treat MVars specially, because we don't want to evacuate the
1566 * mut_link field in the middle of the closure.
1569 StgMVar *mvar = ((StgMVar *)p);
1571 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1572 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1573 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1574 p += sizeofW(StgMVar);
1575 evac_gen = saved_evac_gen;
1583 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1584 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1585 p += sizeofW(StgHeader) + 2;
1590 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1591 p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1597 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1598 p += sizeofW(StgHeader) + 1;
1603 p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1609 p += sizeofW(StgHeader) + 1;
1616 p += sizeofW(StgHeader) + 2;
1623 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1624 p += sizeofW(StgHeader) + 2;
1637 case IND_OLDGEN_PERM:
1643 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1644 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1645 (StgClosure *)*p = evacuate((StgClosure *)*p);
1647 p += info->layout.payload.nptrs;
1652 /* ignore MUT_CONSs */
1653 if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1655 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1656 evac_gen = saved_evac_gen;
1658 p += sizeofW(StgMutVar);
1663 p += BLACKHOLE_sizeW();
1668 StgBlockingQueue *bh = (StgBlockingQueue *)p;
1669 (StgClosure *)bh->blocking_queue =
1670 evacuate((StgClosure *)bh->blocking_queue);
1671 if (failed_to_evac) {
1672 failed_to_evac = rtsFalse;
1673 recordMutable((StgMutClosure *)bh);
1675 p += BLACKHOLE_sizeW();
1679 case THUNK_SELECTOR:
1681 StgSelector *s = (StgSelector *)p;
1682 s->selectee = evacuate(s->selectee);
1683 p += THUNK_SELECTOR_sizeW();
1689 barf("scavenge:IND???\n");
1691 case CONSTR_INTLIKE:
1692 case CONSTR_CHARLIKE:
1694 case CONSTR_NOCAF_STATIC:
1698 /* Shouldn't see a static object here. */
1699 barf("scavenge: STATIC object\n");
1711 /* Shouldn't see stack frames here. */
1712 barf("scavenge: stack frame\n");
1714 case AP_UPD: /* same as PAPs */
1716 /* Treat a PAP just like a section of stack, not forgetting to
1717 * evacuate the function pointer too...
1720 StgPAP* pap = stgCast(StgPAP*,p);
1722 pap->fun = evacuate(pap->fun);
1723 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1724 p += pap_sizeW(pap);
1729 /* nothing to follow */
1730 p += arr_words_sizeW(stgCast(StgArrWords*,p));
1734 /* follow everything */
1738 evac_gen = 0; /* repeatedly mutable */
1739 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1740 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1741 (StgClosure *)*p = evacuate((StgClosure *)*p);
1743 evac_gen = saved_evac_gen;
1747 case MUT_ARR_PTRS_FROZEN:
1748 /* follow everything */
1750 StgPtr start = p, next;
1752 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1753 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1754 (StgClosure *)*p = evacuate((StgClosure *)*p);
1756 if (failed_to_evac) {
1757 /* we can do this easier... */
1758 recordMutable((StgMutClosure *)start);
1759 failed_to_evac = rtsFalse;
1770 /* chase the link field for any TSOs on the same queue */
1771 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1772 /* scavenge this thread's stack */
1773 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1774 evac_gen = saved_evac_gen;
1775 p += tso_sizeW(tso);
1782 barf("scavenge: unimplemented/strange closure type\n");
1788 /* If we didn't manage to promote all the objects pointed to by
1789 * the current object, then we have to designate this object as
1790 * mutable (because it contains old-to-new generation pointers).
1792 if (failed_to_evac) {
1793 mkMutCons((StgClosure *)q, &generations[evac_gen]);
1794 failed_to_evac = rtsFalse;
1802 /* -----------------------------------------------------------------------------
1803 Scavenge one object.
1805 This is used for objects that are temporarily marked as mutable
1806 because they contain old-to-new generation pointers. Only certain
1807 objects can have this property.
1808 -------------------------------------------------------------------------- */
1810 scavenge_one(StgClosure *p)
1815 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1816 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1820 switch (info -> type) {
1823 case FUN_1_0: /* hardly worth specialising these guys */
1843 case IND_OLDGEN_PERM:
1849 end = (P_)p->payload + info->layout.payload.ptrs;
1850 for (q = (P_)p->payload; q < end; q++) {
1851 (StgClosure *)*q = evacuate((StgClosure *)*q);
1860 case THUNK_SELECTOR:
1862 StgSelector *s = (StgSelector *)p;
1863 s->selectee = evacuate(s->selectee);
1867 case AP_UPD: /* same as PAPs */
1869 /* Treat a PAP just like a section of stack, not forgetting to
1870 * evacuate the function pointer too...
1873 StgPAP* pap = (StgPAP *)p;
1875 pap->fun = evacuate(pap->fun);
1876 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1881 /* This might happen if for instance a MUT_CONS was pointing to a
1882 * THUNK which has since been updated. The IND_OLDGEN will
1883 * be on the mutable list anyway, so we don't need to do anything
1889 barf("scavenge_one: strange object");
1892 no_luck = failed_to_evac;
1893 failed_to_evac = rtsFalse;
1898 /* -----------------------------------------------------------------------------
1899 Scavenging mutable lists.
1901 We treat the mutable list of each generation > N (i.e. all the
1902 generations older than the one being collected) as roots. We also
1903 remove non-mutable objects from the mutable list at this point.
1904 -------------------------------------------------------------------------- */
1907 scavenge_mut_once_list(generation *gen)
1910 StgMutClosure *p, *next, *new_list;
1912 p = gen->mut_once_list;
1913 new_list = END_MUT_LIST;
1917 failed_to_evac = rtsFalse;
1919 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1921 /* make sure the info pointer is into text space */
1922 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1923 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1926 switch(info->type) {
1929 case IND_OLDGEN_PERM:
1931 /* Try to pull the indirectee into this generation, so we can
1932 * remove the indirection from the mutable list.
1934 ((StgIndOldGen *)p)->indirectee =
1935 evacuate(((StgIndOldGen *)p)->indirectee);
1938 /* Debugging code to print out the size of the thing we just
1942 StgPtr start = gen->steps[0].scan;
1943 bdescr *start_bd = gen->steps[0].scan_bd;
1945 scavenge(&gen->steps[0]);
1946 if (start_bd != gen->steps[0].scan_bd) {
1947 size += (P_)BLOCK_ROUND_UP(start) - start;
1948 start_bd = start_bd->link;
1949 while (start_bd != gen->steps[0].scan_bd) {
1950 size += BLOCK_SIZE_W;
1951 start_bd = start_bd->link;
1953 size += gen->steps[0].scan -
1954 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
1956 size = gen->steps[0].scan - start;
1958 fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
1962 /* failed_to_evac might happen if we've got more than two
1963 * generations, we're collecting only generation 0, the
1964 * indirection resides in generation 2 and the indirectee is
1967 if (failed_to_evac) {
1968 failed_to_evac = rtsFalse;
1969 p->mut_link = new_list;
1972 /* the mut_link field of an IND_STATIC is overloaded as the
1973 * static link field too (it just so happens that we don't need
1974 * both at the same time), so we need to NULL it out when
1975 * removing this object from the mutable list because the static
1976 * link fields are all assumed to be NULL before doing a major
1984 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
1985 * it from the mutable list if possible by promoting whatever it
1988 ASSERT(p->header.info == &MUT_CONS_info);
1989 if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
1990 /* didn't manage to promote everything, so put the
1991 * MUT_CONS back on the list.
1993 p->mut_link = new_list;
1999 /* shouldn't have anything else on the mutables list */
2000 barf("scavenge_mut_once_list: strange object?");
2004 gen->mut_once_list = new_list;
2009 scavenge_mutable_list(generation *gen)
2012 StgMutClosure *p, *next;
2014 p = gen->saved_mut_list;
2018 failed_to_evac = rtsFalse;
2020 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2022 /* make sure the info pointer is into text space */
2023 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2024 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2027 switch(info->type) {
2029 case MUT_ARR_PTRS_FROZEN:
2030 /* remove this guy from the mutable list, but follow the ptrs
2031 * anyway (and make sure they get promoted to this gen).
2036 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2038 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2039 (StgClosure *)*q = evacuate((StgClosure *)*q);
2043 if (failed_to_evac) {
2044 failed_to_evac = rtsFalse;
2045 p->mut_link = gen->mut_list;
2052 /* follow everything */
2053 p->mut_link = gen->mut_list;
2058 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2059 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2060 (StgClosure *)*q = evacuate((StgClosure *)*q);
2066 /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2067 * it from the mutable list if possible by promoting whatever it
2070 ASSERT(p->header.info != &MUT_CONS_info);
2071 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2072 p->mut_link = gen->mut_list;
2078 StgMVar *mvar = (StgMVar *)p;
2079 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2080 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2081 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2082 p->mut_link = gen->mut_list;
2088 /* follow ptrs and remove this from the mutable list */
2090 StgTSO *tso = (StgTSO *)p;
2092 /* Don't bother scavenging if this thread is dead
2094 if (!(tso->whatNext == ThreadComplete ||
2095 tso->whatNext == ThreadKilled)) {
2096 /* Don't need to chase the link field for any TSOs on the
2097 * same queue. Just scavenge this thread's stack
2099 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2102 /* Don't take this TSO off the mutable list - it might still
2103 * point to some younger objects (because we set evac_gen to 0
2106 tso->mut_link = gen->mut_list;
2107 gen->mut_list = (StgMutClosure *)tso;
2113 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2114 (StgClosure *)bh->blocking_queue =
2115 evacuate((StgClosure *)bh->blocking_queue);
2116 p->mut_link = gen->mut_list;
2122 /* shouldn't have anything else on the mutables list */
2123 barf("scavenge_mut_list: strange object?");
2129 scavenge_static(void)
2131 StgClosure* p = static_objects;
2132 const StgInfoTable *info;
2134 /* Always evacuate straight to the oldest generation for static
2136 evac_gen = oldest_gen->no;
2138 /* keep going until we've scavenged all the objects on the linked
2140 while (p != END_OF_STATIC_LIST) {
2144 /* make sure the info pointer is into text space */
2145 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2146 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2148 /* Take this object *off* the static_objects list,
2149 * and put it on the scavenged_static_objects list.
2151 static_objects = STATIC_LINK(info,p);
2152 STATIC_LINK(info,p) = scavenged_static_objects;
2153 scavenged_static_objects = p;
2155 switch (info -> type) {
2159 StgInd *ind = (StgInd *)p;
2160 ind->indirectee = evacuate(ind->indirectee);
2162 /* might fail to evacuate it, in which case we have to pop it
2163 * back on the mutable list (and take it off the
2164 * scavenged_static list because the static link and mut link
2165 * pointers are one and the same).
2167 if (failed_to_evac) {
2168 failed_to_evac = rtsFalse;
2169 scavenged_static_objects = STATIC_LINK(info,p);
2170 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2171 oldest_gen->mut_once_list = (StgMutClosure *)ind;
2185 next = (P_)p->payload + info->layout.payload.ptrs;
2186 /* evacuate the pointers */
2187 for (q = (P_)p->payload; q < next; q++) {
2188 (StgClosure *)*q = evacuate((StgClosure *)*q);
2194 barf("scavenge_static");
2197 ASSERT(failed_to_evac == rtsFalse);
2199 /* get the next static object from the list. Remeber, there might
2200 * be more stuff on this list now that we've done some evacuating!
2201 * (static_objects is a global)
2207 /* -----------------------------------------------------------------------------
2208 scavenge_stack walks over a section of stack and evacuates all the
2209 objects pointed to by it. We can use the same code for walking
2210 PAPs, since these are just sections of copied stack.
2211 -------------------------------------------------------------------------- */
2214 scavenge_stack(StgPtr p, StgPtr stack_end)
2217 const StgInfoTable* info;
2221 * Each time around this loop, we are looking at a chunk of stack
2222 * that starts with either a pending argument section or an
2223 * activation record.
2226 while (p < stack_end) {
2227 q = *stgCast(StgPtr*,p);
2229 /* If we've got a tag, skip over that many words on the stack */
2230 if (IS_ARG_TAG(stgCast(StgWord,q))) {
2235 /* Is q a pointer to a closure?
2237 if (! LOOKS_LIKE_GHC_INFO(q)) {
2240 if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
2241 ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2243 /* otherwise, must be a pointer into the allocation space.
2247 (StgClosure *)*p = evacuate((StgClosure *)q);
2253 * Otherwise, q must be the info pointer of an activation
2254 * record. All activation records have 'bitmap' style layout
2257 info = get_itbl(stgCast(StgClosure*,p));
2259 switch (info->type) {
2261 /* Dynamic bitmap: the mask is stored on the stack */
2263 bitmap = stgCast(StgRetDyn*,p)->liveness;
2264 p = &payloadWord(stgCast(StgRetDyn*,p),0);
2267 /* probably a slow-entry point return address: */
2273 /* Specialised code for update frames, since they're so common.
2274 * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2275 * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2279 StgUpdateFrame *frame = (StgUpdateFrame *)p;
2281 StgClosureType type = get_itbl(frame->updatee)->type;
2283 p += sizeofW(StgUpdateFrame);
2284 if (type == EVACUATED) {
2285 frame->updatee = evacuate(frame->updatee);
2288 bdescr *bd = Bdescr((P_)frame->updatee);
2290 if (bd->gen->no > N) {
2291 if (bd->gen->no < evac_gen) {
2292 failed_to_evac = rtsTrue;
2297 /* Don't promote blackholes */
2299 if (!(step->gen->no == 0 &&
2301 step->no == step->gen->n_steps-1)) {
2308 to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2309 sizeofW(StgHeader), step);
2310 frame->updatee = to;
2313 to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2314 frame->updatee = to;
2315 recordMutable((StgMutClosure *)to);
2318 barf("scavenge_stack: UPDATE_FRAME updatee");
2323 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2330 bitmap = info->layout.bitmap;
2333 while (bitmap != 0) {
2334 if ((bitmap & 1) == 0) {
2335 (StgClosure *)*p = evacuate((StgClosure *)*p);
2338 bitmap = bitmap >> 1;
2345 /* large bitmap (> 32 entries) */
2350 StgLargeBitmap *large_bitmap;
2353 large_bitmap = info->layout.large_bitmap;
2356 for (i=0; i<large_bitmap->size; i++) {
2357 bitmap = large_bitmap->bitmap[i];
2358 q = p + sizeof(W_) * 8;
2359 while (bitmap != 0) {
2360 if ((bitmap & 1) == 0) {
2361 (StgClosure *)*p = evacuate((StgClosure *)*p);
2364 bitmap = bitmap >> 1;
2366 if (i+1 < large_bitmap->size) {
2368 (StgClosure *)*p = evacuate((StgClosure *)*p);
2374 /* and don't forget to follow the SRT */
2379 barf("scavenge_stack: weird activation record found on stack.\n");
2384 /*-----------------------------------------------------------------------------
2385 scavenge the large object list.
2387 evac_gen set by caller; similar games played with evac_gen as with
2388 scavenge() - see comment at the top of scavenge(). Most large
2389 objects are (repeatedly) mutable, so most of the time evac_gen will
2391 --------------------------------------------------------------------------- */
2394 scavenge_large(step *step)
2398 const StgInfoTable* info;
2399 nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2401 evac_gen = 0; /* most objects are mutable */
2402 bd = step->new_large_objects;
2404 for (; bd != NULL; bd = step->new_large_objects) {
2406 /* take this object *off* the large objects list and put it on
2407 * the scavenged large objects list. This is so that we can
2408 * treat new_large_objects as a stack and push new objects on
2409 * the front when evacuating.
2411 step->new_large_objects = bd->link;
2412 dbl_link_onto(bd, &step->scavenged_large_objects);
2415 info = get_itbl(stgCast(StgClosure*,p));
2417 switch (info->type) {
2419 /* only certain objects can be "large"... */
2422 /* nothing to follow */
2426 /* follow everything */
2430 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2431 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2432 (StgClosure *)*p = evacuate((StgClosure *)*p);
2437 case MUT_ARR_PTRS_FROZEN:
2438 /* follow everything */
2440 StgPtr start = p, next;
2442 evac_gen = saved_evac_gen; /* not really mutable */
2443 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2444 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2445 (StgClosure *)*p = evacuate((StgClosure *)*p);
2448 if (failed_to_evac) {
2449 recordMutable((StgMutClosure *)start);
2456 StgBCO* bco = stgCast(StgBCO*,p);
2458 evac_gen = saved_evac_gen;
2459 for (i = 0; i < bco->n_ptrs; i++) {
2460 bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2471 /* chase the link field for any TSOs on the same queue */
2472 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2473 /* scavenge this thread's stack */
2474 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2479 barf("scavenge_large: unknown/strange object");
2485 zero_static_object_list(StgClosure* first_static)
2489 const StgInfoTable *info;
2491 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2493 link = STATIC_LINK(info, p);
2494 STATIC_LINK(info,p) = NULL;
2498 /* This function is only needed because we share the mutable link
2499 * field with the static link field in an IND_STATIC, so we have to
2500 * zero the mut_link field before doing a major GC, which needs the
2501 * static link field.
2503 * It doesn't do any harm to zero all the mutable link fields on the
2507 zero_mutable_list( StgMutClosure *first )
2509 StgMutClosure *next, *c;
2511 for (c = first; c != END_MUT_LIST; c = next) {
2517 /* -----------------------------------------------------------------------------
2519 -------------------------------------------------------------------------- */
2521 void RevertCAFs(void)
2523 while (enteredCAFs != END_CAF_LIST) {
2524 StgCAF* caf = enteredCAFs;
2526 enteredCAFs = caf->link;
2527 ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2528 SET_INFO(caf,&CAF_UNENTERED_info);
2529 caf->value = stgCast(StgClosure*,0xdeadbeef);
2530 caf->link = stgCast(StgCAF*,0xdeadbeef);
2534 void revert_dead_CAFs(void)
2536 StgCAF* caf = enteredCAFs;
2537 enteredCAFs = END_CAF_LIST;
2538 while (caf != END_CAF_LIST) {
2539 StgCAF* next = caf->link;
2541 switch(GET_INFO(caf)->type) {
2544 /* This object has been evacuated, it must be live. */
2545 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2546 new->link = enteredCAFs;
2552 SET_INFO(caf,&CAF_UNENTERED_info);
2553 caf->value = stgCast(StgClosure*,0xdeadbeef);
2554 caf->link = stgCast(StgCAF*,0xdeadbeef);
2558 barf("revert_dead_CAFs: enteredCAFs list corrupted");
2564 /* -----------------------------------------------------------------------------
2565 Sanity code for CAF garbage collection.
2567 With DEBUG turned on, we manage a CAF list in addition to the SRT
2568 mechanism. After GC, we run down the CAF list and blackhole any
2569 CAFs which have been garbage collected. This means we get an error
2570 whenever the program tries to enter a garbage collected CAF.
2572 Any garbage collected CAFs are taken off the CAF list at the same
2574 -------------------------------------------------------------------------- */
2582 const StgInfoTable *info;
2593 ASSERT(info->type == IND_STATIC);
2595 if (STATIC_LINK(info,p) == NULL) {
2596 IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2598 SET_INFO(p,&BLACKHOLE_info);
2599 p = STATIC_LINK2(info,p);
2603 pp = &STATIC_LINK2(info,p);
2610 /* fprintf(stderr, "%d CAFs live\n", i); */
2614 /* -----------------------------------------------------------------------------
2617 Whenever a thread returns to the scheduler after possibly doing
2618 some work, we have to run down the stack and black-hole all the
2619 closures referred to by update frames.
2620 -------------------------------------------------------------------------- */
2623 threadLazyBlackHole(StgTSO *tso)
2625 StgUpdateFrame *update_frame;
2626 StgBlockingQueue *bh;
2629 stack_end = &tso->stack[tso->stack_size];
2630 update_frame = tso->su;
2633 switch (get_itbl(update_frame)->type) {
2636 update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2640 bh = (StgBlockingQueue *)update_frame->updatee;
2642 /* if the thunk is already blackholed, it means we've also
2643 * already blackholed the rest of the thunks on this stack,
2644 * so we can stop early.
2646 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2647 * don't interfere with this optimisation.
2649 if (bh->header.info == &BLACKHOLE_info) {
2653 if (bh->header.info != &BLACKHOLE_BQ_info &&
2654 bh->header.info != &CAF_BLACKHOLE_info) {
2655 SET_INFO(bh,&BLACKHOLE_info);
2658 update_frame = update_frame->link;
2662 update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2668 barf("threadPaused");
2673 /* -----------------------------------------------------------------------------
2676 * Code largely pinched from old RTS, then hacked to bits. We also do
2677 * lazy black holing here.
2679 * -------------------------------------------------------------------------- */
2682 threadSqueezeStack(StgTSO *tso)
2684 lnat displacement = 0;
2685 StgUpdateFrame *frame;
2686 StgUpdateFrame *next_frame; /* Temporally next */
2687 StgUpdateFrame *prev_frame; /* Temporally previous */
2689 rtsBool prev_was_update_frame;
2691 bottom = &(tso->stack[tso->stack_size]);
2694 /* There must be at least one frame, namely the STOP_FRAME.
2696 ASSERT((P_)frame < bottom);
2698 /* Walk down the stack, reversing the links between frames so that
2699 * we can walk back up as we squeeze from the bottom. Note that
2700 * next_frame and prev_frame refer to next and previous as they were
2701 * added to the stack, rather than the way we see them in this
2702 * walk. (It makes the next loop less confusing.)
2704 * Stop if we find an update frame pointing to a black hole
2705 * (see comment in threadLazyBlackHole()).
2709 while ((P_)frame < bottom - 1) { /* bottom - 1 is the STOP_FRAME */
2710 prev_frame = frame->link;
2711 frame->link = next_frame;
2714 if (get_itbl(frame)->type == UPDATE_FRAME
2715 && frame->updatee->header.info == &BLACKHOLE_info) {
2720 /* Now, we're at the bottom. Frame points to the lowest update
2721 * frame on the stack, and its link actually points to the frame
2722 * above. We have to walk back up the stack, squeezing out empty
2723 * update frames and turning the pointers back around on the way
2726 * The bottom-most frame (the STOP_FRAME) has not been altered, and
2727 * we never want to eliminate it anyway. Just walk one step up
2728 * before starting to squeeze. When you get to the topmost frame,
2729 * remember that there are still some words above it that might have
2736 prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2739 * Loop through all of the frames (everything except the very
2740 * bottom). Things are complicated by the fact that we have
2741 * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2742 * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2744 while (frame != NULL) {
2746 StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2747 rtsBool is_update_frame;
2749 next_frame = frame->link;
2750 is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2753 * 1. both the previous and current frame are update frames
2754 * 2. the current frame is empty
2756 if (prev_was_update_frame && is_update_frame &&
2757 (P_)prev_frame == frame_bottom + displacement) {
2759 /* Now squeeze out the current frame */
2760 StgClosure *updatee_keep = prev_frame->updatee;
2761 StgClosure *updatee_bypass = frame->updatee;
2764 fprintf(stderr, "squeezing frame at %p\n", frame);
2767 /* Deal with blocking queues. If both updatees have blocked
2768 * threads, then we should merge the queues into the update
2769 * frame that we're keeping.
2771 * Alternatively, we could just wake them up: they'll just go
2772 * straight to sleep on the proper blackhole! This is less code
2773 * and probably less bug prone, although it's probably much
2776 #if 0 /* do it properly... */
2777 if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
2778 /* Sigh. It has one. Don't lose those threads! */
2779 if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2780 /* Urgh. Two queues. Merge them. */
2781 P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2783 while (keep_tso->link != END_TSO_QUEUE) {
2784 keep_tso = keep_tso->link;
2786 keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2789 /* For simplicity, just swap the BQ for the BH */
2790 P_ temp = updatee_keep;
2792 updatee_keep = updatee_bypass;
2793 updatee_bypass = temp;
2795 /* Record the swap in the kept frame (below) */
2796 prev_frame->updatee = updatee_keep;
2801 TICK_UPD_SQUEEZED();
2802 UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2804 sp = (P_)frame - 1; /* sp = stuff to slide */
2805 displacement += sizeofW(StgUpdateFrame);
2808 /* No squeeze for this frame */
2809 sp = frame_bottom - 1; /* Keep the current frame */
2811 /* Do lazy black-holing.
2813 if (is_update_frame) {
2814 StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2815 if (bh->header.info != &BLACKHOLE_BQ_info &&
2816 bh->header.info != &CAF_BLACKHOLE_info) {
2817 SET_INFO(bh,&BLACKHOLE_info);
2821 /* Fix the link in the current frame (should point to the frame below) */
2822 frame->link = prev_frame;
2823 prev_was_update_frame = is_update_frame;
2826 /* Now slide all words from sp up to the next frame */
2828 if (displacement > 0) {
2829 P_ next_frame_bottom;
2831 if (next_frame != NULL)
2832 next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2834 next_frame_bottom = tso->sp - 1;
2837 fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2841 while (sp >= next_frame_bottom) {
2842 sp[displacement] = *sp;
2846 (P_)prev_frame = (P_)frame + displacement;
2850 tso->sp += displacement;
2851 tso->su = prev_frame;
2854 /* -----------------------------------------------------------------------------
2857 * We have to prepare for GC - this means doing lazy black holing
2858 * here. We also take the opportunity to do stack squeezing if it's
2860 * -------------------------------------------------------------------------- */
2863 threadPaused(StgTSO *tso)
2865 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2866 threadSqueezeStack(tso); /* does black holing too */
2868 threadLazyBlackHole(tso);