1 /* -----------------------------------------------------------------------------
2 * $Id: GC.c,v 1.47 1999/03/03 18:58:53 sof 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;
762 /* There might be a DEAD_WEAK on the list if finalizeWeak# was
763 * called on a live weak pointer object. Just remove it.
765 if (w->header.info == &DEAD_WEAK_info) {
766 next_w = ((StgDeadWeak *)w)->link;
771 ASSERT(get_itbl(w)->type == WEAK);
773 /* Now, check whether the key is reachable.
775 if ((new = isAlive(w->key))) {
777 /* evacuate the value and finalizer */
778 w->value = evacuate(w->value);
779 w->finalizer = evacuate(w->finalizer);
780 /* remove this weak ptr from the old_weak_ptr list */
782 /* and put it on the new weak ptr list */
784 w->link = weak_ptr_list;
787 IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
797 /* If we didn't make any changes, then we can go round and kill all
798 * the dead weak pointers. The old_weak_ptr list is used as a list
799 * of pending finalizers later on.
801 if (flag == rtsFalse) {
802 for (w = old_weak_ptr_list; w; w = w->link) {
803 w->value = evacuate(w->value);
804 w->finalizer = evacuate(w->finalizer);
812 /* -----------------------------------------------------------------------------
813 After GC, the live weak pointer list may have forwarding pointers
814 on it, because a weak pointer object was evacuated after being
815 moved to the live weak pointer list. We remove those forwarding
818 Also, we don't consider weak pointer objects to be reachable, but
819 we must nevertheless consider them to be "live" and retain them.
820 Therefore any weak pointer objects which haven't as yet been
821 evacuated need to be evacuated now.
822 -------------------------------------------------------------------------- */
825 cleanup_weak_ptr_list ( void )
827 StgWeak *w, **last_w;
829 last_w = &weak_ptr_list;
830 for (w = weak_ptr_list; w; w = w->link) {
832 if (get_itbl(w)->type == EVACUATED) {
833 w = (StgWeak *)((StgEvacuated *)w)->evacuee;
837 if (Bdescr((P_)w)->evacuated == 0) {
838 (StgClosure *)w = evacuate((StgClosure *)w);
845 /* -----------------------------------------------------------------------------
846 isAlive determines whether the given closure is still alive (after
847 a garbage collection) or not. It returns the new address of the
848 closure if it is alive, or NULL otherwise.
849 -------------------------------------------------------------------------- */
852 isAlive(StgClosure *p)
860 /* ToDo: for static closures, check the static link field.
861 * Problem here is that we sometimes don't set the link field, eg.
862 * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
865 /* ignore closures in generations that we're not collecting. */
866 if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
870 switch (info->type) {
875 case IND_OLDGEN: /* rely on compatible layout with StgInd */
876 case IND_OLDGEN_PERM:
877 /* follow indirections */
878 p = ((StgInd *)p)->indirectee;
883 return ((StgEvacuated *)p)->evacuee;
893 MarkRoot(StgClosure *root)
895 return evacuate(root);
898 static void addBlock(step *step)
900 bdescr *bd = allocBlock();
904 if (step->gen->no <= N) {
910 step->hp_bd->free = step->hp;
911 step->hp_bd->link = bd;
912 step->hp = bd->start;
913 step->hpLim = step->hp + BLOCK_SIZE_W;
919 static __inline__ void
920 upd_evacuee(StgClosure *p, StgClosure *dest)
922 p->header.info = &EVACUATED_info;
923 ((StgEvacuated *)p)->evacuee = dest;
926 static __inline__ StgClosure *
927 copy(StgClosure *src, nat size, step *step)
931 TICK_GC_WORDS_COPIED(size);
932 /* Find out where we're going, using the handy "to" pointer in
933 * the step of the source object. If it turns out we need to
934 * evacuate to an older generation, adjust it here (see comment
937 if (step->gen->no < evac_gen) {
938 #ifdef NO_EAGER_PROMOTION
939 failed_to_evac = rtsTrue;
941 step = &generations[evac_gen].steps[0];
945 /* chain a new block onto the to-space for the destination step if
948 if (step->hp + size >= step->hpLim) {
952 for(to = step->hp, from = (P_)src; size>0; --size) {
958 upd_evacuee(src,(StgClosure *)dest);
959 return (StgClosure *)dest;
962 /* Special version of copy() for when we only want to copy the info
963 * pointer of an object, but reserve some padding after it. This is
964 * used to optimise evacuation of BLACKHOLEs.
967 static __inline__ StgClosure *
968 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
972 TICK_GC_WORDS_COPIED(size_to_copy);
973 if (step->gen->no < evac_gen) {
974 #ifdef NO_EAGER_PROMOTION
975 failed_to_evac = rtsTrue;
977 step = &generations[evac_gen].steps[0];
981 if (step->hp + size_to_reserve >= step->hpLim) {
985 for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
990 step->hp += size_to_reserve;
991 upd_evacuee(src,(StgClosure *)dest);
992 return (StgClosure *)dest;
995 /* -----------------------------------------------------------------------------
996 Evacuate a large object
998 This just consists of removing the object from the (doubly-linked)
999 large_alloc_list, and linking it on to the (singly-linked)
1000 new_large_objects list, from where it will be scavenged later.
1002 Convention: bd->evacuated is /= 0 for a large object that has been
1003 evacuated, or 0 otherwise.
1004 -------------------------------------------------------------------------- */
1007 evacuate_large(StgPtr p, rtsBool mutable)
1009 bdescr *bd = Bdescr(p);
1012 /* should point to the beginning of the block */
1013 ASSERT(((W_)p & BLOCK_MASK) == 0);
1015 /* already evacuated? */
1016 if (bd->evacuated) {
1017 /* Don't forget to set the failed_to_evac flag if we didn't get
1018 * the desired destination (see comments in evacuate()).
1020 if (bd->gen->no < evac_gen) {
1021 failed_to_evac = rtsTrue;
1022 TICK_GC_FAILED_PROMOTION();
1028 /* remove from large_object list */
1030 bd->back->link = bd->link;
1031 } else { /* first object in the list */
1032 step->large_objects = bd->link;
1035 bd->link->back = bd->back;
1038 /* link it on to the evacuated large object list of the destination step
1040 step = bd->step->to;
1041 if (step->gen->no < evac_gen) {
1042 #ifdef NO_EAGER_PROMOTION
1043 failed_to_evac = rtsTrue;
1045 step = &generations[evac_gen].steps[0];
1050 bd->gen = step->gen;
1051 bd->link = step->new_large_objects;
1052 step->new_large_objects = bd;
1056 recordMutable((StgMutClosure *)p);
1060 /* -----------------------------------------------------------------------------
1061 Adding a MUT_CONS to an older generation.
1063 This is necessary from time to time when we end up with an
1064 old-to-new generation pointer in a non-mutable object. We defer
1065 the promotion until the next GC.
1066 -------------------------------------------------------------------------- */
1069 mkMutCons(StgClosure *ptr, generation *gen)
1074 step = &gen->steps[0];
1076 /* chain a new block onto the to-space for the destination step if
1079 if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
1083 q = (StgMutVar *)step->hp;
1084 step->hp += sizeofW(StgMutVar);
1086 SET_HDR(q,&MUT_CONS_info,CCS_GC);
1088 recordOldToNewPtrs((StgMutClosure *)q);
1090 return (StgClosure *)q;
1093 /* -----------------------------------------------------------------------------
1096 This is called (eventually) for every live object in the system.
1098 The caller to evacuate specifies a desired generation in the
1099 evac_gen global variable. The following conditions apply to
1100 evacuating an object which resides in generation M when we're
1101 collecting up to generation N
1105 else evac to step->to
1107 if M < evac_gen evac to evac_gen, step 0
1109 if the object is already evacuated, then we check which generation
1112 if M >= evac_gen do nothing
1113 if M < evac_gen set failed_to_evac flag to indicate that we
1114 didn't manage to evacuate this object into evac_gen.
1116 -------------------------------------------------------------------------- */
1120 evacuate(StgClosure *q)
1125 const StgInfoTable *info;
1128 if (HEAP_ALLOCED(q)) {
1130 if (bd->gen->no > N) {
1131 /* Can't evacuate this object, because it's in a generation
1132 * older than the ones we're collecting. Let's hope that it's
1133 * in evac_gen or older, or we will have to make an IND_OLDGEN object.
1135 if (bd->gen->no < evac_gen) {
1137 failed_to_evac = rtsTrue;
1138 TICK_GC_FAILED_PROMOTION();
1142 step = bd->step->to;
1145 /* make sure the info pointer is into text space */
1146 ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1147 || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1150 switch (info -> type) {
1153 return copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
1156 ASSERT(q->header.info != &MUT_CONS_info);
1158 to = copy(q,sizeW_fromITBL(info),step);
1159 recordMutable((StgMutClosure *)to);
1166 return copy(q,sizeofW(StgHeader)+1,step);
1168 case THUNK_1_0: /* here because of MIN_UPD_SIZE */
1173 #ifdef NO_PROMOTE_THUNKS
1174 if (bd->gen->no == 0 &&
1175 bd->step->no != 0 &&
1176 bd->step->no == bd->gen->n_steps-1) {
1180 return copy(q,sizeofW(StgHeader)+2,step);
1188 return copy(q,sizeofW(StgHeader)+2,step);
1194 case IND_OLDGEN_PERM:
1200 return copy(q,sizeW_fromITBL(info),step);
1204 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1207 to = copy(q,BLACKHOLE_sizeW(),step);
1208 recordMutable((StgMutClosure *)to);
1211 case THUNK_SELECTOR:
1213 const StgInfoTable* selectee_info;
1214 StgClosure* selectee = ((StgSelector*)q)->selectee;
1217 selectee_info = get_itbl(selectee);
1218 switch (selectee_info->type) {
1227 StgWord32 offset = info->layout.selector_offset;
1229 /* check that the size is in range */
1231 (StgWord32)(selectee_info->layout.payload.ptrs +
1232 selectee_info->layout.payload.nptrs));
1234 /* perform the selection! */
1235 q = selectee->payload[offset];
1237 /* if we're already in to-space, there's no need to continue
1238 * with the evacuation, just update the source address with
1239 * a pointer to the (evacuated) constructor field.
1241 if (HEAP_ALLOCED(q)) {
1242 bdescr *bd = Bdescr((P_)q);
1243 if (bd->evacuated) {
1244 if (bd->gen->no < evac_gen) {
1245 failed_to_evac = rtsTrue;
1246 TICK_GC_FAILED_PROMOTION();
1252 /* otherwise, carry on and evacuate this constructor field,
1253 * (but not the constructor itself)
1262 case IND_OLDGEN_PERM:
1263 selectee = stgCast(StgInd *,selectee)->indirectee;
1267 selectee = stgCast(StgCAF *,selectee)->value;
1271 selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1281 case THUNK_SELECTOR:
1282 /* aargh - do recursively???? */
1287 /* not evaluated yet */
1291 barf("evacuate: THUNK_SELECTOR: strange selectee");
1294 return copy(q,THUNK_SELECTOR_sizeW(),step);
1298 /* follow chains of indirections, don't evacuate them */
1299 q = ((StgInd*)q)->indirectee;
1302 /* ToDo: optimise STATIC_LINK for known cases.
1303 - FUN_STATIC : payload[0]
1304 - THUNK_STATIC : payload[1]
1305 - IND_STATIC : payload[1]
1309 if (info->srt_len == 0) { /* small optimisation */
1315 /* don't want to evacuate these, but we do want to follow pointers
1316 * from SRTs - see scavenge_static.
1319 /* put the object on the static list, if necessary.
1321 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1322 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1323 static_objects = (StgClosure *)q;
1327 case CONSTR_INTLIKE:
1328 case CONSTR_CHARLIKE:
1329 case CONSTR_NOCAF_STATIC:
1330 /* no need to put these on the static linked list, they don't need
1345 /* shouldn't see these */
1346 barf("evacuate: stack frame\n");
1350 /* these are special - the payload is a copy of a chunk of stack,
1352 return copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1355 /* Already evacuated, just return the forwarding address.
1356 * HOWEVER: if the requested destination generation (evac_gen) is
1357 * older than the actual generation (because the object was
1358 * already evacuated to a younger generation) then we have to
1359 * set the failed_to_evac flag to indicate that we couldn't
1360 * manage to promote the object to the desired generation.
1362 if (evac_gen > 0) { /* optimisation */
1363 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1364 if (Bdescr((P_)p)->gen->no < evac_gen) {
1365 /* fprintf(stderr,"evac failed!\n");*/
1366 failed_to_evac = rtsTrue;
1367 TICK_GC_FAILED_PROMOTION();
1370 return ((StgEvacuated*)q)->evacuee;
1374 nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1376 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1377 evacuate_large((P_)q, rtsFalse);
1380 /* just copy the block */
1381 return copy(q,size,step);
1386 case MUT_ARR_PTRS_FROZEN:
1388 nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1390 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1391 evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1394 /* just copy the block */
1395 to = copy(q,size,step);
1396 if (info->type == MUT_ARR_PTRS) {
1397 recordMutable((StgMutClosure *)to);
1405 StgTSO *tso = stgCast(StgTSO *,q);
1406 nat size = tso_sizeW(tso);
1409 /* Large TSOs don't get moved, so no relocation is required.
1411 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1412 evacuate_large((P_)q, rtsTrue);
1415 /* To evacuate a small TSO, we need to relocate the update frame
1419 StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1421 diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1423 /* relocate the stack pointers... */
1424 new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1425 new_tso->sp = (StgPtr)new_tso->sp + diff;
1426 new_tso->splim = (StgPtr)new_tso->splim + diff;
1428 relocate_TSO(tso, new_tso);
1430 recordMutable((StgMutClosure *)new_tso);
1431 return (StgClosure *)new_tso;
1437 fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1441 barf("evacuate: strange closure type");
1447 /* -----------------------------------------------------------------------------
1448 relocate_TSO is called just after a TSO has been copied from src to
1449 dest. It adjusts the update frame list for the new location.
1450 -------------------------------------------------------------------------- */
1453 relocate_TSO(StgTSO *src, StgTSO *dest)
1460 diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1464 while ((P_)su < dest->stack + dest->stack_size) {
1465 switch (get_itbl(su)->type) {
1467 /* GCC actually manages to common up these three cases! */
1470 su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1475 cf = (StgCatchFrame *)su;
1476 cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1481 sf = (StgSeqFrame *)su;
1482 sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1491 barf("relocate_TSO");
1500 scavenge_srt(const StgInfoTable *info)
1502 StgClosure **srt, **srt_end;
1504 /* evacuate the SRT. If srt_len is zero, then there isn't an
1505 * srt field in the info table. That's ok, because we'll
1506 * never dereference it.
1508 srt = stgCast(StgClosure **,info->srt);
1509 srt_end = srt + info->srt_len;
1510 for (; srt < srt_end; srt++) {
1511 /* Special-case to handle references to closures hiding out in DLLs, since
1512 double indirections required to get at those. The code generator knows
1513 which is which when generating the SRT, so it stores the (indirect)
1514 reference to the DLL closure in the table by first adding one to it.
1515 We check for this here, and undo the addition before evacuating it.
1517 If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1518 closure that's fixed at link-time, and no extra magic is required.
1520 #ifdef HAVE_WIN32_DLL_SUPPORT
1521 if ( stgCast(unsigned long,*srt) & 0x1 ) {
1522 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
1532 /* -----------------------------------------------------------------------------
1533 Scavenge a given step until there are no more objects in this step
1536 evac_gen is set by the caller to be either zero (for a step in a
1537 generation < N) or G where G is the generation of the step being
1540 We sometimes temporarily change evac_gen back to zero if we're
1541 scavenging a mutable object where early promotion isn't such a good
1543 -------------------------------------------------------------------------- */
1547 scavenge(step *step)
1550 const StgInfoTable *info;
1552 nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1557 failed_to_evac = rtsFalse;
1559 /* scavenge phase - standard breadth-first scavenging of the
1563 while (bd != step->hp_bd || p < step->hp) {
1565 /* If we're at the end of this block, move on to the next block */
1566 if (bd != step->hp_bd && p == bd->free) {
1572 q = p; /* save ptr to object */
1574 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1575 || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1577 info = get_itbl((StgClosure *)p);
1578 switch (info -> type) {
1582 StgBCO* bco = stgCast(StgBCO*,p);
1584 for (i = 0; i < bco->n_ptrs; i++) {
1585 bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1587 p += bco_sizeW(bco);
1592 /* treat MVars specially, because we don't want to evacuate the
1593 * mut_link field in the middle of the closure.
1596 StgMVar *mvar = ((StgMVar *)p);
1598 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1599 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1600 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1601 p += sizeofW(StgMVar);
1602 evac_gen = saved_evac_gen;
1610 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1611 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1612 p += sizeofW(StgHeader) + 2;
1617 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1618 p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1624 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1625 p += sizeofW(StgHeader) + 1;
1630 p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1636 p += sizeofW(StgHeader) + 1;
1643 p += sizeofW(StgHeader) + 2;
1650 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1651 p += sizeofW(StgHeader) + 2;
1664 case IND_OLDGEN_PERM:
1670 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1671 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1672 (StgClosure *)*p = evacuate((StgClosure *)*p);
1674 p += info->layout.payload.nptrs;
1679 /* ignore MUT_CONSs */
1680 if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1682 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1683 evac_gen = saved_evac_gen;
1685 p += sizeofW(StgMutVar);
1690 p += BLACKHOLE_sizeW();
1695 StgBlockingQueue *bh = (StgBlockingQueue *)p;
1696 (StgClosure *)bh->blocking_queue =
1697 evacuate((StgClosure *)bh->blocking_queue);
1698 if (failed_to_evac) {
1699 failed_to_evac = rtsFalse;
1700 recordMutable((StgMutClosure *)bh);
1702 p += BLACKHOLE_sizeW();
1706 case THUNK_SELECTOR:
1708 StgSelector *s = (StgSelector *)p;
1709 s->selectee = evacuate(s->selectee);
1710 p += THUNK_SELECTOR_sizeW();
1716 barf("scavenge:IND???\n");
1718 case CONSTR_INTLIKE:
1719 case CONSTR_CHARLIKE:
1721 case CONSTR_NOCAF_STATIC:
1725 /* Shouldn't see a static object here. */
1726 barf("scavenge: STATIC object\n");
1738 /* Shouldn't see stack frames here. */
1739 barf("scavenge: stack frame\n");
1741 case AP_UPD: /* same as PAPs */
1743 /* Treat a PAP just like a section of stack, not forgetting to
1744 * evacuate the function pointer too...
1747 StgPAP* pap = stgCast(StgPAP*,p);
1749 pap->fun = evacuate(pap->fun);
1750 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1751 p += pap_sizeW(pap);
1756 /* nothing to follow */
1757 p += arr_words_sizeW(stgCast(StgArrWords*,p));
1761 /* follow everything */
1765 evac_gen = 0; /* repeatedly mutable */
1766 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1767 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1768 (StgClosure *)*p = evacuate((StgClosure *)*p);
1770 evac_gen = saved_evac_gen;
1774 case MUT_ARR_PTRS_FROZEN:
1775 /* follow everything */
1777 StgPtr start = p, next;
1779 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1780 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1781 (StgClosure *)*p = evacuate((StgClosure *)*p);
1783 if (failed_to_evac) {
1784 /* we can do this easier... */
1785 recordMutable((StgMutClosure *)start);
1786 failed_to_evac = rtsFalse;
1797 /* chase the link field for any TSOs on the same queue */
1798 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1799 /* scavenge this thread's stack */
1800 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1801 evac_gen = saved_evac_gen;
1802 p += tso_sizeW(tso);
1809 barf("scavenge: unimplemented/strange closure type\n");
1815 /* If we didn't manage to promote all the objects pointed to by
1816 * the current object, then we have to designate this object as
1817 * mutable (because it contains old-to-new generation pointers).
1819 if (failed_to_evac) {
1820 mkMutCons((StgClosure *)q, &generations[evac_gen]);
1821 failed_to_evac = rtsFalse;
1829 /* -----------------------------------------------------------------------------
1830 Scavenge one object.
1832 This is used for objects that are temporarily marked as mutable
1833 because they contain old-to-new generation pointers. Only certain
1834 objects can have this property.
1835 -------------------------------------------------------------------------- */
1837 scavenge_one(StgClosure *p)
1842 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1843 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1847 switch (info -> type) {
1850 case FUN_1_0: /* hardly worth specialising these guys */
1870 case IND_OLDGEN_PERM:
1876 end = (P_)p->payload + info->layout.payload.ptrs;
1877 for (q = (P_)p->payload; q < end; q++) {
1878 (StgClosure *)*q = evacuate((StgClosure *)*q);
1887 case THUNK_SELECTOR:
1889 StgSelector *s = (StgSelector *)p;
1890 s->selectee = evacuate(s->selectee);
1894 case AP_UPD: /* same as PAPs */
1896 /* Treat a PAP just like a section of stack, not forgetting to
1897 * evacuate the function pointer too...
1900 StgPAP* pap = (StgPAP *)p;
1902 pap->fun = evacuate(pap->fun);
1903 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1908 /* This might happen if for instance a MUT_CONS was pointing to a
1909 * THUNK which has since been updated. The IND_OLDGEN will
1910 * be on the mutable list anyway, so we don't need to do anything
1916 barf("scavenge_one: strange object");
1919 no_luck = failed_to_evac;
1920 failed_to_evac = rtsFalse;
1925 /* -----------------------------------------------------------------------------
1926 Scavenging mutable lists.
1928 We treat the mutable list of each generation > N (i.e. all the
1929 generations older than the one being collected) as roots. We also
1930 remove non-mutable objects from the mutable list at this point.
1931 -------------------------------------------------------------------------- */
1934 scavenge_mut_once_list(generation *gen)
1937 StgMutClosure *p, *next, *new_list;
1939 p = gen->mut_once_list;
1940 new_list = END_MUT_LIST;
1944 failed_to_evac = rtsFalse;
1946 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1948 /* make sure the info pointer is into text space */
1949 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1950 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1953 switch(info->type) {
1956 case IND_OLDGEN_PERM:
1958 /* Try to pull the indirectee into this generation, so we can
1959 * remove the indirection from the mutable list.
1961 ((StgIndOldGen *)p)->indirectee =
1962 evacuate(((StgIndOldGen *)p)->indirectee);
1965 /* Debugging code to print out the size of the thing we just
1969 StgPtr start = gen->steps[0].scan;
1970 bdescr *start_bd = gen->steps[0].scan_bd;
1972 scavenge(&gen->steps[0]);
1973 if (start_bd != gen->steps[0].scan_bd) {
1974 size += (P_)BLOCK_ROUND_UP(start) - start;
1975 start_bd = start_bd->link;
1976 while (start_bd != gen->steps[0].scan_bd) {
1977 size += BLOCK_SIZE_W;
1978 start_bd = start_bd->link;
1980 size += gen->steps[0].scan -
1981 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
1983 size = gen->steps[0].scan - start;
1985 fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
1989 /* failed_to_evac might happen if we've got more than two
1990 * generations, we're collecting only generation 0, the
1991 * indirection resides in generation 2 and the indirectee is
1994 if (failed_to_evac) {
1995 failed_to_evac = rtsFalse;
1996 p->mut_link = new_list;
1999 /* the mut_link field of an IND_STATIC is overloaded as the
2000 * static link field too (it just so happens that we don't need
2001 * both at the same time), so we need to NULL it out when
2002 * removing this object from the mutable list because the static
2003 * link fields are all assumed to be NULL before doing a major
2011 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
2012 * it from the mutable list if possible by promoting whatever it
2015 ASSERT(p->header.info == &MUT_CONS_info);
2016 if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
2017 /* didn't manage to promote everything, so put the
2018 * MUT_CONS back on the list.
2020 p->mut_link = new_list;
2026 /* shouldn't have anything else on the mutables list */
2027 barf("scavenge_mut_once_list: strange object?");
2031 gen->mut_once_list = new_list;
2036 scavenge_mutable_list(generation *gen)
2039 StgMutClosure *p, *next;
2041 p = gen->saved_mut_list;
2045 failed_to_evac = rtsFalse;
2047 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2049 /* make sure the info pointer is into text space */
2050 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2051 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2054 switch(info->type) {
2056 case MUT_ARR_PTRS_FROZEN:
2057 /* remove this guy from the mutable list, but follow the ptrs
2058 * anyway (and make sure they get promoted to this gen).
2063 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2065 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2066 (StgClosure *)*q = evacuate((StgClosure *)*q);
2070 if (failed_to_evac) {
2071 failed_to_evac = rtsFalse;
2072 p->mut_link = gen->mut_list;
2079 /* follow everything */
2080 p->mut_link = gen->mut_list;
2085 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2086 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2087 (StgClosure *)*q = evacuate((StgClosure *)*q);
2093 /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2094 * it from the mutable list if possible by promoting whatever it
2097 ASSERT(p->header.info != &MUT_CONS_info);
2098 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2099 p->mut_link = gen->mut_list;
2105 StgMVar *mvar = (StgMVar *)p;
2106 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2107 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2108 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2109 p->mut_link = gen->mut_list;
2115 /* follow ptrs and remove this from the mutable list */
2117 StgTSO *tso = (StgTSO *)p;
2119 /* Don't bother scavenging if this thread is dead
2121 if (!(tso->whatNext == ThreadComplete ||
2122 tso->whatNext == ThreadKilled)) {
2123 /* Don't need to chase the link field for any TSOs on the
2124 * same queue. Just scavenge this thread's stack
2126 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2129 /* Don't take this TSO off the mutable list - it might still
2130 * point to some younger objects (because we set evac_gen to 0
2133 tso->mut_link = gen->mut_list;
2134 gen->mut_list = (StgMutClosure *)tso;
2140 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2141 (StgClosure *)bh->blocking_queue =
2142 evacuate((StgClosure *)bh->blocking_queue);
2143 p->mut_link = gen->mut_list;
2149 /* shouldn't have anything else on the mutables list */
2150 barf("scavenge_mut_list: strange object?");
2156 scavenge_static(void)
2158 StgClosure* p = static_objects;
2159 const StgInfoTable *info;
2161 /* Always evacuate straight to the oldest generation for static
2163 evac_gen = oldest_gen->no;
2165 /* keep going until we've scavenged all the objects on the linked
2167 while (p != END_OF_STATIC_LIST) {
2171 /* make sure the info pointer is into text space */
2172 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2173 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2175 /* Take this object *off* the static_objects list,
2176 * and put it on the scavenged_static_objects list.
2178 static_objects = STATIC_LINK(info,p);
2179 STATIC_LINK(info,p) = scavenged_static_objects;
2180 scavenged_static_objects = p;
2182 switch (info -> type) {
2186 StgInd *ind = (StgInd *)p;
2187 ind->indirectee = evacuate(ind->indirectee);
2189 /* might fail to evacuate it, in which case we have to pop it
2190 * back on the mutable list (and take it off the
2191 * scavenged_static list because the static link and mut link
2192 * pointers are one and the same).
2194 if (failed_to_evac) {
2195 failed_to_evac = rtsFalse;
2196 scavenged_static_objects = STATIC_LINK(info,p);
2197 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2198 oldest_gen->mut_once_list = (StgMutClosure *)ind;
2212 next = (P_)p->payload + info->layout.payload.ptrs;
2213 /* evacuate the pointers */
2214 for (q = (P_)p->payload; q < next; q++) {
2215 (StgClosure *)*q = evacuate((StgClosure *)*q);
2221 barf("scavenge_static");
2224 ASSERT(failed_to_evac == rtsFalse);
2226 /* get the next static object from the list. Remeber, there might
2227 * be more stuff on this list now that we've done some evacuating!
2228 * (static_objects is a global)
2234 /* -----------------------------------------------------------------------------
2235 scavenge_stack walks over a section of stack and evacuates all the
2236 objects pointed to by it. We can use the same code for walking
2237 PAPs, since these are just sections of copied stack.
2238 -------------------------------------------------------------------------- */
2241 scavenge_stack(StgPtr p, StgPtr stack_end)
2244 const StgInfoTable* info;
2248 * Each time around this loop, we are looking at a chunk of stack
2249 * that starts with either a pending argument section or an
2250 * activation record.
2253 while (p < stack_end) {
2254 q = *stgCast(StgPtr*,p);
2256 /* If we've got a tag, skip over that many words on the stack */
2257 if (IS_ARG_TAG(stgCast(StgWord,q))) {
2262 /* Is q a pointer to a closure?
2265 if (! LOOKS_LIKE_GHC_INFO(q)) {
2267 if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) { /* Is it a static closure? */
2268 ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2270 /* otherwise, must be a pointer into the allocation space. */
2273 (StgClosure *)*p = evacuate((StgClosure *)q);
2279 * Otherwise, q must be the info pointer of an activation
2280 * record. All activation records have 'bitmap' style layout
2283 info = get_itbl(stgCast(StgClosure*,p));
2285 switch (info->type) {
2287 /* Dynamic bitmap: the mask is stored on the stack */
2289 bitmap = stgCast(StgRetDyn*,p)->liveness;
2290 p = &payloadWord(stgCast(StgRetDyn*,p),0);
2293 /* probably a slow-entry point return address: */
2299 /* Specialised code for update frames, since they're so common.
2300 * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2301 * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2305 StgUpdateFrame *frame = (StgUpdateFrame *)p;
2307 StgClosureType type = get_itbl(frame->updatee)->type;
2309 p += sizeofW(StgUpdateFrame);
2310 if (type == EVACUATED) {
2311 frame->updatee = evacuate(frame->updatee);
2314 bdescr *bd = Bdescr((P_)frame->updatee);
2316 if (bd->gen->no > N) {
2317 if (bd->gen->no < evac_gen) {
2318 failed_to_evac = rtsTrue;
2323 /* Don't promote blackholes */
2325 if (!(step->gen->no == 0 &&
2327 step->no == step->gen->n_steps-1)) {
2334 to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2335 sizeofW(StgHeader), step);
2336 frame->updatee = to;
2339 to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2340 frame->updatee = to;
2341 recordMutable((StgMutClosure *)to);
2344 barf("scavenge_stack: UPDATE_FRAME updatee");
2349 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2356 bitmap = info->layout.bitmap;
2359 while (bitmap != 0) {
2360 if ((bitmap & 1) == 0) {
2361 (StgClosure *)*p = evacuate((StgClosure *)*p);
2364 bitmap = bitmap >> 1;
2371 /* large bitmap (> 32 entries) */
2376 StgLargeBitmap *large_bitmap;
2379 large_bitmap = info->layout.large_bitmap;
2382 for (i=0; i<large_bitmap->size; i++) {
2383 bitmap = large_bitmap->bitmap[i];
2384 q = p + sizeof(W_) * 8;
2385 while (bitmap != 0) {
2386 if ((bitmap & 1) == 0) {
2387 (StgClosure *)*p = evacuate((StgClosure *)*p);
2390 bitmap = bitmap >> 1;
2392 if (i+1 < large_bitmap->size) {
2394 (StgClosure *)*p = evacuate((StgClosure *)*p);
2400 /* and don't forget to follow the SRT */
2405 barf("scavenge_stack: weird activation record found on stack.\n");
2410 /*-----------------------------------------------------------------------------
2411 scavenge the large object list.
2413 evac_gen set by caller; similar games played with evac_gen as with
2414 scavenge() - see comment at the top of scavenge(). Most large
2415 objects are (repeatedly) mutable, so most of the time evac_gen will
2417 --------------------------------------------------------------------------- */
2420 scavenge_large(step *step)
2424 const StgInfoTable* info;
2425 nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2427 evac_gen = 0; /* most objects are mutable */
2428 bd = step->new_large_objects;
2430 for (; bd != NULL; bd = step->new_large_objects) {
2432 /* take this object *off* the large objects list and put it on
2433 * the scavenged large objects list. This is so that we can
2434 * treat new_large_objects as a stack and push new objects on
2435 * the front when evacuating.
2437 step->new_large_objects = bd->link;
2438 dbl_link_onto(bd, &step->scavenged_large_objects);
2441 info = get_itbl(stgCast(StgClosure*,p));
2443 switch (info->type) {
2445 /* only certain objects can be "large"... */
2448 /* nothing to follow */
2452 /* follow everything */
2456 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2457 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2458 (StgClosure *)*p = evacuate((StgClosure *)*p);
2463 case MUT_ARR_PTRS_FROZEN:
2464 /* follow everything */
2466 StgPtr start = p, next;
2468 evac_gen = saved_evac_gen; /* not really mutable */
2469 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2470 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2471 (StgClosure *)*p = evacuate((StgClosure *)*p);
2474 if (failed_to_evac) {
2475 recordMutable((StgMutClosure *)start);
2482 StgBCO* bco = stgCast(StgBCO*,p);
2484 evac_gen = saved_evac_gen;
2485 for (i = 0; i < bco->n_ptrs; i++) {
2486 bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2497 /* chase the link field for any TSOs on the same queue */
2498 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2499 /* scavenge this thread's stack */
2500 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2505 barf("scavenge_large: unknown/strange object");
2511 zero_static_object_list(StgClosure* first_static)
2515 const StgInfoTable *info;
2517 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2519 link = STATIC_LINK(info, p);
2520 STATIC_LINK(info,p) = NULL;
2524 /* This function is only needed because we share the mutable link
2525 * field with the static link field in an IND_STATIC, so we have to
2526 * zero the mut_link field before doing a major GC, which needs the
2527 * static link field.
2529 * It doesn't do any harm to zero all the mutable link fields on the
2533 zero_mutable_list( StgMutClosure *first )
2535 StgMutClosure *next, *c;
2537 for (c = first; c != END_MUT_LIST; c = next) {
2543 /* -----------------------------------------------------------------------------
2545 -------------------------------------------------------------------------- */
2547 void RevertCAFs(void)
2549 while (enteredCAFs != END_CAF_LIST) {
2550 StgCAF* caf = enteredCAFs;
2552 enteredCAFs = caf->link;
2553 ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2554 SET_INFO(caf,&CAF_UNENTERED_info);
2555 caf->value = stgCast(StgClosure*,0xdeadbeef);
2556 caf->link = stgCast(StgCAF*,0xdeadbeef);
2560 void revert_dead_CAFs(void)
2562 StgCAF* caf = enteredCAFs;
2563 enteredCAFs = END_CAF_LIST;
2564 while (caf != END_CAF_LIST) {
2565 StgCAF* next = caf->link;
2567 switch(GET_INFO(caf)->type) {
2570 /* This object has been evacuated, it must be live. */
2571 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2572 new->link = enteredCAFs;
2578 SET_INFO(caf,&CAF_UNENTERED_info);
2579 caf->value = stgCast(StgClosure*,0xdeadbeef);
2580 caf->link = stgCast(StgCAF*,0xdeadbeef);
2584 barf("revert_dead_CAFs: enteredCAFs list corrupted");
2590 /* -----------------------------------------------------------------------------
2591 Sanity code for CAF garbage collection.
2593 With DEBUG turned on, we manage a CAF list in addition to the SRT
2594 mechanism. After GC, we run down the CAF list and blackhole any
2595 CAFs which have been garbage collected. This means we get an error
2596 whenever the program tries to enter a garbage collected CAF.
2598 Any garbage collected CAFs are taken off the CAF list at the same
2600 -------------------------------------------------------------------------- */
2608 const StgInfoTable *info;
2619 ASSERT(info->type == IND_STATIC);
2621 if (STATIC_LINK(info,p) == NULL) {
2622 IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2624 SET_INFO(p,&BLACKHOLE_info);
2625 p = STATIC_LINK2(info,p);
2629 pp = &STATIC_LINK2(info,p);
2636 /* fprintf(stderr, "%d CAFs live\n", i); */
2640 /* -----------------------------------------------------------------------------
2643 Whenever a thread returns to the scheduler after possibly doing
2644 some work, we have to run down the stack and black-hole all the
2645 closures referred to by update frames.
2646 -------------------------------------------------------------------------- */
2649 threadLazyBlackHole(StgTSO *tso)
2651 StgUpdateFrame *update_frame;
2652 StgBlockingQueue *bh;
2655 stack_end = &tso->stack[tso->stack_size];
2656 update_frame = tso->su;
2659 switch (get_itbl(update_frame)->type) {
2662 update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2666 bh = (StgBlockingQueue *)update_frame->updatee;
2668 /* if the thunk is already blackholed, it means we've also
2669 * already blackholed the rest of the thunks on this stack,
2670 * so we can stop early.
2672 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2673 * don't interfere with this optimisation.
2675 if (bh->header.info == &BLACKHOLE_info) {
2679 if (bh->header.info != &BLACKHOLE_BQ_info &&
2680 bh->header.info != &CAF_BLACKHOLE_info) {
2681 SET_INFO(bh,&BLACKHOLE_info);
2684 update_frame = update_frame->link;
2688 update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2694 barf("threadPaused");
2699 /* -----------------------------------------------------------------------------
2702 * Code largely pinched from old RTS, then hacked to bits. We also do
2703 * lazy black holing here.
2705 * -------------------------------------------------------------------------- */
2708 threadSqueezeStack(StgTSO *tso)
2710 lnat displacement = 0;
2711 StgUpdateFrame *frame;
2712 StgUpdateFrame *next_frame; /* Temporally next */
2713 StgUpdateFrame *prev_frame; /* Temporally previous */
2715 rtsBool prev_was_update_frame;
2717 bottom = &(tso->stack[tso->stack_size]);
2720 /* There must be at least one frame, namely the STOP_FRAME.
2722 ASSERT((P_)frame < bottom);
2724 /* Walk down the stack, reversing the links between frames so that
2725 * we can walk back up as we squeeze from the bottom. Note that
2726 * next_frame and prev_frame refer to next and previous as they were
2727 * added to the stack, rather than the way we see them in this
2728 * walk. (It makes the next loop less confusing.)
2730 * Stop if we find an update frame pointing to a black hole
2731 * (see comment in threadLazyBlackHole()).
2735 while ((P_)frame < bottom - 1) { /* bottom - 1 is the STOP_FRAME */
2736 prev_frame = frame->link;
2737 frame->link = next_frame;
2740 if (get_itbl(frame)->type == UPDATE_FRAME
2741 && frame->updatee->header.info == &BLACKHOLE_info) {
2746 /* Now, we're at the bottom. Frame points to the lowest update
2747 * frame on the stack, and its link actually points to the frame
2748 * above. We have to walk back up the stack, squeezing out empty
2749 * update frames and turning the pointers back around on the way
2752 * The bottom-most frame (the STOP_FRAME) has not been altered, and
2753 * we never want to eliminate it anyway. Just walk one step up
2754 * before starting to squeeze. When you get to the topmost frame,
2755 * remember that there are still some words above it that might have
2762 prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2765 * Loop through all of the frames (everything except the very
2766 * bottom). Things are complicated by the fact that we have
2767 * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2768 * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2770 while (frame != NULL) {
2772 StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2773 rtsBool is_update_frame;
2775 next_frame = frame->link;
2776 is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2779 * 1. both the previous and current frame are update frames
2780 * 2. the current frame is empty
2782 if (prev_was_update_frame && is_update_frame &&
2783 (P_)prev_frame == frame_bottom + displacement) {
2785 /* Now squeeze out the current frame */
2786 StgClosure *updatee_keep = prev_frame->updatee;
2787 StgClosure *updatee_bypass = frame->updatee;
2790 fprintf(stderr, "squeezing frame at %p\n", frame);
2793 /* Deal with blocking queues. If both updatees have blocked
2794 * threads, then we should merge the queues into the update
2795 * frame that we're keeping.
2797 * Alternatively, we could just wake them up: they'll just go
2798 * straight to sleep on the proper blackhole! This is less code
2799 * and probably less bug prone, although it's probably much
2802 #if 0 /* do it properly... */
2803 if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
2804 /* Sigh. It has one. Don't lose those threads! */
2805 if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2806 /* Urgh. Two queues. Merge them. */
2807 P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2809 while (keep_tso->link != END_TSO_QUEUE) {
2810 keep_tso = keep_tso->link;
2812 keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2815 /* For simplicity, just swap the BQ for the BH */
2816 P_ temp = updatee_keep;
2818 updatee_keep = updatee_bypass;
2819 updatee_bypass = temp;
2821 /* Record the swap in the kept frame (below) */
2822 prev_frame->updatee = updatee_keep;
2827 TICK_UPD_SQUEEZED();
2828 UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2830 sp = (P_)frame - 1; /* sp = stuff to slide */
2831 displacement += sizeofW(StgUpdateFrame);
2834 /* No squeeze for this frame */
2835 sp = frame_bottom - 1; /* Keep the current frame */
2837 /* Do lazy black-holing.
2839 if (is_update_frame) {
2840 StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2841 if (bh->header.info != &BLACKHOLE_BQ_info &&
2842 bh->header.info != &CAF_BLACKHOLE_info) {
2843 SET_INFO(bh,&BLACKHOLE_info);
2847 /* Fix the link in the current frame (should point to the frame below) */
2848 frame->link = prev_frame;
2849 prev_was_update_frame = is_update_frame;
2852 /* Now slide all words from sp up to the next frame */
2854 if (displacement > 0) {
2855 P_ next_frame_bottom;
2857 if (next_frame != NULL)
2858 next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2860 next_frame_bottom = tso->sp - 1;
2863 fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2867 while (sp >= next_frame_bottom) {
2868 sp[displacement] = *sp;
2872 (P_)prev_frame = (P_)frame + displacement;
2876 tso->sp += displacement;
2877 tso->su = prev_frame;
2880 /* -----------------------------------------------------------------------------
2883 * We have to prepare for GC - this means doing lazy black holing
2884 * here. We also take the opportunity to do stack squeezing if it's
2886 * -------------------------------------------------------------------------- */
2889 threadPaused(StgTSO *tso)
2891 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2892 threadSqueezeStack(tso); /* does black holing too */
2894 threadLazyBlackHole(tso);