1 /* -----------------------------------------------------------------------------
2 * $Id: GC.c,v 1.36 1999/02/17 17:35:32 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 zeroStaticObjectList(StgClosure* first_static);
105 static rtsBool traverse_weak_ptr_list(void);
106 static void zeroMutableList(StgMutClosure *first);
107 static void revertDeadCAFs(void);
109 static void scavenge_stack(StgPtr p, StgPtr stack_end);
110 static void scavenge_large(step *step);
111 static void scavenge(step *step);
112 static void scavenge_static(void);
113 static void scavenge_mutable_list(generation *g);
114 static void scavenge_mut_once_list(generation *g);
117 static void gcCAFs(void);
120 /* -----------------------------------------------------------------------------
123 For garbage collecting generation N (and all younger generations):
125 - follow all pointers in the root set. the root set includes all
126 mutable objects in all steps in all generations.
128 - for each pointer, evacuate the object it points to into either
129 + to-space in the next higher step in that generation, if one exists,
130 + if the object's generation == N, then evacuate it to the next
131 generation if one exists, or else to-space in the current
133 + if the object's generation < N, then evacuate it to to-space
134 in the next generation.
136 - repeatedly scavenge to-space from each step in each generation
137 being collected until no more objects can be evacuated.
139 - free from-space in each step, and set from-space = to-space.
141 -------------------------------------------------------------------------- */
143 void GarbageCollect(void (*get_roots)(void))
147 lnat live, allocated, collected = 0;
151 CostCentreStack *prev_CCS;
154 /* tell the stats department that we've started a GC */
157 /* attribute any costs to CCS_GC */
163 /* We might have been called from Haskell land by _ccall_GC, in
164 * which case we need to call threadPaused() because the scheduler
165 * won't have done it.
167 if (CurrentTSO) { threadPaused(CurrentTSO); }
169 /* Approximate how much we allocated: number of blocks in the
170 * nursery + blocks allocated via allocate() - unused nusery blocks.
171 * This leaves a little slop at the end of each block, and doesn't
172 * take into account large objects (ToDo).
174 allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
175 for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
176 allocated -= BLOCK_SIZE_W;
179 /* Figure out which generation to collect
182 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
183 if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
187 major_gc = (N == RtsFlags.GcFlags.generations-1);
189 /* check stack sanity *before* GC (ToDo: check all threads) */
190 /*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
191 IF_DEBUG(sanity, checkFreeListSanity());
193 /* Initialise the static object lists
195 static_objects = END_OF_STATIC_LIST;
196 scavenged_static_objects = END_OF_STATIC_LIST;
198 /* zero the mutable list for the oldest generation (see comment by
199 * zeroMutableList below).
202 zeroMutableList(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
205 /* Save the old to-space if we're doing a two-space collection
207 if (RtsFlags.GcFlags.generations == 1) {
208 old_to_space = g0s0->to_space;
209 g0s0->to_space = NULL;
212 /* Keep a count of how many new blocks we allocated during this GC
213 * (used for resizing the allocation area, later).
217 /* Initialise to-space in all the generations/steps that we're
220 for (g = 0; g <= N; g++) {
221 generations[g].mut_once_list = END_MUT_LIST;
222 generations[g].mut_list = END_MUT_LIST;
224 for (s = 0; s < generations[g].n_steps; s++) {
226 /* generation 0, step 0 doesn't need to-space */
227 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
231 /* Get a free block for to-space. Extra blocks will be chained on
235 step = &generations[g].steps[s];
236 ASSERT(step->gen->no == g);
237 ASSERT(step->hp ? Bdescr(step->hp)->step == step : rtsTrue);
238 bd->gen = &generations[g];
241 bd->evacuated = 1; /* it's a to-space block */
242 step->hp = bd->start;
243 step->hpLim = step->hp + BLOCK_SIZE_W;
246 step->to_blocks = 1; /* ???? */
247 step->scan = bd->start;
249 step->new_large_objects = NULL;
250 step->scavenged_large_objects = NULL;
251 /* mark the large objects as not evacuated yet */
252 for (bd = step->large_objects; bd; bd = bd->link) {
258 /* make sure the older generations have at least one block to
259 * allocate into (this makes things easier for copy(), see below.
261 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
262 for (s = 0; s < generations[g].n_steps; s++) {
263 step = &generations[g].steps[s];
264 if (step->hp_bd == NULL) {
266 bd->gen = &generations[g];
269 bd->evacuated = 0; /* *not* a to-space block */
270 step->hp = bd->start;
271 step->hpLim = step->hp + BLOCK_SIZE_W;
276 /* Set the scan pointer for older generations: remember we
277 * still have to scavenge objects that have been promoted. */
278 step->scan = step->hp;
279 step->scan_bd = step->hp_bd;
280 step->to_space = NULL;
282 step->new_large_objects = NULL;
283 step->scavenged_large_objects = NULL;
287 /* -----------------------------------------------------------------------
288 * follow all the roots that we know about:
289 * - mutable lists from each generation > N
290 * we want to *scavenge* these roots, not evacuate them: they're not
291 * going to move in this GC.
292 * Also: do them in reverse generation order. This is because we
293 * often want to promote objects that are pointed to by older
294 * generations early, so we don't have to repeatedly copy them.
295 * Doing the generations in reverse order ensures that we don't end
296 * up in the situation where we want to evac an object to gen 3 and
297 * it has already been evaced to gen 2.
301 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
302 generations[g].saved_mut_list = generations[g].mut_list;
303 generations[g].mut_list = END_MUT_LIST;
306 /* Do the mut-once lists first */
307 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
308 scavenge_mut_once_list(&generations[g]);
310 for (st = generations[g].n_steps-1; st >= 0; st--) {
311 scavenge(&generations[g].steps[st]);
315 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
316 scavenge_mutable_list(&generations[g]);
318 for (st = generations[g].n_steps-1; st >= 0; st--) {
319 scavenge(&generations[g].steps[st]);
324 /* follow all the roots that the application knows about.
329 /* And don't forget to mark the TSO if we got here direct from
332 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
335 /* Mark the weak pointer list, and prepare to detect dead weak
339 old_weak_ptr_list = weak_ptr_list;
340 weak_ptr_list = NULL;
341 weak_done = rtsFalse;
343 /* Mark the stable pointer table.
345 markStablePtrTable(major_gc);
349 /* ToDo: To fix the caf leak, we need to make the commented out
350 * parts of this code do something sensible - as described in
353 extern void markHugsObjects(void);
355 /* ToDo: This (undefined) function should contain the scavenge
356 * loop immediately below this block of code - but I'm not sure
357 * enough of the details to do this myself.
359 scavengeEverything();
360 /* revert dead CAFs and update enteredCAFs list */
365 /* This will keep the CAFs and the attached BCOs alive
366 * but the values will have been reverted
368 scavengeEverything();
373 /* -------------------------------------------------------------------------
374 * Repeatedly scavenge all the areas we know about until there's no
375 * more scavenging to be done.
382 /* scavenge static objects */
383 if (major_gc && static_objects != END_OF_STATIC_LIST) {
387 /* When scavenging the older generations: Objects may have been
388 * evacuated from generations <= N into older generations, and we
389 * need to scavenge these objects. We're going to try to ensure that
390 * any evacuations that occur move the objects into at least the
391 * same generation as the object being scavenged, otherwise we
392 * have to create new entries on the mutable list for the older
396 /* scavenge each step in generations 0..maxgen */
400 for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
401 for (st = generations[gen].n_steps-1; st >= 0 ; st--) {
402 if (gen == 0 && step == 0) {
405 step = &generations[gen].steps[st];
407 if (step->hp_bd != step->scan_bd || step->scan < step->hp) {
412 if (step->new_large_objects != NULL) {
413 scavenge_large(step);
420 if (flag) { goto loop; }
422 /* must be last... */
423 if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
428 /* Now see which stable names are still alive
430 gcStablePtrTable(major_gc);
432 /* Set the maximum blocks for the oldest generation, based on twice
433 * the amount of live data now, adjusted to fit the maximum heap
436 * This is an approximation, since in the worst case we'll need
437 * twice the amount of live data plus whatever space the other
440 if (RtsFlags.GcFlags.generations > 1) {
442 oldest_gen->max_blocks =
443 stg_max(oldest_gen->steps[0].to_blocks * RtsFlags.GcFlags.oldGenFactor,
444 RtsFlags.GcFlags.minOldGenSize);
445 if (oldest_gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
446 oldest_gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
447 if (((int)oldest_gen->max_blocks -
448 (int)oldest_gen->steps[0].to_blocks) <
449 (RtsFlags.GcFlags.pcFreeHeap *
450 RtsFlags.GcFlags.maxHeapSize / 200)) {
457 /* run through all the generations/steps and tidy up
459 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
462 generations[g].collections++; /* for stats */
465 for (s = 0; s < generations[g].n_steps; s++) {
467 step = &generations[g].steps[s];
469 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
470 /* Tidy the end of the to-space chains */
471 step->hp_bd->free = step->hp;
472 step->hp_bd->link = NULL;
475 /* for generations we collected... */
478 collected += step->n_blocks * BLOCK_SIZE_W; /* for stats */
480 /* free old memory and shift to-space into from-space for all
481 * the collected steps (except the allocation area). These
482 * freed blocks will probaby be quickly recycled.
484 if (!(g == 0 && s == 0)) {
485 freeChain(step->blocks);
486 step->blocks = step->to_space;
487 step->n_blocks = step->to_blocks;
488 step->to_space = NULL;
490 for (bd = step->blocks; bd != NULL; bd = bd->link) {
491 bd->evacuated = 0; /* now from-space */
495 /* LARGE OBJECTS. The current live large objects are chained on
496 * scavenged_large, having been moved during garbage
497 * collection from large_objects. Any objects left on
498 * large_objects list are therefore dead, so we free them here.
500 for (bd = step->large_objects; bd != NULL; bd = next) {
505 for (bd = step->scavenged_large_objects; bd != NULL; bd = bd->link) {
508 step->large_objects = step->scavenged_large_objects;
510 /* Set the maximum blocks for this generation, interpolating
511 * between the maximum size of the oldest and youngest
514 * max_blocks = oldgen_max_blocks * G
515 * ----------------------
520 generations[g].max_blocks = (oldest_gen->max_blocks * g)
521 / (RtsFlags.GcFlags.generations-1);
523 generations[g].max_blocks = oldest_gen->max_blocks;
526 /* for older generations... */
529 /* For older generations, we need to append the
530 * scavenged_large_object list (i.e. large objects that have been
531 * promoted during this GC) to the large_object list for that step.
533 for (bd = step->scavenged_large_objects; bd; bd = next) {
536 dbl_link_onto(bd, &step->large_objects);
539 /* add the new blocks we promoted during this GC */
540 step->n_blocks += step->to_blocks;
545 /* Guess the amount of live data for stats. */
548 /* Two-space collector:
549 * Free the old to-space, and estimate the amount of live data.
551 if (RtsFlags.GcFlags.generations == 1) {
554 if (old_to_space != NULL) {
555 freeChain(old_to_space);
557 for (bd = g0s0->to_space; bd != NULL; bd = bd->link) {
558 bd->evacuated = 0; /* now from-space */
561 /* For a two-space collector, we need to resize the nursery. */
563 /* set up a new nursery. Allocate a nursery size based on a
564 * function of the amount of live data (currently a factor of 2,
565 * should be configurable (ToDo)). Use the blocks from the old
566 * nursery if possible, freeing up any left over blocks.
568 * If we get near the maximum heap size, then adjust our nursery
569 * size accordingly. If the nursery is the same size as the live
570 * data (L), then we need 3L bytes. We can reduce the size of the
571 * nursery to bring the required memory down near 2L bytes.
573 * A normal 2-space collector would need 4L bytes to give the same
574 * performance we get from 3L bytes, reducing to the same
575 * performance at 2L bytes.
577 blocks = g0s0->to_blocks;
579 if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
580 RtsFlags.GcFlags.maxHeapSize ) {
581 int adjusted_blocks; /* signed on purpose */
584 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
585 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));
586 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
587 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
590 blocks = adjusted_blocks;
593 blocks *= RtsFlags.GcFlags.oldGenFactor;
594 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
595 blocks = RtsFlags.GcFlags.minAllocAreaSize;
598 resizeNursery(blocks);
601 /* Generational collector:
602 * If the user has given us a suggested heap size, adjust our
603 * allocation area to make best use of the memory available.
606 if (RtsFlags.GcFlags.heapSizeSuggestion) {
608 nat needed = calcNeeded(); /* approx blocks needed at next GC */
610 /* Guess how much will be live in generation 0 step 0 next time.
611 * A good approximation is the obtained by finding the
612 * percentage of g0s0 that was live at the last minor GC.
615 g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
618 /* Estimate a size for the allocation area based on the
619 * information available. We might end up going slightly under
620 * or over the suggested heap size, but we should be pretty
623 * Formula: suggested - needed
624 * ----------------------------
625 * 1 + g0s0_pcnt_kept/100
627 * where 'needed' is the amount of memory needed at the next
628 * collection for collecting all steps except g0s0.
631 (((int)RtsFlags.GcFlags.heapSizeSuggestion - (int)needed) * 100) /
632 (100 + (int)g0s0_pcnt_kept);
634 if (blocks < (int)RtsFlags.GcFlags.minAllocAreaSize) {
635 blocks = RtsFlags.GcFlags.minAllocAreaSize;
638 resizeNursery((nat)blocks);
642 /* revert dead CAFs and update enteredCAFs list */
645 /* mark the garbage collected CAFs as dead */
647 if (major_gc) { gcCAFs(); }
650 /* zero the scavenged static object list */
652 zeroStaticObjectList(scavenged_static_objects);
657 for (bd = g0s0->blocks; bd; bd = bd->link) {
658 bd->free = bd->start;
659 ASSERT(bd->gen == g0);
660 ASSERT(bd->step == g0s0);
662 current_nursery = g0s0->blocks;
664 /* Free the small objects allocated via allocate(), since this will
665 * all have been copied into G0S1 now.
667 if (small_alloc_list != NULL) {
668 freeChain(small_alloc_list);
670 small_alloc_list = NULL;
672 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
674 /* start any pending finalizers */
675 scheduleFinalizers(old_weak_ptr_list);
677 /* check sanity after GC */
678 IF_DEBUG(sanity, checkSanity(N));
680 /* extra GC trace info */
681 IF_DEBUG(gc, stat_describe_gens());
684 /* symbol-table based profiling */
685 /* heapCensus(to_space); */ /* ToDo */
688 /* restore enclosing cost centre */
693 /* check for memory leaks if sanity checking is on */
694 IF_DEBUG(sanity, memInventory());
696 /* ok, GC over: tell the stats department what happened. */
697 stat_endGC(allocated, collected, live, N);
700 /* -----------------------------------------------------------------------------
703 traverse_weak_ptr_list is called possibly many times during garbage
704 collection. It returns a flag indicating whether it did any work
705 (i.e. called evacuate on any live pointers).
707 Invariant: traverse_weak_ptr_list is called when the heap is in an
708 idempotent state. That means that there are no pending
709 evacuate/scavenge operations. This invariant helps the weak
710 pointer code decide which weak pointers are dead - if there are no
711 new live weak pointers, then all the currently unreachable ones are
714 For generational GC: we just don't try to finalize weak pointers in
715 older generations than the one we're collecting. This could
716 probably be optimised by keeping per-generation lists of weak
717 pointers, but for a few weak pointers this scheme will work.
718 -------------------------------------------------------------------------- */
721 traverse_weak_ptr_list(void)
723 StgWeak *w, **last_w, *next_w;
725 rtsBool flag = rtsFalse;
727 if (weak_done) { return rtsFalse; }
729 /* doesn't matter where we evacuate values/finalizers to, since
730 * these pointers are treated as roots (iff the keys are alive).
734 last_w = &old_weak_ptr_list;
735 for (w = old_weak_ptr_list; w; w = next_w) {
737 if ((new = isAlive(w->key))) {
739 /* evacuate the value and finalizer */
740 w->value = evacuate(w->value);
741 w->finalizer = evacuate(w->finalizer);
742 /* remove this weak ptr from the old_weak_ptr list */
744 /* and put it on the new weak ptr list */
746 w->link = weak_ptr_list;
749 IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
759 /* If we didn't make any changes, then we can go round and kill all
760 * the dead weak pointers. The old_weak_ptr list is used as a list
761 * of pending finalizers later on.
763 if (flag == rtsFalse) {
764 for (w = old_weak_ptr_list; w; w = w->link) {
765 w->value = evacuate(w->value);
766 w->finalizer = evacuate(w->finalizer);
774 /* -----------------------------------------------------------------------------
775 isAlive determines whether the given closure is still alive (after
776 a garbage collection) or not. It returns the new address of the
777 closure if it is alive, or NULL otherwise.
778 -------------------------------------------------------------------------- */
781 isAlive(StgClosure *p)
789 /* ToDo: for static closures, check the static link field.
790 * Problem here is that we sometimes don't set the link field, eg.
791 * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
794 /* ignore closures in generations that we're not collecting. */
795 if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
799 switch (info->type) {
804 case IND_OLDGEN: /* rely on compatible layout with StgInd */
805 case IND_OLDGEN_PERM:
806 /* follow indirections */
807 p = ((StgInd *)p)->indirectee;
812 return ((StgEvacuated *)p)->evacuee;
822 MarkRoot(StgClosure *root)
824 return evacuate(root);
827 static void addBlock(step *step)
829 bdescr *bd = allocBlock();
833 if (step->gen->no <= N) {
839 step->hp_bd->free = step->hp;
840 step->hp_bd->link = bd;
841 step->hp = bd->start;
842 step->hpLim = step->hp + BLOCK_SIZE_W;
848 static __inline__ StgClosure *
849 copy(StgClosure *src, nat size, step *step)
853 TICK_GC_WORDS_COPIED(size);
854 /* Find out where we're going, using the handy "to" pointer in
855 * the step of the source object. If it turns out we need to
856 * evacuate to an older generation, adjust it here (see comment
859 if (step->gen->no < evac_gen) {
860 step = &generations[evac_gen].steps[0];
863 /* chain a new block onto the to-space for the destination step if
866 if (step->hp + size >= step->hpLim) {
870 for(to = step->hp, from = (P_)src; size>0; --size) {
876 return (StgClosure *)dest;
879 /* Special version of copy() for when we only want to copy the info
880 * pointer of an object, but reserve some padding after it. This is
881 * used to optimise evacuation of BLACKHOLEs.
884 static __inline__ StgClosure *
885 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
889 TICK_GC_WORDS_COPIED(size_to_copy);
890 if (step->gen->no < evac_gen) {
891 step = &generations[evac_gen].steps[0];
894 if (step->hp + size_to_reserve >= step->hpLim) {
898 for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
903 step->hp += size_to_reserve;
904 return (StgClosure *)dest;
907 static __inline__ void
908 upd_evacuee(StgClosure *p, StgClosure *dest)
910 StgEvacuated *q = (StgEvacuated *)p;
912 SET_INFO(q,&EVACUATED_info);
916 /* -----------------------------------------------------------------------------
917 Evacuate a large object
919 This just consists of removing the object from the (doubly-linked)
920 large_alloc_list, and linking it on to the (singly-linked)
921 new_large_objects list, from where it will be scavenged later.
923 Convention: bd->evacuated is /= 0 for a large object that has been
924 evacuated, or 0 otherwise.
925 -------------------------------------------------------------------------- */
928 evacuate_large(StgPtr p, rtsBool mutable)
930 bdescr *bd = Bdescr(p);
933 /* should point to the beginning of the block */
934 ASSERT(((W_)p & BLOCK_MASK) == 0);
936 /* already evacuated? */
938 /* Don't forget to set the failed_to_evac flag if we didn't get
939 * the desired destination (see comments in evacuate()).
941 if (bd->gen->no < evac_gen) {
942 failed_to_evac = rtsTrue;
943 TICK_GC_FAILED_PROMOTION();
949 /* remove from large_object list */
951 bd->back->link = bd->link;
952 } else { /* first object in the list */
953 step->large_objects = bd->link;
956 bd->link->back = bd->back;
959 /* link it on to the evacuated large object list of the destination step
962 if (step->gen->no < evac_gen) {
963 step = &generations[evac_gen].steps[0];
968 bd->link = step->new_large_objects;
969 step->new_large_objects = bd;
973 recordMutable((StgMutClosure *)p);
977 /* -----------------------------------------------------------------------------
978 Adding a MUT_CONS to an older generation.
980 This is necessary from time to time when we end up with an
981 old-to-new generation pointer in a non-mutable object. We defer
982 the promotion until the next GC.
983 -------------------------------------------------------------------------- */
986 mkMutCons(StgClosure *ptr, generation *gen)
991 step = &gen->steps[0];
993 /* chain a new block onto the to-space for the destination step if
996 if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
1000 q = (StgMutVar *)step->hp;
1001 step->hp += sizeofW(StgMutVar);
1003 SET_HDR(q,&MUT_CONS_info,CCS_GC);
1005 recordOldToNewPtrs((StgMutClosure *)q);
1007 return (StgClosure *)q;
1010 /* -----------------------------------------------------------------------------
1013 This is called (eventually) for every live object in the system.
1015 The caller to evacuate specifies a desired generation in the
1016 evac_gen global variable. The following conditions apply to
1017 evacuating an object which resides in generation M when we're
1018 collecting up to generation N
1022 else evac to step->to
1024 if M < evac_gen evac to evac_gen, step 0
1026 if the object is already evacuated, then we check which generation
1029 if M >= evac_gen do nothing
1030 if M < evac_gen set failed_to_evac flag to indicate that we
1031 didn't manage to evacuate this object into evac_gen.
1033 -------------------------------------------------------------------------- */
1037 evacuate(StgClosure *q)
1042 const StgInfoTable *info;
1045 if (!LOOKS_LIKE_STATIC(q)) {
1047 if (bd->gen->no > N) {
1048 /* Can't evacuate this object, because it's in a generation
1049 * older than the ones we're collecting. Let's hope that it's
1050 * in evac_gen or older, or we will have to make an IND_OLDGEN object.
1052 if (bd->gen->no < evac_gen) {
1054 failed_to_evac = rtsTrue;
1055 TICK_GC_FAILED_PROMOTION();
1059 step = bd->step->to;
1062 /* make sure the info pointer is into text space */
1063 ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1064 || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1067 switch (info -> type) {
1070 to = copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
1075 ASSERT(q->header.info != &MUT_CONS_info);
1077 to = copy(q,sizeW_fromITBL(info),step);
1079 recordMutable((StgMutClosure *)to);
1083 stable_ptr_table[((StgStableName *)q)->sn].keep = rtsTrue;
1084 to = copy(q,sizeofW(StgStableName),step);
1092 to = copy(q,sizeofW(StgHeader)+1,step);
1096 case THUNK_1_0: /* here because of MIN_UPD_SIZE */
1107 to = copy(q,sizeofW(StgHeader)+2,step);
1115 case IND_OLDGEN_PERM:
1120 to = copy(q,sizeW_fromITBL(info),step);
1126 to = copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1131 to = copy(q,BLACKHOLE_sizeW(),step);
1133 recordMutable((StgMutClosure *)to);
1136 case THUNK_SELECTOR:
1138 const StgInfoTable* selectee_info;
1139 StgClosure* selectee = ((StgSelector*)q)->selectee;
1142 selectee_info = get_itbl(selectee);
1143 switch (selectee_info->type) {
1152 StgNat32 offset = info->layout.selector_offset;
1154 /* check that the size is in range */
1156 (StgNat32)(selectee_info->layout.payload.ptrs +
1157 selectee_info->layout.payload.nptrs));
1159 /* perform the selection! */
1160 q = selectee->payload[offset];
1162 /* if we're already in to-space, there's no need to continue
1163 * with the evacuation, just update the source address with
1164 * a pointer to the (evacuated) constructor field.
1166 if (IS_USER_PTR(q)) {
1167 bdescr *bd = Bdescr((P_)q);
1168 if (bd->evacuated) {
1169 if (bd->gen->no < evac_gen) {
1170 failed_to_evac = rtsTrue;
1171 TICK_GC_FAILED_PROMOTION();
1177 /* otherwise, carry on and evacuate this constructor field,
1178 * (but not the constructor itself)
1187 case IND_OLDGEN_PERM:
1188 selectee = stgCast(StgInd *,selectee)->indirectee;
1192 selectee = stgCast(StgCAF *,selectee)->value;
1196 selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1206 case THUNK_SELECTOR:
1207 /* aargh - do recursively???? */
1212 /* not evaluated yet */
1216 barf("evacuate: THUNK_SELECTOR: strange selectee");
1219 to = copy(q,THUNK_SELECTOR_sizeW(),step);
1225 /* follow chains of indirections, don't evacuate them */
1226 q = ((StgInd*)q)->indirectee;
1229 /* ToDo: optimise STATIC_LINK for known cases.
1230 - FUN_STATIC : payload[0]
1231 - THUNK_STATIC : payload[1]
1232 - IND_STATIC : payload[1]
1236 if (info->srt_len == 0) { /* small optimisation */
1242 /* don't want to evacuate these, but we do want to follow pointers
1243 * from SRTs - see scavenge_static.
1246 /* put the object on the static list, if necessary.
1248 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1249 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1250 static_objects = (StgClosure *)q;
1254 case CONSTR_INTLIKE:
1255 case CONSTR_CHARLIKE:
1256 case CONSTR_NOCAF_STATIC:
1257 /* no need to put these on the static linked list, they don't need
1272 /* shouldn't see these */
1273 barf("evacuate: stack frame\n");
1277 /* these are special - the payload is a copy of a chunk of stack,
1279 to = copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1284 /* Already evacuated, just return the forwarding address.
1285 * HOWEVER: if the requested destination generation (evac_gen) is
1286 * older than the actual generation (because the object was
1287 * already evacuated to a younger generation) then we have to
1288 * set the failed_to_evac flag to indicate that we couldn't
1289 * manage to promote the object to the desired generation.
1291 if (evac_gen > 0) { /* optimisation */
1292 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1293 if (Bdescr((P_)p)->gen->no < evac_gen) {
1294 /* fprintf(stderr,"evac failed!\n");*/
1295 failed_to_evac = rtsTrue;
1296 TICK_GC_FAILED_PROMOTION();
1299 return ((StgEvacuated*)q)->evacuee;
1303 nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1305 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1306 evacuate_large((P_)q, rtsFalse);
1309 /* just copy the block */
1310 to = copy(q,size,step);
1317 case MUT_ARR_PTRS_FROZEN:
1319 nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1321 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1322 evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1325 /* just copy the block */
1326 to = copy(q,size,step);
1328 if (info->type == MUT_ARR_PTRS) {
1329 recordMutable((StgMutClosure *)to);
1337 StgTSO *tso = stgCast(StgTSO *,q);
1338 nat size = tso_sizeW(tso);
1341 /* Large TSOs don't get moved, so no relocation is required.
1343 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1344 evacuate_large((P_)q, rtsTrue);
1347 /* To evacuate a small TSO, we need to relocate the update frame
1351 StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1353 diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1355 /* relocate the stack pointers... */
1356 new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1357 new_tso->sp = (StgPtr)new_tso->sp + diff;
1358 new_tso->splim = (StgPtr)new_tso->splim + diff;
1360 relocate_TSO(tso, new_tso);
1361 upd_evacuee(q,(StgClosure *)new_tso);
1363 recordMutable((StgMutClosure *)new_tso);
1364 return (StgClosure *)new_tso;
1370 fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1374 barf("evacuate: strange closure type");
1380 /* -----------------------------------------------------------------------------
1381 relocate_TSO is called just after a TSO has been copied from src to
1382 dest. It adjusts the update frame list for the new location.
1383 -------------------------------------------------------------------------- */
1386 relocate_TSO(StgTSO *src, StgTSO *dest)
1393 diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1397 while ((P_)su < dest->stack + dest->stack_size) {
1398 switch (get_itbl(su)->type) {
1400 /* GCC actually manages to common up these three cases! */
1403 su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1408 cf = (StgCatchFrame *)su;
1409 cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1414 sf = (StgSeqFrame *)su;
1415 sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1424 barf("relocate_TSO");
1433 scavenge_srt(const StgInfoTable *info)
1435 StgClosure **srt, **srt_end;
1437 /* evacuate the SRT. If srt_len is zero, then there isn't an
1438 * srt field in the info table. That's ok, because we'll
1439 * never dereference it.
1441 srt = stgCast(StgClosure **,info->srt);
1442 srt_end = srt + info->srt_len;
1443 for (; srt < srt_end; srt++) {
1448 /* -----------------------------------------------------------------------------
1449 Scavenge a given step until there are no more objects in this step
1452 evac_gen is set by the caller to be either zero (for a step in a
1453 generation < N) or G where G is the generation of the step being
1456 We sometimes temporarily change evac_gen back to zero if we're
1457 scavenging a mutable object where early promotion isn't such a good
1459 -------------------------------------------------------------------------- */
1463 scavenge(step *step)
1466 const StgInfoTable *info;
1468 nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1473 failed_to_evac = rtsFalse;
1475 /* scavenge phase - standard breadth-first scavenging of the
1479 while (bd != step->hp_bd || p < step->hp) {
1481 /* If we're at the end of this block, move on to the next block */
1482 if (bd != step->hp_bd && p == bd->free) {
1488 q = p; /* save ptr to object */
1490 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1491 || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1493 info = get_itbl((StgClosure *)p);
1494 switch (info -> type) {
1498 StgBCO* bco = stgCast(StgBCO*,p);
1500 for (i = 0; i < bco->n_ptrs; i++) {
1501 bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1503 p += bco_sizeW(bco);
1508 /* treat MVars specially, because we don't want to evacuate the
1509 * mut_link field in the middle of the closure.
1512 StgMVar *mvar = ((StgMVar *)p);
1514 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1515 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1516 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1517 p += sizeofW(StgMVar);
1518 evac_gen = saved_evac_gen;
1526 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1527 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1528 p += sizeofW(StgHeader) + 2;
1533 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1534 p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1540 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1541 p += sizeofW(StgHeader) + 1;
1546 p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1552 p += sizeofW(StgHeader) + 1;
1559 p += sizeofW(StgHeader) + 2;
1566 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1567 p += sizeofW(StgHeader) + 2;
1580 case IND_OLDGEN_PERM:
1586 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1587 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1588 (StgClosure *)*p = evacuate((StgClosure *)*p);
1590 p += info->layout.payload.nptrs;
1595 /* ignore MUT_CONSs */
1596 if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1598 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1599 evac_gen = saved_evac_gen;
1601 p += sizeofW(StgMutVar);
1606 p += BLACKHOLE_sizeW();
1611 StgBlockingQueue *bh = (StgBlockingQueue *)p;
1612 (StgClosure *)bh->blocking_queue =
1613 evacuate((StgClosure *)bh->blocking_queue);
1614 if (failed_to_evac) {
1615 failed_to_evac = rtsFalse;
1616 recordMutable((StgMutClosure *)bh);
1618 p += BLACKHOLE_sizeW();
1622 case THUNK_SELECTOR:
1624 StgSelector *s = (StgSelector *)p;
1625 s->selectee = evacuate(s->selectee);
1626 p += THUNK_SELECTOR_sizeW();
1632 barf("scavenge:IND???\n");
1634 case CONSTR_INTLIKE:
1635 case CONSTR_CHARLIKE:
1637 case CONSTR_NOCAF_STATIC:
1641 /* Shouldn't see a static object here. */
1642 barf("scavenge: STATIC object\n");
1654 /* Shouldn't see stack frames here. */
1655 barf("scavenge: stack frame\n");
1657 case AP_UPD: /* same as PAPs */
1659 /* Treat a PAP just like a section of stack, not forgetting to
1660 * evacuate the function pointer too...
1663 StgPAP* pap = stgCast(StgPAP*,p);
1665 pap->fun = evacuate(pap->fun);
1666 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1667 p += pap_sizeW(pap);
1672 /* nothing to follow */
1673 p += arr_words_sizeW(stgCast(StgArrWords*,p));
1677 /* follow everything */
1681 evac_gen = 0; /* repeatedly mutable */
1682 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1683 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1684 (StgClosure *)*p = evacuate((StgClosure *)*p);
1686 evac_gen = saved_evac_gen;
1690 case MUT_ARR_PTRS_FROZEN:
1691 /* follow everything */
1693 StgPtr start = p, next;
1695 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1696 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1697 (StgClosure *)*p = evacuate((StgClosure *)*p);
1699 if (failed_to_evac) {
1700 /* we can do this easier... */
1701 recordMutable((StgMutClosure *)start);
1702 failed_to_evac = rtsFalse;
1713 /* chase the link field for any TSOs on the same queue */
1714 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1715 /* scavenge this thread's stack */
1716 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1717 evac_gen = saved_evac_gen;
1718 p += tso_sizeW(tso);
1725 barf("scavenge: unimplemented/strange closure type\n");
1731 /* If we didn't manage to promote all the objects pointed to by
1732 * the current object, then we have to designate this object as
1733 * mutable (because it contains old-to-new generation pointers).
1735 if (failed_to_evac) {
1736 mkMutCons((StgClosure *)q, &generations[evac_gen]);
1737 failed_to_evac = rtsFalse;
1745 /* -----------------------------------------------------------------------------
1746 Scavenge one object.
1748 This is used for objects that are temporarily marked as mutable
1749 because they contain old-to-new generation pointers. Only certain
1750 objects can have this property.
1751 -------------------------------------------------------------------------- */
1753 scavenge_one(StgClosure *p)
1758 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1759 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1763 switch (info -> type) {
1766 case FUN_1_0: /* hardly worth specialising these guys */
1786 case IND_OLDGEN_PERM:
1792 end = (P_)p->payload + info->layout.payload.ptrs;
1793 for (q = (P_)p->payload; q < end; q++) {
1794 (StgClosure *)*q = evacuate((StgClosure *)*q);
1803 case THUNK_SELECTOR:
1805 StgSelector *s = (StgSelector *)p;
1806 s->selectee = evacuate(s->selectee);
1810 case AP_UPD: /* same as PAPs */
1812 /* Treat a PAP just like a section of stack, not forgetting to
1813 * evacuate the function pointer too...
1816 StgPAP* pap = (StgPAP *)p;
1818 pap->fun = evacuate(pap->fun);
1819 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1824 /* This might happen if for instance a MUT_CONS was pointing to a
1825 * THUNK which has since been updated. The IND_OLDGEN will
1826 * be on the mutable list anyway, so we don't need to do anything
1832 barf("scavenge_one: strange object");
1835 no_luck = failed_to_evac;
1836 failed_to_evac = rtsFalse;
1841 /* -----------------------------------------------------------------------------
1842 Scavenging mutable lists.
1844 We treat the mutable list of each generation > N (i.e. all the
1845 generations older than the one being collected) as roots. We also
1846 remove non-mutable objects from the mutable list at this point.
1847 -------------------------------------------------------------------------- */
1850 scavenge_mut_once_list(generation *gen)
1853 StgMutClosure *p, *next, *new_list;
1855 p = gen->mut_once_list;
1856 new_list = END_MUT_LIST;
1860 failed_to_evac = rtsFalse;
1862 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1864 /* make sure the info pointer is into text space */
1865 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1866 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1869 switch(info->type) {
1872 case IND_OLDGEN_PERM:
1874 /* Try to pull the indirectee into this generation, so we can
1875 * remove the indirection from the mutable list.
1877 ((StgIndOldGen *)p)->indirectee =
1878 evacuate(((StgIndOldGen *)p)->indirectee);
1881 /* Debugging code to print out the size of the thing we just
1885 StgPtr start = gen->steps[0].scan;
1886 bdescr *start_bd = gen->steps[0].scan_bd;
1888 scavenge(&gen->steps[0]);
1889 if (start_bd != gen->steps[0].scan_bd) {
1890 size += (P_)BLOCK_ROUND_UP(start) - start;
1891 start_bd = start_bd->link;
1892 while (start_bd != gen->steps[0].scan_bd) {
1893 size += BLOCK_SIZE_W;
1894 start_bd = start_bd->link;
1896 size += gen->steps[0].scan -
1897 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
1899 size = gen->steps[0].scan - start;
1901 fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
1905 /* failed_to_evac might happen if we've got more than two
1906 * generations, we're collecting only generation 0, the
1907 * indirection resides in generation 2 and the indirectee is
1910 if (failed_to_evac) {
1911 failed_to_evac = rtsFalse;
1912 p->mut_link = new_list;
1915 /* the mut_link field of an IND_STATIC is overloaded as the
1916 * static link field too (it just so happens that we don't need
1917 * both at the same time), so we need to NULL it out when
1918 * removing this object from the mutable list because the static
1919 * link fields are all assumed to be NULL before doing a major
1927 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
1928 * it from the mutable list if possible by promoting whatever it
1931 ASSERT(p->header.info == &MUT_CONS_info);
1932 if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
1933 /* didn't manage to promote everything, so put the
1934 * MUT_CONS back on the list.
1936 p->mut_link = new_list;
1942 /* shouldn't have anything else on the mutables list */
1943 barf("scavenge_mut_once_list: strange object?");
1947 gen->mut_once_list = new_list;
1952 scavenge_mutable_list(generation *gen)
1955 StgMutClosure *p, *next;
1957 p = gen->saved_mut_list;
1961 failed_to_evac = rtsFalse;
1963 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1965 /* make sure the info pointer is into text space */
1966 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1967 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1970 switch(info->type) {
1972 case MUT_ARR_PTRS_FROZEN:
1973 /* remove this guy from the mutable list, but follow the ptrs
1974 * anyway (and make sure they get promoted to this gen).
1979 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1981 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1982 (StgClosure *)*q = evacuate((StgClosure *)*q);
1986 if (failed_to_evac) {
1987 failed_to_evac = rtsFalse;
1988 p->mut_link = gen->mut_list;
1995 /* follow everything */
1996 p->mut_link = gen->mut_list;
2001 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2002 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2003 (StgClosure *)*q = evacuate((StgClosure *)*q);
2009 /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2010 * it from the mutable list if possible by promoting whatever it
2013 ASSERT(p->header.info != &MUT_CONS_info);
2014 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2015 p->mut_link = gen->mut_list;
2021 StgMVar *mvar = (StgMVar *)p;
2022 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2023 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2024 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2025 p->mut_link = gen->mut_list;
2031 /* follow ptrs and remove this from the mutable list */
2033 StgTSO *tso = (StgTSO *)p;
2035 /* Don't bother scavenging if this thread is dead
2037 if (!(tso->whatNext == ThreadComplete ||
2038 tso->whatNext == ThreadKilled)) {
2039 /* Don't need to chase the link field for any TSOs on the
2040 * same queue. Just scavenge this thread's stack
2042 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2045 /* Don't take this TSO off the mutable list - it might still
2046 * point to some younger objects (because we set evac_gen to 0
2049 tso->mut_link = gen->mut_list;
2050 gen->mut_list = (StgMutClosure *)tso;
2056 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2057 (StgClosure *)bh->blocking_queue =
2058 evacuate((StgClosure *)bh->blocking_queue);
2059 p->mut_link = gen->mut_list;
2065 /* shouldn't have anything else on the mutables list */
2066 barf("scavenge_mut_list: strange object?");
2072 scavenge_static(void)
2074 StgClosure* p = static_objects;
2075 const StgInfoTable *info;
2077 /* Always evacuate straight to the oldest generation for static
2079 evac_gen = oldest_gen->no;
2081 /* keep going until we've scavenged all the objects on the linked
2083 while (p != END_OF_STATIC_LIST) {
2087 /* make sure the info pointer is into text space */
2088 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2089 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2091 /* Take this object *off* the static_objects list,
2092 * and put it on the scavenged_static_objects list.
2094 static_objects = STATIC_LINK(info,p);
2095 STATIC_LINK(info,p) = scavenged_static_objects;
2096 scavenged_static_objects = p;
2098 switch (info -> type) {
2102 StgInd *ind = (StgInd *)p;
2103 ind->indirectee = evacuate(ind->indirectee);
2105 /* might fail to evacuate it, in which case we have to pop it
2106 * back on the mutable list (and take it off the
2107 * scavenged_static list because the static link and mut link
2108 * pointers are one and the same).
2110 if (failed_to_evac) {
2111 failed_to_evac = rtsFalse;
2112 scavenged_static_objects = STATIC_LINK(info,p);
2113 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2114 oldest_gen->mut_once_list = (StgMutClosure *)ind;
2128 next = (P_)p->payload + info->layout.payload.ptrs;
2129 /* evacuate the pointers */
2130 for (q = (P_)p->payload; q < next; q++) {
2131 (StgClosure *)*q = evacuate((StgClosure *)*q);
2137 barf("scavenge_static");
2140 ASSERT(failed_to_evac == rtsFalse);
2142 /* get the next static object from the list. Remeber, there might
2143 * be more stuff on this list now that we've done some evacuating!
2144 * (static_objects is a global)
2150 /* -----------------------------------------------------------------------------
2151 scavenge_stack walks over a section of stack and evacuates all the
2152 objects pointed to by it. We can use the same code for walking
2153 PAPs, since these are just sections of copied stack.
2154 -------------------------------------------------------------------------- */
2157 scavenge_stack(StgPtr p, StgPtr stack_end)
2160 const StgInfoTable* info;
2164 * Each time around this loop, we are looking at a chunk of stack
2165 * that starts with either a pending argument section or an
2166 * activation record.
2169 while (p < stack_end) {
2170 q = *stgCast(StgPtr*,p);
2172 /* If we've got a tag, skip over that many words on the stack */
2173 if (IS_ARG_TAG(stgCast(StgWord,q))) {
2178 /* Is q a pointer to a closure?
2180 if (! LOOKS_LIKE_GHC_INFO(q)) {
2183 if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
2184 ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2186 /* otherwise, must be a pointer into the allocation space.
2190 (StgClosure *)*p = evacuate((StgClosure *)q);
2196 * Otherwise, q must be the info pointer of an activation
2197 * record. All activation records have 'bitmap' style layout
2200 info = get_itbl(stgCast(StgClosure*,p));
2202 switch (info->type) {
2204 /* Dynamic bitmap: the mask is stored on the stack */
2206 bitmap = stgCast(StgRetDyn*,p)->liveness;
2207 p = &payloadWord(stgCast(StgRetDyn*,p),0);
2210 /* probably a slow-entry point return address: */
2216 /* Specialised code for update frames, since they're so common.
2217 * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2218 * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2222 StgUpdateFrame *frame = (StgUpdateFrame *)p;
2224 StgClosureType type = get_itbl(frame->updatee)->type;
2226 p += sizeofW(StgUpdateFrame);
2227 if (type == EVACUATED) {
2228 frame->updatee = evacuate(frame->updatee);
2231 bdescr *bd = Bdescr((P_)frame->updatee);
2233 if (bd->gen->no > N) {
2234 if (bd->gen->no < evac_gen) {
2235 failed_to_evac = rtsTrue;
2239 step = bd->step->to;
2243 to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2244 sizeofW(StgHeader), step);
2245 upd_evacuee(frame->updatee,to);
2246 frame->updatee = to;
2249 to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2250 upd_evacuee(frame->updatee,to);
2251 frame->updatee = to;
2252 recordMutable((StgMutClosure *)to);
2255 barf("scavenge_stack: UPDATE_FRAME updatee");
2260 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2267 bitmap = info->layout.bitmap;
2270 while (bitmap != 0) {
2271 if ((bitmap & 1) == 0) {
2272 (StgClosure *)*p = evacuate((StgClosure *)*p);
2275 bitmap = bitmap >> 1;
2282 /* large bitmap (> 32 entries) */
2287 StgLargeBitmap *large_bitmap;
2290 large_bitmap = info->layout.large_bitmap;
2293 for (i=0; i<large_bitmap->size; i++) {
2294 bitmap = large_bitmap->bitmap[i];
2295 q = p + sizeof(W_) * 8;
2296 while (bitmap != 0) {
2297 if ((bitmap & 1) == 0) {
2298 (StgClosure *)*p = evacuate((StgClosure *)*p);
2301 bitmap = bitmap >> 1;
2303 if (i+1 < large_bitmap->size) {
2305 (StgClosure *)*p = evacuate((StgClosure *)*p);
2311 /* and don't forget to follow the SRT */
2316 barf("scavenge_stack: weird activation record found on stack.\n");
2321 /*-----------------------------------------------------------------------------
2322 scavenge the large object list.
2324 evac_gen set by caller; similar games played with evac_gen as with
2325 scavenge() - see comment at the top of scavenge(). Most large
2326 objects are (repeatedly) mutable, so most of the time evac_gen will
2328 --------------------------------------------------------------------------- */
2331 scavenge_large(step *step)
2335 const StgInfoTable* info;
2336 nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2338 evac_gen = 0; /* most objects are mutable */
2339 bd = step->new_large_objects;
2341 for (; bd != NULL; bd = step->new_large_objects) {
2343 /* take this object *off* the large objects list and put it on
2344 * the scavenged large objects list. This is so that we can
2345 * treat new_large_objects as a stack and push new objects on
2346 * the front when evacuating.
2348 step->new_large_objects = bd->link;
2349 dbl_link_onto(bd, &step->scavenged_large_objects);
2352 info = get_itbl(stgCast(StgClosure*,p));
2354 switch (info->type) {
2356 /* only certain objects can be "large"... */
2359 /* nothing to follow */
2363 /* follow everything */
2367 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2368 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2369 (StgClosure *)*p = evacuate((StgClosure *)*p);
2374 case MUT_ARR_PTRS_FROZEN:
2375 /* follow everything */
2377 StgPtr start = p, next;
2379 evac_gen = saved_evac_gen; /* not really mutable */
2380 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2381 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2382 (StgClosure *)*p = evacuate((StgClosure *)*p);
2385 if (failed_to_evac) {
2386 recordMutable((StgMutClosure *)start);
2393 StgBCO* bco = stgCast(StgBCO*,p);
2395 evac_gen = saved_evac_gen;
2396 for (i = 0; i < bco->n_ptrs; i++) {
2397 bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2408 /* chase the link field for any TSOs on the same queue */
2409 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2410 /* scavenge this thread's stack */
2411 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2416 barf("scavenge_large: unknown/strange object");
2422 zeroStaticObjectList(StgClosure* first_static)
2426 const StgInfoTable *info;
2428 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2430 link = STATIC_LINK(info, p);
2431 STATIC_LINK(info,p) = NULL;
2435 /* This function is only needed because we share the mutable link
2436 * field with the static link field in an IND_STATIC, so we have to
2437 * zero the mut_link field before doing a major GC, which needs the
2438 * static link field.
2440 * It doesn't do any harm to zero all the mutable link fields on the
2444 zeroMutableList(StgMutClosure *first)
2446 StgMutClosure *next, *c;
2448 for (c = first; c != END_MUT_LIST; c = next) {
2454 /* -----------------------------------------------------------------------------
2456 -------------------------------------------------------------------------- */
2458 void RevertCAFs(void)
2460 while (enteredCAFs != END_CAF_LIST) {
2461 StgCAF* caf = enteredCAFs;
2463 enteredCAFs = caf->link;
2464 ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2465 SET_INFO(caf,&CAF_UNENTERED_info);
2466 caf->value = stgCast(StgClosure*,0xdeadbeef);
2467 caf->link = stgCast(StgCAF*,0xdeadbeef);
2471 void revertDeadCAFs(void)
2473 StgCAF* caf = enteredCAFs;
2474 enteredCAFs = END_CAF_LIST;
2475 while (caf != END_CAF_LIST) {
2476 StgCAF* next = caf->link;
2478 switch(GET_INFO(caf)->type) {
2481 /* This object has been evacuated, it must be live. */
2482 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2483 new->link = enteredCAFs;
2489 SET_INFO(caf,&CAF_UNENTERED_info);
2490 caf->value = stgCast(StgClosure*,0xdeadbeef);
2491 caf->link = stgCast(StgCAF*,0xdeadbeef);
2495 barf("revertDeadCAFs: enteredCAFs list corrupted");
2501 /* -----------------------------------------------------------------------------
2502 Sanity code for CAF garbage collection.
2504 With DEBUG turned on, we manage a CAF list in addition to the SRT
2505 mechanism. After GC, we run down the CAF list and blackhole any
2506 CAFs which have been garbage collected. This means we get an error
2507 whenever the program tries to enter a garbage collected CAF.
2509 Any garbage collected CAFs are taken off the CAF list at the same
2511 -------------------------------------------------------------------------- */
2519 const StgInfoTable *info;
2530 ASSERT(info->type == IND_STATIC);
2532 if (STATIC_LINK(info,p) == NULL) {
2533 IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2535 SET_INFO(p,&BLACKHOLE_info);
2536 p = STATIC_LINK2(info,p);
2540 pp = &STATIC_LINK2(info,p);
2547 /* fprintf(stderr, "%d CAFs live\n", i); */
2551 /* -----------------------------------------------------------------------------
2554 Whenever a thread returns to the scheduler after possibly doing
2555 some work, we have to run down the stack and black-hole all the
2556 closures referred to by update frames.
2557 -------------------------------------------------------------------------- */
2560 threadLazyBlackHole(StgTSO *tso)
2562 StgUpdateFrame *update_frame;
2563 StgBlockingQueue *bh;
2566 stack_end = &tso->stack[tso->stack_size];
2567 update_frame = tso->su;
2570 switch (get_itbl(update_frame)->type) {
2573 update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2577 bh = (StgBlockingQueue *)update_frame->updatee;
2579 /* if the thunk is already blackholed, it means we've also
2580 * already blackholed the rest of the thunks on this stack,
2581 * so we can stop early.
2583 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2584 * don't interfere with this optimisation.
2586 if (bh->header.info == &BLACKHOLE_info) {
2590 if (bh->header.info != &BLACKHOLE_BQ_info &&
2591 bh->header.info != &CAF_BLACKHOLE_info) {
2592 SET_INFO(bh,&BLACKHOLE_info);
2595 update_frame = update_frame->link;
2599 update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2605 barf("threadPaused");
2610 /* -----------------------------------------------------------------------------
2613 * Code largely pinched from old RTS, then hacked to bits. We also do
2614 * lazy black holing here.
2616 * -------------------------------------------------------------------------- */
2619 threadSqueezeStack(StgTSO *tso)
2621 lnat displacement = 0;
2622 StgUpdateFrame *frame;
2623 StgUpdateFrame *next_frame; /* Temporally next */
2624 StgUpdateFrame *prev_frame; /* Temporally previous */
2626 rtsBool prev_was_update_frame;
2628 bottom = &(tso->stack[tso->stack_size]);
2631 /* There must be at least one frame, namely the STOP_FRAME.
2633 ASSERT((P_)frame < bottom);
2635 /* Walk down the stack, reversing the links between frames so that
2636 * we can walk back up as we squeeze from the bottom. Note that
2637 * next_frame and prev_frame refer to next and previous as they were
2638 * added to the stack, rather than the way we see them in this
2639 * walk. (It makes the next loop less confusing.)
2641 * Stop if we find an update frame pointing to a black hole
2642 * (see comment in threadLazyBlackHole()).
2646 while ((P_)frame < bottom - 1) { /* bottom - 1 is the STOP_FRAME */
2647 prev_frame = frame->link;
2648 frame->link = next_frame;
2651 if (get_itbl(frame)->type == UPDATE_FRAME
2652 && frame->updatee->header.info == &BLACKHOLE_info) {
2657 /* Now, we're at the bottom. Frame points to the lowest update
2658 * frame on the stack, and its link actually points to the frame
2659 * above. We have to walk back up the stack, squeezing out empty
2660 * update frames and turning the pointers back around on the way
2663 * The bottom-most frame (the STOP_FRAME) has not been altered, and
2664 * we never want to eliminate it anyway. Just walk one step up
2665 * before starting to squeeze. When you get to the topmost frame,
2666 * remember that there are still some words above it that might have
2673 prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2676 * Loop through all of the frames (everything except the very
2677 * bottom). Things are complicated by the fact that we have
2678 * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2679 * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2681 while (frame != NULL) {
2683 StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2684 rtsBool is_update_frame;
2686 next_frame = frame->link;
2687 is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2690 * 1. both the previous and current frame are update frames
2691 * 2. the current frame is empty
2693 if (prev_was_update_frame && is_update_frame &&
2694 (P_)prev_frame == frame_bottom + displacement) {
2696 /* Now squeeze out the current frame */
2697 StgClosure *updatee_keep = prev_frame->updatee;
2698 StgClosure *updatee_bypass = frame->updatee;
2701 fprintf(stderr, "squeezing frame at %p\n", frame);
2704 /* Deal with blocking queues. If both updatees have blocked
2705 * threads, then we should merge the queues into the update
2706 * frame that we're keeping.
2708 * Alternatively, we could just wake them up: they'll just go
2709 * straight to sleep on the proper blackhole! This is less code
2710 * and probably less bug prone, although it's probably much
2713 #if 0 /* do it properly... */
2714 if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
2715 /* Sigh. It has one. Don't lose those threads! */
2716 if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2717 /* Urgh. Two queues. Merge them. */
2718 P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2720 while (keep_tso->link != END_TSO_QUEUE) {
2721 keep_tso = keep_tso->link;
2723 keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2726 /* For simplicity, just swap the BQ for the BH */
2727 P_ temp = updatee_keep;
2729 updatee_keep = updatee_bypass;
2730 updatee_bypass = temp;
2732 /* Record the swap in the kept frame (below) */
2733 prev_frame->updatee = updatee_keep;
2738 TICK_UPD_SQUEEZED();
2739 UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2741 sp = (P_)frame - 1; /* sp = stuff to slide */
2742 displacement += sizeofW(StgUpdateFrame);
2745 /* No squeeze for this frame */
2746 sp = frame_bottom - 1; /* Keep the current frame */
2748 /* Do lazy black-holing.
2750 if (is_update_frame) {
2751 StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2752 if (bh->header.info != &BLACKHOLE_BQ_info &&
2753 bh->header.info != &CAF_BLACKHOLE_info) {
2754 SET_INFO(bh,&BLACKHOLE_info);
2758 /* Fix the link in the current frame (should point to the frame below) */
2759 frame->link = prev_frame;
2760 prev_was_update_frame = is_update_frame;
2763 /* Now slide all words from sp up to the next frame */
2765 if (displacement > 0) {
2766 P_ next_frame_bottom;
2768 if (next_frame != NULL)
2769 next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2771 next_frame_bottom = tso->sp - 1;
2774 fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2778 while (sp >= next_frame_bottom) {
2779 sp[displacement] = *sp;
2783 (P_)prev_frame = (P_)frame + displacement;
2787 tso->sp += displacement;
2788 tso->su = prev_frame;
2791 /* -----------------------------------------------------------------------------
2794 * We have to prepare for GC - this means doing lazy black holing
2795 * here. We also take the opportunity to do stack squeezing if it's
2797 * -------------------------------------------------------------------------- */
2800 threadPaused(StgTSO *tso)
2802 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2803 threadSqueezeStack(tso); /* does black holing too */
2805 threadLazyBlackHole(tso);