1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team 1998-2003
5 * Generational garbage collector
7 * ---------------------------------------------------------------------------*/
9 #include "PosixSource.h"
15 #include "LdvProfile.h"
20 #include "BlockAlloc.h"
26 #include "ParTicky.h" // ToDo: move into Rts.h
27 #include "GCCompact.h"
30 #if defined(GRAN) || defined(PAR)
31 # include "GranSimRts.h"
32 # include "ParallelRts.h"
36 # include "ParallelDebug.h"
41 #if defined(RTS_GTK_FRONTPANEL)
42 #include "FrontPanel.h"
45 #include "RetainerProfile.h"
49 /* STATIC OBJECT LIST.
52 * We maintain a linked list of static objects that are still live.
53 * The requirements for this list are:
55 * - we need to scan the list while adding to it, in order to
56 * scavenge all the static objects (in the same way that
57 * breadth-first scavenging works for dynamic objects).
59 * - we need to be able to tell whether an object is already on
60 * the list, to break loops.
62 * Each static object has a "static link field", which we use for
63 * linking objects on to the list. We use a stack-type list, consing
64 * objects on the front as they are added (this means that the
65 * scavenge phase is depth-first, not breadth-first, but that
68 * A separate list is kept for objects that have been scavenged
69 * already - this is so that we can zero all the marks afterwards.
71 * An object is on the list if its static link field is non-zero; this
72 * means that we have to mark the end of the list with '1', not NULL.
74 * Extra notes for generational GC:
76 * Each generation has a static object list associated with it. When
77 * collecting generations up to N, we treat the static object lists
78 * from generations > N as roots.
80 * We build up a static object list while collecting generations 0..N,
81 * which is then appended to the static object list of generation N+1.
83 static StgClosure* static_objects; // live static objects
84 StgClosure* scavenged_static_objects; // static objects scavenged so far
86 /* N is the oldest generation being collected, where the generations
87 * are numbered starting at 0. A major GC (indicated by the major_gc
88 * flag) is when we're collecting all generations. We only attempt to
89 * deal with static objects and GC CAFs when doing a major GC.
92 static rtsBool major_gc;
94 /* Youngest generation that objects should be evacuated to in
95 * evacuate(). (Logically an argument to evacuate, but it's static
96 * a lot of the time so we optimise it into a global variable).
102 StgWeak *old_weak_ptr_list; // also pending finaliser list
104 /* Which stage of processing various kinds of weak pointer are we at?
105 * (see traverse_weak_ptr_list() below for discussion).
107 typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage;
108 static WeakStage weak_stage;
110 /* List of all threads during GC
112 static StgTSO *old_all_threads;
113 StgTSO *resurrected_threads;
115 /* Flag indicating failure to evacuate an object to the desired
118 static rtsBool failed_to_evac;
120 /* Old to-space (used for two-space collector only)
122 static bdescr *old_to_blocks;
124 /* Data used for allocation area sizing.
126 static lnat new_blocks; // blocks allocated during this GC
127 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC
129 /* Used to avoid long recursion due to selector thunks
131 static lnat thunk_selector_depth = 0;
132 #define MAX_THUNK_SELECTOR_DEPTH 8
134 /* -----------------------------------------------------------------------------
135 Static function declarations
136 -------------------------------------------------------------------------- */
138 static bdescr * gc_alloc_block ( step *stp );
139 static void mark_root ( StgClosure **root );
141 // Use a register argument for evacuate, if available.
143 #define REGPARM1 __attribute__((regparm(1)))
148 REGPARM1 static StgClosure * evacuate (StgClosure *q);
150 static void zero_static_object_list ( StgClosure* first_static );
151 static void zero_mutable_list ( StgMutClosure *first );
153 static rtsBool traverse_weak_ptr_list ( void );
154 static void mark_weak_ptr_list ( StgWeak **list );
156 static StgClosure * eval_thunk_selector ( nat field, StgSelector * p );
159 static void scavenge ( step * );
160 static void scavenge_mark_stack ( void );
161 static void scavenge_stack ( StgPtr p, StgPtr stack_end );
162 static rtsBool scavenge_one ( StgPtr p );
163 static void scavenge_large ( step * );
164 static void scavenge_static ( void );
165 static void scavenge_mutable_list ( generation *g );
166 static void scavenge_mut_once_list ( generation *g );
168 static void scavenge_large_bitmap ( StgPtr p,
169 StgLargeBitmap *large_bitmap,
172 #if 0 && defined(DEBUG)
173 static void gcCAFs ( void );
176 /* -----------------------------------------------------------------------------
177 inline functions etc. for dealing with the mark bitmap & stack.
178 -------------------------------------------------------------------------- */
180 #define MARK_STACK_BLOCKS 4
182 static bdescr *mark_stack_bdescr;
183 static StgPtr *mark_stack;
184 static StgPtr *mark_sp;
185 static StgPtr *mark_splim;
187 // Flag and pointers used for falling back to a linear scan when the
188 // mark stack overflows.
189 static rtsBool mark_stack_overflowed;
190 static bdescr *oldgen_scan_bd;
191 static StgPtr oldgen_scan;
193 STATIC_INLINE rtsBool
194 mark_stack_empty(void)
196 return mark_sp == mark_stack;
199 STATIC_INLINE rtsBool
200 mark_stack_full(void)
202 return mark_sp >= mark_splim;
206 reset_mark_stack(void)
208 mark_sp = mark_stack;
212 push_mark_stack(StgPtr p)
223 /* -----------------------------------------------------------------------------
224 Allocate a new to-space block in the given step.
225 -------------------------------------------------------------------------- */
228 gc_alloc_block(step *stp)
230 bdescr *bd = allocBlock();
231 bd->gen_no = stp->gen_no;
235 // blocks in to-space in generations up to and including N
236 // get the BF_EVACUATED flag.
237 if (stp->gen_no <= N) {
238 bd->flags = BF_EVACUATED;
243 // Start a new to-space block, chain it on after the previous one.
244 if (stp->hp_bd == NULL) {
247 stp->hp_bd->free = stp->hp;
248 stp->hp_bd->link = bd;
253 stp->hpLim = stp->hp + BLOCK_SIZE_W;
261 /* -----------------------------------------------------------------------------
264 Rough outline of the algorithm: for garbage collecting generation N
265 (and all younger generations):
267 - follow all pointers in the root set. the root set includes all
268 mutable objects in all generations (mutable_list and mut_once_list).
270 - for each pointer, evacuate the object it points to into either
272 + to-space of the step given by step->to, which is the next
273 highest step in this generation or the first step in the next
274 generation if this is the last step.
276 + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
277 When we evacuate an object we attempt to evacuate
278 everything it points to into the same generation - this is
279 achieved by setting evac_gen to the desired generation. If
280 we can't do this, then an entry in the mut_once list has to
281 be made for the cross-generation pointer.
283 + if the object is already in a generation > N, then leave
286 - repeatedly scavenge to-space from each step in each generation
287 being collected until no more objects can be evacuated.
289 - free from-space in each step, and set from-space = to-space.
291 Locks held: sched_mutex
293 -------------------------------------------------------------------------- */
296 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
300 lnat live, allocated, collected = 0, copied = 0;
301 lnat oldgen_saved_blocks = 0;
305 CostCentreStack *prev_CCS;
308 #if defined(DEBUG) && defined(GRAN)
309 IF_DEBUG(gc, debugBelch("@@ Starting garbage collection at %ld (%lx)\n",
313 #if defined(RTS_USER_SIGNALS)
318 // tell the STM to discard any cached closures its hoping to re-use
321 // tell the stats department that we've started a GC
324 // Init stats and print par specific (timing) info
325 PAR_TICKY_PAR_START();
327 // attribute any costs to CCS_GC
333 /* Approximate how much we allocated.
334 * Todo: only when generating stats?
336 allocated = calcAllocated();
338 /* Figure out which generation to collect
340 if (force_major_gc) {
341 N = RtsFlags.GcFlags.generations - 1;
345 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
346 if (generations[g].steps[0].n_blocks +
347 generations[g].steps[0].n_large_blocks
348 >= generations[g].max_blocks) {
352 major_gc = (N == RtsFlags.GcFlags.generations-1);
355 #ifdef RTS_GTK_FRONTPANEL
356 if (RtsFlags.GcFlags.frontpanel) {
357 updateFrontPanelBeforeGC(N);
361 // check stack sanity *before* GC (ToDo: check all threads)
363 // ToDo!: check sanity IF_DEBUG(sanity, checkTSOsSanity());
365 IF_DEBUG(sanity, checkFreeListSanity());
367 /* Initialise the static object lists
369 static_objects = END_OF_STATIC_LIST;
370 scavenged_static_objects = END_OF_STATIC_LIST;
372 /* zero the mutable list for the oldest generation (see comment by
373 * zero_mutable_list below).
376 zero_mutable_list(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
379 /* Save the old to-space if we're doing a two-space collection
381 if (RtsFlags.GcFlags.generations == 1) {
382 old_to_blocks = g0s0->to_blocks;
383 g0s0->to_blocks = NULL;
384 g0s0->n_to_blocks = 0;
387 /* Keep a count of how many new blocks we allocated during this GC
388 * (used for resizing the allocation area, later).
392 // Initialise to-space in all the generations/steps that we're
395 for (g = 0; g <= N; g++) {
396 generations[g].mut_once_list = END_MUT_LIST;
397 generations[g].mut_list = END_MUT_LIST;
399 for (s = 0; s < generations[g].n_steps; s++) {
401 // generation 0, step 0 doesn't need to-space
402 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
406 stp = &generations[g].steps[s];
407 ASSERT(stp->gen_no == g);
409 // start a new to-space for this step.
412 stp->to_blocks = NULL;
414 // allocate the first to-space block; extra blocks will be
415 // chained on as necessary.
416 bd = gc_alloc_block(stp);
418 stp->scan = bd->start;
421 // initialise the large object queues.
422 stp->new_large_objects = NULL;
423 stp->scavenged_large_objects = NULL;
424 stp->n_scavenged_large_blocks = 0;
426 // mark the large objects as not evacuated yet
427 for (bd = stp->large_objects; bd; bd = bd->link) {
428 bd->flags &= ~BF_EVACUATED;
431 // for a compacted step, we need to allocate the bitmap
432 if (stp->is_compacted) {
433 nat bitmap_size; // in bytes
434 bdescr *bitmap_bdescr;
437 bitmap_size = stp->n_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
439 if (bitmap_size > 0) {
440 bitmap_bdescr = allocGroup((nat)BLOCK_ROUND_UP(bitmap_size)
442 stp->bitmap = bitmap_bdescr;
443 bitmap = bitmap_bdescr->start;
445 IF_DEBUG(gc, debugBelch("bitmap_size: %d, bitmap: %p",
446 bitmap_size, bitmap););
448 // don't forget to fill it with zeros!
449 memset(bitmap, 0, bitmap_size);
451 // For each block in this step, point to its bitmap from the
453 for (bd=stp->blocks; bd != NULL; bd = bd->link) {
454 bd->u.bitmap = bitmap;
455 bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
457 // Also at this point we set the BF_COMPACTED flag
458 // for this block. The invariant is that
459 // BF_COMPACTED is always unset, except during GC
460 // when it is set on those blocks which will be
462 bd->flags |= BF_COMPACTED;
469 /* make sure the older generations have at least one block to
470 * allocate into (this makes things easier for copy(), see below).
472 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
473 for (s = 0; s < generations[g].n_steps; s++) {
474 stp = &generations[g].steps[s];
475 if (stp->hp_bd == NULL) {
476 ASSERT(stp->blocks == NULL);
477 bd = gc_alloc_block(stp);
481 /* Set the scan pointer for older generations: remember we
482 * still have to scavenge objects that have been promoted. */
484 stp->scan_bd = stp->hp_bd;
485 stp->to_blocks = NULL;
486 stp->n_to_blocks = 0;
487 stp->new_large_objects = NULL;
488 stp->scavenged_large_objects = NULL;
489 stp->n_scavenged_large_blocks = 0;
493 /* Allocate a mark stack if we're doing a major collection.
496 mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
497 mark_stack = (StgPtr *)mark_stack_bdescr->start;
498 mark_sp = mark_stack;
499 mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
501 mark_stack_bdescr = NULL;
504 /* -----------------------------------------------------------------------
505 * follow all the roots that we know about:
506 * - mutable lists from each generation > N
507 * we want to *scavenge* these roots, not evacuate them: they're not
508 * going to move in this GC.
509 * Also: do them in reverse generation order. This is because we
510 * often want to promote objects that are pointed to by older
511 * generations early, so we don't have to repeatedly copy them.
512 * Doing the generations in reverse order ensures that we don't end
513 * up in the situation where we want to evac an object to gen 3 and
514 * it has already been evaced to gen 2.
518 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
519 generations[g].saved_mut_list = generations[g].mut_list;
520 generations[g].mut_list = END_MUT_LIST;
523 // Do the mut-once lists first
524 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
525 IF_PAR_DEBUG(verbose,
526 printMutOnceList(&generations[g]));
527 scavenge_mut_once_list(&generations[g]);
529 for (st = generations[g].n_steps-1; st >= 0; st--) {
530 scavenge(&generations[g].steps[st]);
534 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
535 IF_PAR_DEBUG(verbose,
536 printMutableList(&generations[g]));
537 scavenge_mutable_list(&generations[g]);
539 for (st = generations[g].n_steps-1; st >= 0; st--) {
540 scavenge(&generations[g].steps[st]);
545 /* follow roots from the CAF list (used by GHCi)
550 /* follow all the roots that the application knows about.
553 get_roots(mark_root);
556 /* And don't forget to mark the TSO if we got here direct from
558 /* Not needed in a seq version?
560 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
564 // Mark the entries in the GALA table of the parallel system
565 markLocalGAs(major_gc);
566 // Mark all entries on the list of pending fetches
567 markPendingFetches(major_gc);
570 /* Mark the weak pointer list, and prepare to detect dead weak
573 mark_weak_ptr_list(&weak_ptr_list);
574 old_weak_ptr_list = weak_ptr_list;
575 weak_ptr_list = NULL;
576 weak_stage = WeakPtrs;
578 /* The all_threads list is like the weak_ptr_list.
579 * See traverse_weak_ptr_list() for the details.
581 old_all_threads = all_threads;
582 all_threads = END_TSO_QUEUE;
583 resurrected_threads = END_TSO_QUEUE;
585 /* Mark the stable pointer table.
587 markStablePtrTable(mark_root);
589 /* -------------------------------------------------------------------------
590 * Repeatedly scavenge all the areas we know about until there's no
591 * more scavenging to be done.
598 // scavenge static objects
599 if (major_gc && static_objects != END_OF_STATIC_LIST) {
600 IF_DEBUG(sanity, checkStaticObjects(static_objects));
604 /* When scavenging the older generations: Objects may have been
605 * evacuated from generations <= N into older generations, and we
606 * need to scavenge these objects. We're going to try to ensure that
607 * any evacuations that occur move the objects into at least the
608 * same generation as the object being scavenged, otherwise we
609 * have to create new entries on the mutable list for the older
613 // scavenge each step in generations 0..maxgen
619 // scavenge objects in compacted generation
620 if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
621 (mark_stack_bdescr != NULL && !mark_stack_empty())) {
622 scavenge_mark_stack();
626 for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
627 for (st = generations[gen].n_steps; --st >= 0; ) {
628 if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
631 stp = &generations[gen].steps[st];
633 if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
638 if (stp->new_large_objects != NULL) {
647 if (flag) { goto loop; }
649 // must be last... invariant is that everything is fully
650 // scavenged at this point.
651 if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something
656 /* Update the pointers from the "main thread" list - these are
657 * treated as weak pointers because we want to allow a main thread
658 * to get a BlockedOnDeadMVar exception in the same way as any other
659 * thread. Note that the threads should all have been retained by
660 * GC by virtue of being on the all_threads list, we're just
661 * updating pointers here.
666 for (m = main_threads; m != NULL; m = m->link) {
667 tso = (StgTSO *) isAlive((StgClosure *)m->tso);
669 barf("main thread has been GC'd");
676 // Reconstruct the Global Address tables used in GUM
677 rebuildGAtables(major_gc);
678 IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
681 // Now see which stable names are still alive.
684 // Tidy the end of the to-space chains
685 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
686 for (s = 0; s < generations[g].n_steps; s++) {
687 stp = &generations[g].steps[s];
688 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
689 ASSERT(Bdescr(stp->hp) == stp->hp_bd);
690 stp->hp_bd->free = stp->hp;
696 // We call processHeapClosureForDead() on every closure destroyed during
697 // the current garbage collection, so we invoke LdvCensusForDead().
698 if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
699 || RtsFlags.ProfFlags.bioSelector != NULL)
703 // NO MORE EVACUATION AFTER THIS POINT!
704 // Finally: compaction of the oldest generation.
705 if (major_gc && oldest_gen->steps[0].is_compacted) {
706 // save number of blocks for stats
707 oldgen_saved_blocks = oldest_gen->steps[0].n_blocks;
711 IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
713 /* run through all the generations/steps and tidy up
715 copied = new_blocks * BLOCK_SIZE_W;
716 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
719 generations[g].collections++; // for stats
722 for (s = 0; s < generations[g].n_steps; s++) {
724 stp = &generations[g].steps[s];
726 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
727 // stats information: how much we copied
729 copied -= stp->hp_bd->start + BLOCK_SIZE_W -
734 // for generations we collected...
737 // rough calculation of garbage collected, for stats output
738 if (stp->is_compacted) {
739 collected += (oldgen_saved_blocks - stp->n_blocks) * BLOCK_SIZE_W;
741 collected += stp->n_blocks * BLOCK_SIZE_W;
744 /* free old memory and shift to-space into from-space for all
745 * the collected steps (except the allocation area). These
746 * freed blocks will probaby be quickly recycled.
748 if (!(g == 0 && s == 0)) {
749 if (stp->is_compacted) {
750 // for a compacted step, just shift the new to-space
751 // onto the front of the now-compacted existing blocks.
752 for (bd = stp->to_blocks; bd != NULL; bd = bd->link) {
753 bd->flags &= ~BF_EVACUATED; // now from-space
755 // tack the new blocks on the end of the existing blocks
756 if (stp->blocks == NULL) {
757 stp->blocks = stp->to_blocks;
759 for (bd = stp->blocks; bd != NULL; bd = next) {
762 bd->link = stp->to_blocks;
764 // NB. this step might not be compacted next
765 // time, so reset the BF_COMPACTED flags.
766 // They are set before GC if we're going to
767 // compact. (search for BF_COMPACTED above).
768 bd->flags &= ~BF_COMPACTED;
771 // add the new blocks to the block tally
772 stp->n_blocks += stp->n_to_blocks;
774 freeChain(stp->blocks);
775 stp->blocks = stp->to_blocks;
776 stp->n_blocks = stp->n_to_blocks;
777 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
778 bd->flags &= ~BF_EVACUATED; // now from-space
781 stp->to_blocks = NULL;
782 stp->n_to_blocks = 0;
785 /* LARGE OBJECTS. The current live large objects are chained on
786 * scavenged_large, having been moved during garbage
787 * collection from large_objects. Any objects left on
788 * large_objects list are therefore dead, so we free them here.
790 for (bd = stp->large_objects; bd != NULL; bd = next) {
796 // update the count of blocks used by large objects
797 for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
798 bd->flags &= ~BF_EVACUATED;
800 stp->large_objects = stp->scavenged_large_objects;
801 stp->n_large_blocks = stp->n_scavenged_large_blocks;
804 // for older generations...
806 /* For older generations, we need to append the
807 * scavenged_large_object list (i.e. large objects that have been
808 * promoted during this GC) to the large_object list for that step.
810 for (bd = stp->scavenged_large_objects; bd; bd = next) {
812 bd->flags &= ~BF_EVACUATED;
813 dbl_link_onto(bd, &stp->large_objects);
816 // add the new blocks we promoted during this GC
817 stp->n_blocks += stp->n_to_blocks;
818 stp->n_to_blocks = 0;
819 stp->n_large_blocks += stp->n_scavenged_large_blocks;
824 /* Reset the sizes of the older generations when we do a major
827 * CURRENT STRATEGY: make all generations except zero the same size.
828 * We have to stay within the maximum heap size, and leave a certain
829 * percentage of the maximum heap size available to allocate into.
831 if (major_gc && RtsFlags.GcFlags.generations > 1) {
832 nat live, size, min_alloc;
833 nat max = RtsFlags.GcFlags.maxHeapSize;
834 nat gens = RtsFlags.GcFlags.generations;
836 // live in the oldest generations
837 live = oldest_gen->steps[0].n_blocks +
838 oldest_gen->steps[0].n_large_blocks;
840 // default max size for all generations except zero
841 size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
842 RtsFlags.GcFlags.minOldGenSize);
844 // minimum size for generation zero
845 min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
846 RtsFlags.GcFlags.minAllocAreaSize);
848 // Auto-enable compaction when the residency reaches a
849 // certain percentage of the maximum heap size (default: 30%).
850 if (RtsFlags.GcFlags.generations > 1 &&
851 (RtsFlags.GcFlags.compact ||
853 oldest_gen->steps[0].n_blocks >
854 (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
855 oldest_gen->steps[0].is_compacted = 1;
856 // debugBelch("compaction: on\n", live);
858 oldest_gen->steps[0].is_compacted = 0;
859 // debugBelch("compaction: off\n", live);
862 // if we're going to go over the maximum heap size, reduce the
863 // size of the generations accordingly. The calculation is
864 // different if compaction is turned on, because we don't need
865 // to double the space required to collect the old generation.
868 // this test is necessary to ensure that the calculations
869 // below don't have any negative results - we're working
870 // with unsigned values here.
871 if (max < min_alloc) {
875 if (oldest_gen->steps[0].is_compacted) {
876 if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
877 size = (max - min_alloc) / ((gens - 1) * 2 - 1);
880 if ( (size * (gens - 1) * 2) + min_alloc > max ) {
881 size = (max - min_alloc) / ((gens - 1) * 2);
891 debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live,
892 min_alloc, size, max);
895 for (g = 0; g < gens; g++) {
896 generations[g].max_blocks = size;
900 // Guess the amount of live data for stats.
903 /* Free the small objects allocated via allocate(), since this will
904 * all have been copied into G0S1 now.
906 if (small_alloc_list != NULL) {
907 freeChain(small_alloc_list);
909 small_alloc_list = NULL;
913 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
915 // Start a new pinned_object_block
916 pinned_object_block = NULL;
918 /* Free the mark stack.
920 if (mark_stack_bdescr != NULL) {
921 freeGroup(mark_stack_bdescr);
926 for (g = 0; g <= N; g++) {
927 for (s = 0; s < generations[g].n_steps; s++) {
928 stp = &generations[g].steps[s];
929 if (stp->is_compacted && stp->bitmap != NULL) {
930 freeGroup(stp->bitmap);
935 /* Two-space collector:
936 * Free the old to-space, and estimate the amount of live data.
938 if (RtsFlags.GcFlags.generations == 1) {
941 if (old_to_blocks != NULL) {
942 freeChain(old_to_blocks);
944 for (bd = g0s0->to_blocks; bd != NULL; bd = bd->link) {
945 bd->flags = 0; // now from-space
948 /* For a two-space collector, we need to resize the nursery. */
950 /* set up a new nursery. Allocate a nursery size based on a
951 * function of the amount of live data (by default a factor of 2)
952 * Use the blocks from the old nursery if possible, freeing up any
955 * If we get near the maximum heap size, then adjust our nursery
956 * size accordingly. If the nursery is the same size as the live
957 * data (L), then we need 3L bytes. We can reduce the size of the
958 * nursery to bring the required memory down near 2L bytes.
960 * A normal 2-space collector would need 4L bytes to give the same
961 * performance we get from 3L bytes, reducing to the same
962 * performance at 2L bytes.
964 blocks = g0s0->n_to_blocks;
966 if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
967 blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
968 RtsFlags.GcFlags.maxHeapSize ) {
969 long adjusted_blocks; // signed on purpose
972 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
973 IF_DEBUG(gc, debugBelch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
974 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
975 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
978 blocks = adjusted_blocks;
981 blocks *= RtsFlags.GcFlags.oldGenFactor;
982 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
983 blocks = RtsFlags.GcFlags.minAllocAreaSize;
986 resizeNursery(blocks);
989 /* Generational collector:
990 * If the user has given us a suggested heap size, adjust our
991 * allocation area to make best use of the memory available.
994 if (RtsFlags.GcFlags.heapSizeSuggestion) {
996 nat needed = calcNeeded(); // approx blocks needed at next GC
998 /* Guess how much will be live in generation 0 step 0 next time.
999 * A good approximation is obtained by finding the
1000 * percentage of g0s0 that was live at the last minor GC.
1003 g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
1006 /* Estimate a size for the allocation area based on the
1007 * information available. We might end up going slightly under
1008 * or over the suggested heap size, but we should be pretty
1011 * Formula: suggested - needed
1012 * ----------------------------
1013 * 1 + g0s0_pcnt_kept/100
1015 * where 'needed' is the amount of memory needed at the next
1016 * collection for collecting all steps except g0s0.
1019 (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
1020 (100 + (long)g0s0_pcnt_kept);
1022 if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
1023 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1026 resizeNursery((nat)blocks);
1029 // we might have added extra large blocks to the nursery, so
1030 // resize back to minAllocAreaSize again.
1031 resizeNursery(RtsFlags.GcFlags.minAllocAreaSize);
1035 // mark the garbage collected CAFs as dead
1036 #if 0 && defined(DEBUG) // doesn't work at the moment
1037 if (major_gc) { gcCAFs(); }
1041 // resetStaticObjectForRetainerProfiling() must be called before
1043 resetStaticObjectForRetainerProfiling();
1046 // zero the scavenged static object list
1048 zero_static_object_list(scavenged_static_objects);
1051 // Reset the nursery
1054 RELEASE_LOCK(&sched_mutex);
1056 // start any pending finalizers
1057 scheduleFinalizers(old_weak_ptr_list);
1059 // send exceptions to any threads which were about to die
1060 resurrectThreads(resurrected_threads);
1062 ACQUIRE_LOCK(&sched_mutex);
1064 // Update the stable pointer hash table.
1065 updateStablePtrTable(major_gc);
1067 // check sanity after GC
1068 IF_DEBUG(sanity, checkSanity());
1070 // extra GC trace info
1071 IF_DEBUG(gc, statDescribeGens());
1074 // symbol-table based profiling
1075 /* heapCensus(to_blocks); */ /* ToDo */
1078 // restore enclosing cost centre
1083 // check for memory leaks if sanity checking is on
1084 IF_DEBUG(sanity, memInventory());
1086 #ifdef RTS_GTK_FRONTPANEL
1087 if (RtsFlags.GcFlags.frontpanel) {
1088 updateFrontPanelAfterGC( N, live );
1092 // ok, GC over: tell the stats department what happened.
1093 stat_endGC(allocated, collected, live, copied, N);
1095 #if defined(RTS_USER_SIGNALS)
1096 // unblock signals again
1097 unblockUserSignals();
1104 /* -----------------------------------------------------------------------------
1107 traverse_weak_ptr_list is called possibly many times during garbage
1108 collection. It returns a flag indicating whether it did any work
1109 (i.e. called evacuate on any live pointers).
1111 Invariant: traverse_weak_ptr_list is called when the heap is in an
1112 idempotent state. That means that there are no pending
1113 evacuate/scavenge operations. This invariant helps the weak
1114 pointer code decide which weak pointers are dead - if there are no
1115 new live weak pointers, then all the currently unreachable ones are
1118 For generational GC: we just don't try to finalize weak pointers in
1119 older generations than the one we're collecting. This could
1120 probably be optimised by keeping per-generation lists of weak
1121 pointers, but for a few weak pointers this scheme will work.
1123 There are three distinct stages to processing weak pointers:
1125 - weak_stage == WeakPtrs
1127 We process all the weak pointers whos keys are alive (evacuate
1128 their values and finalizers), and repeat until we can find no new
1129 live keys. If no live keys are found in this pass, then we
1130 evacuate the finalizers of all the dead weak pointers in order to
1133 - weak_stage == WeakThreads
1135 Now, we discover which *threads* are still alive. Pointers to
1136 threads from the all_threads and main thread lists are the
1137 weakest of all: a pointers from the finalizer of a dead weak
1138 pointer can keep a thread alive. Any threads found to be unreachable
1139 are evacuated and placed on the resurrected_threads list so we
1140 can send them a signal later.
1142 - weak_stage == WeakDone
1144 No more evacuation is done.
1146 -------------------------------------------------------------------------- */
1149 traverse_weak_ptr_list(void)
1151 StgWeak *w, **last_w, *next_w;
1153 rtsBool flag = rtsFalse;
1155 switch (weak_stage) {
1161 /* doesn't matter where we evacuate values/finalizers to, since
1162 * these pointers are treated as roots (iff the keys are alive).
1166 last_w = &old_weak_ptr_list;
1167 for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1169 /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1170 * called on a live weak pointer object. Just remove it.
1172 if (w->header.info == &stg_DEAD_WEAK_info) {
1173 next_w = ((StgDeadWeak *)w)->link;
1178 switch (get_itbl(w)->type) {
1181 next_w = (StgWeak *)((StgEvacuated *)w)->evacuee;
1186 /* Now, check whether the key is reachable.
1188 new = isAlive(w->key);
1191 // evacuate the value and finalizer
1192 w->value = evacuate(w->value);
1193 w->finalizer = evacuate(w->finalizer);
1194 // remove this weak ptr from the old_weak_ptr list
1196 // and put it on the new weak ptr list
1198 w->link = weak_ptr_list;
1201 IF_DEBUG(weak, debugBelch("Weak pointer still alive at %p -> %p",
1206 last_w = &(w->link);
1212 barf("traverse_weak_ptr_list: not WEAK");
1216 /* If we didn't make any changes, then we can go round and kill all
1217 * the dead weak pointers. The old_weak_ptr list is used as a list
1218 * of pending finalizers later on.
1220 if (flag == rtsFalse) {
1221 for (w = old_weak_ptr_list; w; w = w->link) {
1222 w->finalizer = evacuate(w->finalizer);
1225 // Next, move to the WeakThreads stage after fully
1226 // scavenging the finalizers we've just evacuated.
1227 weak_stage = WeakThreads;
1233 /* Now deal with the all_threads list, which behaves somewhat like
1234 * the weak ptr list. If we discover any threads that are about to
1235 * become garbage, we wake them up and administer an exception.
1238 StgTSO *t, *tmp, *next, **prev;
1240 prev = &old_all_threads;
1241 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1243 (StgClosure *)tmp = isAlive((StgClosure *)t);
1249 ASSERT(get_itbl(t)->type == TSO);
1250 switch (t->what_next) {
1251 case ThreadRelocated:
1256 case ThreadComplete:
1257 // finshed or died. The thread might still be alive, but we
1258 // don't keep it on the all_threads list. Don't forget to
1259 // stub out its global_link field.
1260 next = t->global_link;
1261 t->global_link = END_TSO_QUEUE;
1269 // not alive (yet): leave this thread on the
1270 // old_all_threads list.
1271 prev = &(t->global_link);
1272 next = t->global_link;
1275 // alive: move this thread onto the all_threads list.
1276 next = t->global_link;
1277 t->global_link = all_threads;
1284 /* And resurrect any threads which were about to become garbage.
1287 StgTSO *t, *tmp, *next;
1288 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1289 next = t->global_link;
1290 (StgClosure *)tmp = evacuate((StgClosure *)t);
1291 tmp->global_link = resurrected_threads;
1292 resurrected_threads = tmp;
1296 weak_stage = WeakDone; // *now* we're done,
1297 return rtsTrue; // but one more round of scavenging, please
1300 barf("traverse_weak_ptr_list");
1306 /* -----------------------------------------------------------------------------
1307 After GC, the live weak pointer list may have forwarding pointers
1308 on it, because a weak pointer object was evacuated after being
1309 moved to the live weak pointer list. We remove those forwarding
1312 Also, we don't consider weak pointer objects to be reachable, but
1313 we must nevertheless consider them to be "live" and retain them.
1314 Therefore any weak pointer objects which haven't as yet been
1315 evacuated need to be evacuated now.
1316 -------------------------------------------------------------------------- */
1320 mark_weak_ptr_list ( StgWeak **list )
1322 StgWeak *w, **last_w;
1325 for (w = *list; w; w = w->link) {
1326 // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
1327 ASSERT(w->header.info == &stg_DEAD_WEAK_info
1328 || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
1329 (StgClosure *)w = evacuate((StgClosure *)w);
1331 last_w = &(w->link);
1335 /* -----------------------------------------------------------------------------
1336 isAlive determines whether the given closure is still alive (after
1337 a garbage collection) or not. It returns the new address of the
1338 closure if it is alive, or NULL otherwise.
1340 NOTE: Use it before compaction only!
1341 -------------------------------------------------------------------------- */
1345 isAlive(StgClosure *p)
1347 const StgInfoTable *info;
1352 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1355 // ignore static closures
1357 // ToDo: for static closures, check the static link field.
1358 // Problem here is that we sometimes don't set the link field, eg.
1359 // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1361 if (!HEAP_ALLOCED(p)) {
1365 // ignore closures in generations that we're not collecting.
1367 if (bd->gen_no > N) {
1371 // if it's a pointer into to-space, then we're done
1372 if (bd->flags & BF_EVACUATED) {
1376 // large objects use the evacuated flag
1377 if (bd->flags & BF_LARGE) {
1381 // check the mark bit for compacted steps
1382 if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1386 switch (info->type) {
1391 case IND_OLDGEN: // rely on compatible layout with StgInd
1392 case IND_OLDGEN_PERM:
1393 // follow indirections
1394 p = ((StgInd *)p)->indirectee;
1399 return ((StgEvacuated *)p)->evacuee;
1402 if (((StgTSO *)p)->what_next == ThreadRelocated) {
1403 p = (StgClosure *)((StgTSO *)p)->link;
1416 mark_root(StgClosure **root)
1418 *root = evacuate(*root);
1422 upd_evacuee(StgClosure *p, StgClosure *dest)
1424 // Source object must be in from-space:
1425 ASSERT((Bdescr((P_)p)->flags & BF_EVACUATED) == 0);
1426 // not true: (ToDo: perhaps it should be)
1427 // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
1428 SET_INFO(p, &stg_EVACUATED_info);
1429 ((StgEvacuated *)p)->evacuee = dest;
1433 STATIC_INLINE StgClosure *
1434 copy(StgClosure *src, nat size, step *stp)
1439 nat size_org = size;
1442 TICK_GC_WORDS_COPIED(size);
1443 /* Find out where we're going, using the handy "to" pointer in
1444 * the step of the source object. If it turns out we need to
1445 * evacuate to an older generation, adjust it here (see comment
1448 if (stp->gen_no < evac_gen) {
1449 #ifdef NO_EAGER_PROMOTION
1450 failed_to_evac = rtsTrue;
1452 stp = &generations[evac_gen].steps[0];
1456 /* chain a new block onto the to-space for the destination step if
1459 if (stp->hp + size >= stp->hpLim) {
1460 gc_alloc_block(stp);
1463 for(to = stp->hp, from = (P_)src; size>0; --size) {
1469 upd_evacuee(src,(StgClosure *)dest);
1471 // We store the size of the just evacuated object in the LDV word so that
1472 // the profiler can guess the position of the next object later.
1473 SET_EVACUAEE_FOR_LDV(src, size_org);
1475 return (StgClosure *)dest;
1478 /* Special version of copy() for when we only want to copy the info
1479 * pointer of an object, but reserve some padding after it. This is
1480 * used to optimise evacuation of BLACKHOLEs.
1485 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1490 nat size_to_copy_org = size_to_copy;
1493 TICK_GC_WORDS_COPIED(size_to_copy);
1494 if (stp->gen_no < evac_gen) {
1495 #ifdef NO_EAGER_PROMOTION
1496 failed_to_evac = rtsTrue;
1498 stp = &generations[evac_gen].steps[0];
1502 if (stp->hp + size_to_reserve >= stp->hpLim) {
1503 gc_alloc_block(stp);
1506 for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1511 stp->hp += size_to_reserve;
1512 upd_evacuee(src,(StgClosure *)dest);
1514 // We store the size of the just evacuated object in the LDV word so that
1515 // the profiler can guess the position of the next object later.
1516 // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1518 SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1520 if (size_to_reserve - size_to_copy_org > 0)
1521 FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1523 return (StgClosure *)dest;
1527 /* -----------------------------------------------------------------------------
1528 Evacuate a large object
1530 This just consists of removing the object from the (doubly-linked)
1531 step->large_objects list, and linking it on to the (singly-linked)
1532 step->new_large_objects list, from where it will be scavenged later.
1534 Convention: bd->flags has BF_EVACUATED set for a large object
1535 that has been evacuated, or unset otherwise.
1536 -------------------------------------------------------------------------- */
1540 evacuate_large(StgPtr p)
1542 bdescr *bd = Bdescr(p);
1545 // object must be at the beginning of the block (or be a ByteArray)
1546 ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1547 (((W_)p & BLOCK_MASK) == 0));
1549 // already evacuated?
1550 if (bd->flags & BF_EVACUATED) {
1551 /* Don't forget to set the failed_to_evac flag if we didn't get
1552 * the desired destination (see comments in evacuate()).
1554 if (bd->gen_no < evac_gen) {
1555 failed_to_evac = rtsTrue;
1556 TICK_GC_FAILED_PROMOTION();
1562 // remove from large_object list
1564 bd->u.back->link = bd->link;
1565 } else { // first object in the list
1566 stp->large_objects = bd->link;
1569 bd->link->u.back = bd->u.back;
1572 /* link it on to the evacuated large object list of the destination step
1575 if (stp->gen_no < evac_gen) {
1576 #ifdef NO_EAGER_PROMOTION
1577 failed_to_evac = rtsTrue;
1579 stp = &generations[evac_gen].steps[0];
1584 bd->gen_no = stp->gen_no;
1585 bd->link = stp->new_large_objects;
1586 stp->new_large_objects = bd;
1587 bd->flags |= BF_EVACUATED;
1590 /* -----------------------------------------------------------------------------
1591 Adding a MUT_CONS to an older generation.
1593 This is necessary from time to time when we end up with an
1594 old-to-new generation pointer in a non-mutable object. We defer
1595 the promotion until the next GC.
1596 -------------------------------------------------------------------------- */
1599 mkMutCons(StgClosure *ptr, generation *gen)
1604 stp = &gen->steps[0];
1606 /* chain a new block onto the to-space for the destination step if
1609 if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
1610 gc_alloc_block(stp);
1613 q = (StgMutVar *)stp->hp;
1614 stp->hp += sizeofW(StgMutVar);
1616 SET_HDR(q,&stg_MUT_CONS_info,CCS_GC);
1618 recordOldToNewPtrs((StgMutClosure *)q);
1620 return (StgClosure *)q;
1623 /* -----------------------------------------------------------------------------
1626 This is called (eventually) for every live object in the system.
1628 The caller to evacuate specifies a desired generation in the
1629 evac_gen global variable. The following conditions apply to
1630 evacuating an object which resides in generation M when we're
1631 collecting up to generation N
1635 else evac to step->to
1637 if M < evac_gen evac to evac_gen, step 0
1639 if the object is already evacuated, then we check which generation
1642 if M >= evac_gen do nothing
1643 if M < evac_gen set failed_to_evac flag to indicate that we
1644 didn't manage to evacuate this object into evac_gen.
1649 evacuate() is the single most important function performance-wise
1650 in the GC. Various things have been tried to speed it up, but as
1651 far as I can tell the code generated by gcc 3.2 with -O2 is about
1652 as good as it's going to get. We pass the argument to evacuate()
1653 in a register using the 'regparm' attribute (see the prototype for
1654 evacuate() near the top of this file).
1656 Changing evacuate() to take an (StgClosure **) rather than
1657 returning the new pointer seems attractive, because we can avoid
1658 writing back the pointer when it hasn't changed (eg. for a static
1659 object, or an object in a generation > N). However, I tried it and
1660 it doesn't help. One reason is that the (StgClosure **) pointer
1661 gets spilled to the stack inside evacuate(), resulting in far more
1662 extra reads/writes than we save.
1663 -------------------------------------------------------------------------- */
1665 REGPARM1 static StgClosure *
1666 evacuate(StgClosure *q)
1671 const StgInfoTable *info;
1674 if (HEAP_ALLOCED(q)) {
1677 if (bd->gen_no > N) {
1678 /* Can't evacuate this object, because it's in a generation
1679 * older than the ones we're collecting. Let's hope that it's
1680 * in evac_gen or older, or we will have to arrange to track
1681 * this pointer using the mutable list.
1683 if (bd->gen_no < evac_gen) {
1685 failed_to_evac = rtsTrue;
1686 TICK_GC_FAILED_PROMOTION();
1691 /* evacuate large objects by re-linking them onto a different list.
1693 if (bd->flags & BF_LARGE) {
1695 if (info->type == TSO &&
1696 ((StgTSO *)q)->what_next == ThreadRelocated) {
1697 q = (StgClosure *)((StgTSO *)q)->link;
1700 evacuate_large((P_)q);
1704 /* If the object is in a step that we're compacting, then we
1705 * need to use an alternative evacuate procedure.
1707 if (bd->flags & BF_COMPACTED) {
1708 if (!is_marked((P_)q,bd)) {
1710 if (mark_stack_full()) {
1711 mark_stack_overflowed = rtsTrue;
1714 push_mark_stack((P_)q);
1722 else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1725 // make sure the info pointer is into text space
1726 ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
1729 switch (info -> type) {
1733 return copy(q,sizeW_fromITBL(info),stp);
1737 StgWord w = (StgWord)q->payload[0];
1738 if (q->header.info == Czh_con_info &&
1739 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
1740 (StgChar)w <= MAX_CHARLIKE) {
1741 return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1743 if (q->header.info == Izh_con_info &&
1744 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1745 return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1747 // else, fall through ...
1753 return copy(q,sizeofW(StgHeader)+1,stp);
1755 case THUNK_1_0: // here because of MIN_UPD_SIZE
1760 #ifdef NO_PROMOTE_THUNKS
1761 if (bd->gen_no == 0 &&
1762 bd->step->no != 0 &&
1763 bd->step->no == generations[bd->gen_no].n_steps-1) {
1767 return copy(q,sizeofW(StgHeader)+2,stp);
1775 return copy(q,sizeofW(StgHeader)+2,stp);
1781 case IND_OLDGEN_PERM:
1785 return copy(q,sizeW_fromITBL(info),stp);
1788 return copy(q,bco_sizeW((StgBCO *)q),stp);
1791 case SE_CAF_BLACKHOLE:
1794 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1797 to = copy(q,BLACKHOLE_sizeW(),stp);
1800 case THUNK_SELECTOR:
1804 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
1805 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1808 p = eval_thunk_selector(info->layout.selector_offset,
1812 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1814 // q is still BLACKHOLE'd.
1815 thunk_selector_depth++;
1817 thunk_selector_depth--;
1820 // We store the size of the just evacuated object in the
1821 // LDV word so that the profiler can guess the position of
1822 // the next object later.
1823 SET_EVACUAEE_FOR_LDV(q, THUNK_SELECTOR_sizeW());
1831 // follow chains of indirections, don't evacuate them
1832 q = ((StgInd*)q)->indirectee;
1836 if (info->srt_bitmap != 0 && major_gc &&
1837 THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1838 THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1839 static_objects = (StgClosure *)q;
1844 if (info->srt_bitmap != 0 && major_gc &&
1845 FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1846 FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1847 static_objects = (StgClosure *)q;
1852 /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1853 * on the CAF list, so don't do anything with it here (we'll
1854 * scavenge it later).
1857 && ((StgIndStatic *)q)->saved_info == NULL
1858 && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1859 IND_STATIC_LINK((StgClosure *)q) = static_objects;
1860 static_objects = (StgClosure *)q;
1865 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1866 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1867 static_objects = (StgClosure *)q;
1871 case CONSTR_INTLIKE:
1872 case CONSTR_CHARLIKE:
1873 case CONSTR_NOCAF_STATIC:
1874 /* no need to put these on the static linked list, they don't need
1888 case CATCH_STM_FRAME:
1889 case CATCH_RETRY_FRAME:
1890 case ATOMICALLY_FRAME:
1891 // shouldn't see these
1892 barf("evacuate: stack frame at %p\n", q);
1896 return copy(q,pap_sizeW((StgPAP*)q),stp);
1899 return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
1902 /* Already evacuated, just return the forwarding address.
1903 * HOWEVER: if the requested destination generation (evac_gen) is
1904 * older than the actual generation (because the object was
1905 * already evacuated to a younger generation) then we have to
1906 * set the failed_to_evac flag to indicate that we couldn't
1907 * manage to promote the object to the desired generation.
1909 if (evac_gen > 0) { // optimisation
1910 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1911 if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
1912 failed_to_evac = rtsTrue;
1913 TICK_GC_FAILED_PROMOTION();
1916 return ((StgEvacuated*)q)->evacuee;
1919 // just copy the block
1920 return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1923 case MUT_ARR_PTRS_FROZEN:
1924 // just copy the block
1925 return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1929 StgTSO *tso = (StgTSO *)q;
1931 /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1933 if (tso->what_next == ThreadRelocated) {
1934 q = (StgClosure *)tso->link;
1938 /* To evacuate a small TSO, we need to relocate the update frame
1945 new_tso = (StgTSO *)copyPart((StgClosure *)tso,
1947 sizeofW(StgTSO), stp);
1948 move_TSO(tso, new_tso);
1949 for (p = tso->sp, q = new_tso->sp;
1950 p < tso->stack+tso->stack_size;) {
1954 return (StgClosure *)new_tso;
1959 case RBH: // cf. BLACKHOLE_BQ
1961 //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1962 to = copy(q,BLACKHOLE_sizeW(),stp);
1963 //ToDo: derive size etc from reverted IP
1964 //to = copy(q,size,stp);
1966 debugBelch("@@ evacuate: RBH %p (%s) to %p (%s)",
1967 q, info_type(q), to, info_type(to)));
1972 ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1973 to = copy(q,sizeofW(StgBlockedFetch),stp);
1975 debugBelch("@@ evacuate: %p (%s) to %p (%s)",
1976 q, info_type(q), to, info_type(to)));
1983 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1984 to = copy(q,sizeofW(StgFetchMe),stp);
1986 debugBelch("@@ evacuate: %p (%s) to %p (%s)",
1987 q, info_type(q), to, info_type(to)));
1991 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1992 to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1994 debugBelch("@@ evacuate: %p (%s) to %p (%s)",
1995 q, info_type(q), to, info_type(to)));
2000 return copy(q,sizeofW(StgTRecHeader),stp);
2002 case TVAR_WAIT_QUEUE:
2003 return copy(q,sizeofW(StgTVarWaitQueue),stp);
2006 return copy(q,sizeofW(StgTVar),stp);
2009 return copy(q,sizeofW(StgTRecChunk),stp);
2012 barf("evacuate: strange closure type %d", (int)(info->type));
2018 /* -----------------------------------------------------------------------------
2019 Evaluate a THUNK_SELECTOR if possible.
2021 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2022 a closure pointer if we evaluated it and this is the result. Note
2023 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2024 reducing it to HNF, just that we have eliminated the selection.
2025 The result might be another thunk, or even another THUNK_SELECTOR.
2027 If the return value is non-NULL, the original selector thunk has
2028 been BLACKHOLE'd, and should be updated with an indirection or a
2029 forwarding pointer. If the return value is NULL, then the selector
2031 -------------------------------------------------------------------------- */
2033 static inline rtsBool
2034 is_to_space ( StgClosure *p )
2038 bd = Bdescr((StgPtr)p);
2039 if (HEAP_ALLOCED(p) &&
2040 ((bd->flags & BF_EVACUATED)
2041 || ((bd->flags & BF_COMPACTED) &&
2042 is_marked((P_)p,bd)))) {
2050 eval_thunk_selector( nat field, StgSelector * p )
2053 const StgInfoTable *info_ptr;
2054 StgClosure *selectee;
2056 selectee = p->selectee;
2058 // Save the real info pointer (NOTE: not the same as get_itbl()).
2059 info_ptr = p->header.info;
2061 // If the THUNK_SELECTOR is in a generation that we are not
2062 // collecting, then bail out early. We won't be able to save any
2063 // space in any case, and updating with an indirection is trickier
2065 if (Bdescr((StgPtr)p)->gen_no > N) {
2069 // BLACKHOLE the selector thunk, since it is now under evaluation.
2070 // This is important to stop us going into an infinite loop if
2071 // this selector thunk eventually refers to itself.
2072 SET_INFO(p,&stg_BLACKHOLE_info);
2076 // We don't want to end up in to-space, because this causes
2077 // problems when the GC later tries to evacuate the result of
2078 // eval_thunk_selector(). There are various ways this could
2081 // 1. following an IND_STATIC
2083 // 2. when the old generation is compacted, the mark phase updates
2084 // from-space pointers to be to-space pointers, and we can't
2085 // reliably tell which we're following (eg. from an IND_STATIC).
2087 // 3. compacting GC again: if we're looking at a constructor in
2088 // the compacted generation, it might point directly to objects
2089 // in to-space. We must bale out here, otherwise doing the selection
2090 // will result in a to-space pointer being returned.
2092 // (1) is dealt with using a BF_EVACUATED test on the
2093 // selectee. (2) and (3): we can tell if we're looking at an
2094 // object in the compacted generation that might point to
2095 // to-space objects by testing that (a) it is BF_COMPACTED, (b)
2096 // the compacted generation is being collected, and (c) the
2097 // object is marked. Only a marked object may have pointers that
2098 // point to to-space objects, because that happens when
2101 // The to-space test is now embodied in the in_to_space() inline
2102 // function, as it is re-used below.
2104 if (is_to_space(selectee)) {
2108 info = get_itbl(selectee);
2109 switch (info->type) {
2117 case CONSTR_NOCAF_STATIC:
2118 // check that the size is in range
2119 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
2120 info->layout.payload.nptrs));
2122 // Select the right field from the constructor, and check
2123 // that the result isn't in to-space. It might be in
2124 // to-space if, for example, this constructor contains
2125 // pointers to younger-gen objects (and is on the mut-once
2130 q = selectee->payload[field];
2131 if (is_to_space(q)) {
2141 case IND_OLDGEN_PERM:
2143 selectee = ((StgInd *)selectee)->indirectee;
2147 // We don't follow pointers into to-space; the constructor
2148 // has already been evacuated, so we won't save any space
2149 // leaks by evaluating this selector thunk anyhow.
2152 case THUNK_SELECTOR:
2156 // check that we don't recurse too much, re-using the
2157 // depth bound also used in evacuate().
2158 thunk_selector_depth++;
2159 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2163 val = eval_thunk_selector(info->layout.selector_offset,
2164 (StgSelector *)selectee);
2166 thunk_selector_depth--;
2171 // We evaluated this selector thunk, so update it with
2172 // an indirection. NOTE: we don't use UPD_IND here,
2173 // because we are guaranteed that p is in a generation
2174 // that we are collecting, and we never want to put the
2175 // indirection on a mutable list.
2177 // For the purposes of LDV profiling, we have destroyed
2178 // the original selector thunk.
2179 SET_INFO(p, info_ptr);
2180 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2182 ((StgInd *)selectee)->indirectee = val;
2183 SET_INFO(selectee,&stg_IND_info);
2185 // For the purposes of LDV profiling, we have created an
2187 LDV_RECORD_CREATE(selectee);
2204 case SE_CAF_BLACKHOLE:
2217 // not evaluated yet
2221 barf("eval_thunk_selector: strange selectee %d",
2226 // We didn't manage to evaluate this thunk; restore the old info pointer
2227 SET_INFO(p, info_ptr);
2231 /* -----------------------------------------------------------------------------
2232 move_TSO is called to update the TSO structure after it has been
2233 moved from one place to another.
2234 -------------------------------------------------------------------------- */
2237 move_TSO (StgTSO *src, StgTSO *dest)
2241 // relocate the stack pointer...
2242 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2243 dest->sp = (StgPtr)dest->sp + diff;
2246 /* Similar to scavenge_large_bitmap(), but we don't write back the
2247 * pointers we get back from evacuate().
2250 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2257 bitmap = large_srt->l.bitmap[b];
2258 size = (nat)large_srt->l.size;
2259 p = (StgClosure **)large_srt->srt;
2260 for (i = 0; i < size; ) {
2261 if ((bitmap & 1) != 0) {
2266 if (i % BITS_IN(W_) == 0) {
2268 bitmap = large_srt->l.bitmap[b];
2270 bitmap = bitmap >> 1;
2275 /* evacuate the SRT. If srt_bitmap is zero, then there isn't an
2276 * srt field in the info table. That's ok, because we'll
2277 * never dereference it.
2280 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2285 bitmap = srt_bitmap;
2288 if (bitmap == (StgHalfWord)(-1)) {
2289 scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2293 while (bitmap != 0) {
2294 if ((bitmap & 1) != 0) {
2295 #ifdef ENABLE_WIN32_DLL_SUPPORT
2296 // Special-case to handle references to closures hiding out in DLLs, since
2297 // double indirections required to get at those. The code generator knows
2298 // which is which when generating the SRT, so it stores the (indirect)
2299 // reference to the DLL closure in the table by first adding one to it.
2300 // We check for this here, and undo the addition before evacuating it.
2302 // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2303 // closure that's fixed at link-time, and no extra magic is required.
2304 if ( (unsigned long)(*srt) & 0x1 ) {
2305 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2314 bitmap = bitmap >> 1;
2320 scavenge_thunk_srt(const StgInfoTable *info)
2322 StgThunkInfoTable *thunk_info;
2324 thunk_info = itbl_to_thunk_itbl(info);
2325 scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2329 scavenge_fun_srt(const StgInfoTable *info)
2331 StgFunInfoTable *fun_info;
2333 fun_info = itbl_to_fun_itbl(info);
2334 scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2338 scavenge_ret_srt(const StgInfoTable *info)
2340 StgRetInfoTable *ret_info;
2342 ret_info = itbl_to_ret_itbl(info);
2343 scavenge_srt((StgClosure **)GET_SRT(ret_info), ret_info->i.srt_bitmap);
2346 /* -----------------------------------------------------------------------------
2348 -------------------------------------------------------------------------- */
2351 scavengeTSO (StgTSO *tso)
2353 // chase the link field for any TSOs on the same queue
2354 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2355 if ( tso->why_blocked == BlockedOnMVar
2356 || tso->why_blocked == BlockedOnBlackHole
2357 || tso->why_blocked == BlockedOnException
2359 || tso->why_blocked == BlockedOnGA
2360 || tso->why_blocked == BlockedOnGA_NoSend
2363 tso->block_info.closure = evacuate(tso->block_info.closure);
2365 if ( tso->blocked_exceptions != NULL ) {
2366 tso->blocked_exceptions =
2367 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2370 // scavange current transaction record
2371 (StgClosure *)tso->trec = evacuate((StgClosure *)tso->trec);
2373 // scavenge this thread's stack
2374 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2377 /* -----------------------------------------------------------------------------
2378 Blocks of function args occur on the stack (at the top) and
2380 -------------------------------------------------------------------------- */
2382 STATIC_INLINE StgPtr
2383 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2390 switch (fun_info->f.fun_type) {
2392 bitmap = BITMAP_BITS(fun_info->f.bitmap);
2393 size = BITMAP_SIZE(fun_info->f.bitmap);
2396 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2397 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2401 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2402 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2405 if ((bitmap & 1) == 0) {
2406 (StgClosure *)*p = evacuate((StgClosure *)*p);
2409 bitmap = bitmap >> 1;
2417 STATIC_INLINE StgPtr
2418 scavenge_PAP (StgPAP *pap)
2421 StgWord bitmap, size;
2422 StgFunInfoTable *fun_info;
2424 pap->fun = evacuate(pap->fun);
2425 fun_info = get_fun_itbl(pap->fun);
2426 ASSERT(fun_info->i.type != PAP);
2428 p = (StgPtr)pap->payload;
2431 switch (fun_info->f.fun_type) {
2433 bitmap = BITMAP_BITS(fun_info->f.bitmap);
2436 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2440 scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
2444 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2448 if ((bitmap & 1) == 0) {
2449 (StgClosure *)*p = evacuate((StgClosure *)*p);
2452 bitmap = bitmap >> 1;
2460 /* -----------------------------------------------------------------------------
2461 Scavenge a given step until there are no more objects in this step
2464 evac_gen is set by the caller to be either zero (for a step in a
2465 generation < N) or G where G is the generation of the step being
2468 We sometimes temporarily change evac_gen back to zero if we're
2469 scavenging a mutable object where early promotion isn't such a good
2471 -------------------------------------------------------------------------- */
2479 nat saved_evac_gen = evac_gen;
2484 failed_to_evac = rtsFalse;
2486 /* scavenge phase - standard breadth-first scavenging of the
2490 while (bd != stp->hp_bd || p < stp->hp) {
2492 // If we're at the end of this block, move on to the next block
2493 if (bd != stp->hp_bd && p == bd->free) {
2499 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2500 info = get_itbl((StgClosure *)p);
2502 ASSERT(thunk_selector_depth == 0);
2505 switch (info->type) {
2508 /* treat MVars specially, because we don't want to evacuate the
2509 * mut_link field in the middle of the closure.
2512 StgMVar *mvar = ((StgMVar *)p);
2514 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2515 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2516 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2517 evac_gen = saved_evac_gen;
2518 recordMutable((StgMutClosure *)mvar);
2519 failed_to_evac = rtsFalse; // mutable.
2520 p += sizeofW(StgMVar);
2525 scavenge_fun_srt(info);
2526 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2527 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2528 p += sizeofW(StgHeader) + 2;
2532 scavenge_thunk_srt(info);
2534 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2535 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2536 p += sizeofW(StgHeader) + 2;
2540 scavenge_thunk_srt(info);
2541 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2542 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2546 scavenge_fun_srt(info);
2548 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2549 p += sizeofW(StgHeader) + 1;
2553 scavenge_thunk_srt(info);
2554 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2558 scavenge_fun_srt(info);
2560 p += sizeofW(StgHeader) + 1;
2564 scavenge_thunk_srt(info);
2565 p += sizeofW(StgHeader) + 2;
2569 scavenge_fun_srt(info);
2571 p += sizeofW(StgHeader) + 2;
2575 scavenge_thunk_srt(info);
2576 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2577 p += sizeofW(StgHeader) + 2;
2581 scavenge_fun_srt(info);
2583 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2584 p += sizeofW(StgHeader) + 2;
2588 scavenge_fun_srt(info);
2592 scavenge_thunk_srt(info);
2603 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2604 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2605 (StgClosure *)*p = evacuate((StgClosure *)*p);
2607 p += info->layout.payload.nptrs;
2612 StgBCO *bco = (StgBCO *)p;
2613 (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2614 (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2615 (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2616 (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2617 p += bco_sizeW(bco);
2622 if (stp->gen->no != 0) {
2625 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2626 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2627 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2630 // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2632 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2634 // We pretend that p has just been created.
2635 LDV_RECORD_CREATE((StgClosure *)p);
2638 case IND_OLDGEN_PERM:
2639 ((StgIndOldGen *)p)->indirectee =
2640 evacuate(((StgIndOldGen *)p)->indirectee);
2641 if (failed_to_evac) {
2642 failed_to_evac = rtsFalse;
2643 recordOldToNewPtrs((StgMutClosure *)p);
2645 p += sizeofW(StgIndOldGen);
2650 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2651 evac_gen = saved_evac_gen;
2652 recordMutable((StgMutClosure *)p);
2653 failed_to_evac = rtsFalse; // mutable anyhow
2654 p += sizeofW(StgMutVar);
2659 failed_to_evac = rtsFalse; // mutable anyhow
2660 p += sizeofW(StgMutVar);
2664 case SE_CAF_BLACKHOLE:
2667 p += BLACKHOLE_sizeW();
2672 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2673 (StgClosure *)bh->blocking_queue =
2674 evacuate((StgClosure *)bh->blocking_queue);
2675 recordMutable((StgMutClosure *)bh);
2676 failed_to_evac = rtsFalse;
2677 p += BLACKHOLE_sizeW();
2681 case THUNK_SELECTOR:
2683 StgSelector *s = (StgSelector *)p;
2684 s->selectee = evacuate(s->selectee);
2685 p += THUNK_SELECTOR_sizeW();
2689 // A chunk of stack saved in a heap object
2692 StgAP_STACK *ap = (StgAP_STACK *)p;
2694 ap->fun = evacuate(ap->fun);
2695 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2696 p = (StgPtr)ap->payload + ap->size;
2702 p = scavenge_PAP((StgPAP *)p);
2706 // nothing to follow
2707 p += arr_words_sizeW((StgArrWords *)p);
2711 // follow everything
2715 evac_gen = 0; // repeatedly mutable
2716 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2717 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2718 (StgClosure *)*p = evacuate((StgClosure *)*p);
2720 evac_gen = saved_evac_gen;
2721 recordMutable((StgMutClosure *)q);
2722 failed_to_evac = rtsFalse; // mutable anyhow.
2726 case MUT_ARR_PTRS_FROZEN:
2727 // follow everything
2731 // Set the mut_link field to NULL, so that we will put this
2732 // array back on the mutable list if it is subsequently thawed
2734 ((StgMutArrPtrs*)p)->mut_link = NULL;
2736 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2737 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2738 (StgClosure *)*p = evacuate((StgClosure *)*p);
2740 // it's tempting to recordMutable() if failed_to_evac is
2741 // false, but that breaks some assumptions (eg. every
2742 // closure on the mutable list is supposed to have the MUT
2743 // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2749 StgTSO *tso = (StgTSO *)p;
2752 evac_gen = saved_evac_gen;
2753 recordMutable((StgMutClosure *)tso);
2754 failed_to_evac = rtsFalse; // mutable anyhow.
2755 p += tso_sizeW(tso);
2760 case RBH: // cf. BLACKHOLE_BQ
2763 nat size, ptrs, nonptrs, vhs;
2765 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2767 StgRBH *rbh = (StgRBH *)p;
2768 (StgClosure *)rbh->blocking_queue =
2769 evacuate((StgClosure *)rbh->blocking_queue);
2770 recordMutable((StgMutClosure *)to);
2771 failed_to_evac = rtsFalse; // mutable anyhow.
2773 debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2774 p, info_type(p), (StgClosure *)rbh->blocking_queue));
2775 // ToDo: use size of reverted closure here!
2776 p += BLACKHOLE_sizeW();
2782 StgBlockedFetch *bf = (StgBlockedFetch *)p;
2783 // follow the pointer to the node which is being demanded
2784 (StgClosure *)bf->node =
2785 evacuate((StgClosure *)bf->node);
2786 // follow the link to the rest of the blocking queue
2787 (StgClosure *)bf->link =
2788 evacuate((StgClosure *)bf->link);
2789 if (failed_to_evac) {
2790 failed_to_evac = rtsFalse;
2791 recordMutable((StgMutClosure *)bf);
2794 debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2795 bf, info_type((StgClosure *)bf),
2796 bf->node, info_type(bf->node)));
2797 p += sizeofW(StgBlockedFetch);
2805 p += sizeofW(StgFetchMe);
2806 break; // nothing to do in this case
2808 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2810 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2811 (StgClosure *)fmbq->blocking_queue =
2812 evacuate((StgClosure *)fmbq->blocking_queue);
2813 if (failed_to_evac) {
2814 failed_to_evac = rtsFalse;
2815 recordMutable((StgMutClosure *)fmbq);
2818 debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
2819 p, info_type((StgClosure *)p)));
2820 p += sizeofW(StgFetchMeBlockingQueue);
2825 case TVAR_WAIT_QUEUE:
2827 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
2829 (StgClosure *)wq->waiting_tso = evacuate((StgClosure*)wq->waiting_tso);
2830 (StgClosure *)wq->next_queue_entry = evacuate((StgClosure*)wq->next_queue_entry);
2831 (StgClosure *)wq->prev_queue_entry = evacuate((StgClosure*)wq->prev_queue_entry);
2832 evac_gen = saved_evac_gen;
2833 recordMutable((StgMutClosure *)wq);
2834 failed_to_evac = rtsFalse; // mutable
2835 p += sizeofW(StgTVarWaitQueue);
2841 StgTVar *tvar = ((StgTVar *) p);
2843 (StgClosure *)tvar->current_value = evacuate((StgClosure*)tvar->current_value);
2844 (StgClosure *)tvar->first_wait_queue_entry = evacuate((StgClosure*)tvar->first_wait_queue_entry);
2845 evac_gen = saved_evac_gen;
2846 recordMutable((StgMutClosure *)tvar);
2847 failed_to_evac = rtsFalse; // mutable
2848 p += sizeofW(StgTVar);
2854 StgTRecHeader *trec = ((StgTRecHeader *) p);
2856 (StgClosure *)trec->enclosing_trec = evacuate((StgClosure*)trec->enclosing_trec);
2857 (StgClosure *)trec->current_chunk = evacuate((StgClosure*)trec->current_chunk);
2858 evac_gen = saved_evac_gen;
2859 recordMutable((StgMutClosure *)trec);
2860 failed_to_evac = rtsFalse; // mutable
2861 p += sizeofW(StgTRecHeader);
2868 StgTRecChunk *tc = ((StgTRecChunk *) p);
2869 TRecEntry *e = &(tc -> entries[0]);
2871 (StgClosure *)tc->prev_chunk = evacuate((StgClosure*)tc->prev_chunk);
2872 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
2873 (StgClosure *)e->tvar = evacuate((StgClosure*)e->tvar);
2874 (StgClosure *)e->expected_value = evacuate((StgClosure*)e->expected_value);
2875 (StgClosure *)e->new_value = evacuate((StgClosure*)e->new_value);
2877 evac_gen = saved_evac_gen;
2878 recordMutable((StgMutClosure *)tc);
2879 failed_to_evac = rtsFalse; // mutable
2880 p += sizeofW(StgTRecChunk);
2885 barf("scavenge: unimplemented/strange closure type %d @ %p",
2889 /* If we didn't manage to promote all the objects pointed to by
2890 * the current object, then we have to designate this object as
2891 * mutable (because it contains old-to-new generation pointers).
2893 if (failed_to_evac) {
2894 failed_to_evac = rtsFalse;
2895 mkMutCons((StgClosure *)q, &generations[evac_gen]);
2903 /* -----------------------------------------------------------------------------
2904 Scavenge everything on the mark stack.
2906 This is slightly different from scavenge():
2907 - we don't walk linearly through the objects, so the scavenger
2908 doesn't need to advance the pointer on to the next object.
2909 -------------------------------------------------------------------------- */
2912 scavenge_mark_stack(void)
2918 evac_gen = oldest_gen->no;
2919 saved_evac_gen = evac_gen;
2922 while (!mark_stack_empty()) {
2923 p = pop_mark_stack();
2925 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2926 info = get_itbl((StgClosure *)p);
2929 switch (info->type) {
2932 /* treat MVars specially, because we don't want to evacuate the
2933 * mut_link field in the middle of the closure.
2936 StgMVar *mvar = ((StgMVar *)p);
2938 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2939 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2940 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2941 evac_gen = saved_evac_gen;
2942 failed_to_evac = rtsFalse; // mutable.
2947 scavenge_fun_srt(info);
2948 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2949 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2953 scavenge_thunk_srt(info);
2955 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2956 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2961 scavenge_fun_srt(info);
2962 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2967 scavenge_thunk_srt(info);
2970 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2975 scavenge_fun_srt(info);
2980 scavenge_thunk_srt(info);
2988 scavenge_fun_srt(info);
2992 scavenge_thunk_srt(info);
3003 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3004 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3005 (StgClosure *)*p = evacuate((StgClosure *)*p);
3011 StgBCO *bco = (StgBCO *)p;
3012 (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
3013 (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
3014 (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
3015 (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
3020 // don't need to do anything here: the only possible case
3021 // is that we're in a 1-space compacting collector, with
3022 // no "old" generation.
3026 case IND_OLDGEN_PERM:
3027 ((StgIndOldGen *)p)->indirectee =
3028 evacuate(((StgIndOldGen *)p)->indirectee);
3029 if (failed_to_evac) {
3030 recordOldToNewPtrs((StgMutClosure *)p);
3032 failed_to_evac = rtsFalse;
3037 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3038 evac_gen = saved_evac_gen;
3039 failed_to_evac = rtsFalse;
3044 failed_to_evac = rtsFalse;
3048 case SE_CAF_BLACKHOLE:
3056 StgBlockingQueue *bh = (StgBlockingQueue *)p;
3057 (StgClosure *)bh->blocking_queue =
3058 evacuate((StgClosure *)bh->blocking_queue);
3059 failed_to_evac = rtsFalse;
3063 case THUNK_SELECTOR:
3065 StgSelector *s = (StgSelector *)p;
3066 s->selectee = evacuate(s->selectee);
3070 // A chunk of stack saved in a heap object
3073 StgAP_STACK *ap = (StgAP_STACK *)p;
3075 ap->fun = evacuate(ap->fun);
3076 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3082 scavenge_PAP((StgPAP *)p);
3086 // follow everything
3090 evac_gen = 0; // repeatedly mutable
3091 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3092 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3093 (StgClosure *)*p = evacuate((StgClosure *)*p);
3095 evac_gen = saved_evac_gen;
3096 failed_to_evac = rtsFalse; // mutable anyhow.
3100 case MUT_ARR_PTRS_FROZEN:
3101 // follow everything
3105 // Set the mut_link field to NULL, so that we will put this
3106 // array on the mutable list if it is subsequently thawed
3108 ((StgMutArrPtrs*)p)->mut_link = NULL;
3110 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3111 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3112 (StgClosure *)*p = evacuate((StgClosure *)*p);
3119 StgTSO *tso = (StgTSO *)p;
3122 evac_gen = saved_evac_gen;
3123 failed_to_evac = rtsFalse;
3128 case RBH: // cf. BLACKHOLE_BQ
3131 nat size, ptrs, nonptrs, vhs;
3133 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3135 StgRBH *rbh = (StgRBH *)p;
3136 (StgClosure *)rbh->blocking_queue =
3137 evacuate((StgClosure *)rbh->blocking_queue);
3138 recordMutable((StgMutClosure *)rbh);
3139 failed_to_evac = rtsFalse; // mutable anyhow.
3141 debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3142 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3148 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3149 // follow the pointer to the node which is being demanded
3150 (StgClosure *)bf->node =
3151 evacuate((StgClosure *)bf->node);
3152 // follow the link to the rest of the blocking queue
3153 (StgClosure *)bf->link =
3154 evacuate((StgClosure *)bf->link);
3155 if (failed_to_evac) {
3156 failed_to_evac = rtsFalse;
3157 recordMutable((StgMutClosure *)bf);
3160 debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3161 bf, info_type((StgClosure *)bf),
3162 bf->node, info_type(bf->node)));
3170 break; // nothing to do in this case
3172 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3174 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3175 (StgClosure *)fmbq->blocking_queue =
3176 evacuate((StgClosure *)fmbq->blocking_queue);
3177 if (failed_to_evac) {
3178 failed_to_evac = rtsFalse;
3179 recordMutable((StgMutClosure *)fmbq);
3182 debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3183 p, info_type((StgClosure *)p)));
3188 case TVAR_WAIT_QUEUE:
3190 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3192 (StgClosure *)wq->waiting_tso = evacuate((StgClosure*)wq->waiting_tso);
3193 (StgClosure *)wq->next_queue_entry = evacuate((StgClosure*)wq->next_queue_entry);
3194 (StgClosure *)wq->prev_queue_entry = evacuate((StgClosure*)wq->prev_queue_entry);
3195 evac_gen = saved_evac_gen;
3196 recordMutable((StgMutClosure *)wq);
3197 failed_to_evac = rtsFalse; // mutable
3203 StgTVar *tvar = ((StgTVar *) p);
3205 (StgClosure *)tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3206 (StgClosure *)tvar->first_wait_queue_entry = evacuate((StgClosure*)tvar->first_wait_queue_entry);
3207 evac_gen = saved_evac_gen;
3208 recordMutable((StgMutClosure *)tvar);
3209 failed_to_evac = rtsFalse; // mutable
3216 StgTRecChunk *tc = ((StgTRecChunk *) p);
3217 TRecEntry *e = &(tc -> entries[0]);
3219 (StgClosure *)tc->prev_chunk = evacuate((StgClosure*)tc->prev_chunk);
3220 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3221 (StgClosure *)e->tvar = evacuate((StgClosure*)e->tvar);
3222 (StgClosure *)e->expected_value = evacuate((StgClosure*)e->expected_value);
3223 (StgClosure *)e->new_value = evacuate((StgClosure*)e->new_value);
3225 evac_gen = saved_evac_gen;
3226 recordMutable((StgMutClosure *)tc);
3227 failed_to_evac = rtsFalse; // mutable
3233 StgTRecHeader *trec = ((StgTRecHeader *) p);
3235 (StgClosure *)trec->enclosing_trec = evacuate((StgClosure*)trec->enclosing_trec);
3236 (StgClosure *)trec->current_chunk = evacuate((StgClosure*)trec->current_chunk);
3237 evac_gen = saved_evac_gen;
3238 recordMutable((StgMutClosure *)trec);
3239 failed_to_evac = rtsFalse; // mutable
3244 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3248 if (failed_to_evac) {
3249 failed_to_evac = rtsFalse;
3250 mkMutCons((StgClosure *)q, &generations[evac_gen]);
3253 // mark the next bit to indicate "scavenged"
3254 mark(q+1, Bdescr(q));
3256 } // while (!mark_stack_empty())
3258 // start a new linear scan if the mark stack overflowed at some point
3259 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3260 IF_DEBUG(gc, debugBelch("scavenge_mark_stack: starting linear scan"));
3261 mark_stack_overflowed = rtsFalse;
3262 oldgen_scan_bd = oldest_gen->steps[0].blocks;
3263 oldgen_scan = oldgen_scan_bd->start;
3266 if (oldgen_scan_bd) {
3267 // push a new thing on the mark stack
3269 // find a closure that is marked but not scavenged, and start
3271 while (oldgen_scan < oldgen_scan_bd->free
3272 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3276 if (oldgen_scan < oldgen_scan_bd->free) {
3278 // already scavenged?
3279 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3280 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3283 push_mark_stack(oldgen_scan);
3284 // ToDo: bump the linear scan by the actual size of the object
3285 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3289 oldgen_scan_bd = oldgen_scan_bd->link;
3290 if (oldgen_scan_bd != NULL) {
3291 oldgen_scan = oldgen_scan_bd->start;
3297 /* -----------------------------------------------------------------------------
3298 Scavenge one object.
3300 This is used for objects that are temporarily marked as mutable
3301 because they contain old-to-new generation pointers. Only certain
3302 objects can have this property.
3303 -------------------------------------------------------------------------- */
3306 scavenge_one(StgPtr p)
3308 const StgInfoTable *info;
3309 nat saved_evac_gen = evac_gen;
3312 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3313 info = get_itbl((StgClosure *)p);
3315 switch (info->type) {
3318 case FUN_1_0: // hardly worth specialising these guys
3338 case IND_OLDGEN_PERM:
3342 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3343 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3344 (StgClosure *)*q = evacuate((StgClosure *)*q);
3350 case SE_CAF_BLACKHOLE:
3355 case THUNK_SELECTOR:
3357 StgSelector *s = (StgSelector *)p;
3358 s->selectee = evacuate(s->selectee);
3363 // nothing to follow
3368 // follow everything
3371 evac_gen = 0; // repeatedly mutable
3372 recordMutable((StgMutClosure *)p);
3373 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3374 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3375 (StgClosure *)*p = evacuate((StgClosure *)*p);
3377 evac_gen = saved_evac_gen;
3378 failed_to_evac = rtsFalse;
3382 case MUT_ARR_PTRS_FROZEN:
3384 // follow everything
3387 // Set the mut_link field to NULL, so that we will put this
3388 // array on the mutable list if it is subsequently thawed
3390 ((StgMutArrPtrs*)p)->mut_link = NULL;
3392 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3393 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3394 (StgClosure *)*p = evacuate((StgClosure *)*p);
3401 StgTSO *tso = (StgTSO *)p;
3403 evac_gen = 0; // repeatedly mutable
3405 recordMutable((StgMutClosure *)tso);
3406 evac_gen = saved_evac_gen;
3407 failed_to_evac = rtsFalse;
3413 StgAP_STACK *ap = (StgAP_STACK *)p;
3415 ap->fun = evacuate(ap->fun);
3416 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3417 p = (StgPtr)ap->payload + ap->size;
3423 p = scavenge_PAP((StgPAP *)p);
3427 // This might happen if for instance a MUT_CONS was pointing to a
3428 // THUNK which has since been updated. The IND_OLDGEN will
3429 // be on the mutable list anyway, so we don't need to do anything
3434 barf("scavenge_one: strange object %d", (int)(info->type));
3437 no_luck = failed_to_evac;
3438 failed_to_evac = rtsFalse;
3442 /* -----------------------------------------------------------------------------
3443 Scavenging mutable lists.
3445 We treat the mutable list of each generation > N (i.e. all the
3446 generations older than the one being collected) as roots. We also
3447 remove non-mutable objects from the mutable list at this point.
3448 -------------------------------------------------------------------------- */
3451 scavenge_mut_once_list(generation *gen)
3453 const StgInfoTable *info;
3454 StgMutClosure *p, *next, *new_list;
3456 p = gen->mut_once_list;
3457 new_list = END_MUT_LIST;
3461 failed_to_evac = rtsFalse;
3463 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3465 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3468 if (info->type==RBH)
3469 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3471 switch(info->type) {
3474 case IND_OLDGEN_PERM:
3476 /* Try to pull the indirectee into this generation, so we can
3477 * remove the indirection from the mutable list.
3479 ((StgIndOldGen *)p)->indirectee =
3480 evacuate(((StgIndOldGen *)p)->indirectee);
3482 #if 0 && defined(DEBUG)
3483 if (RtsFlags.DebugFlags.gc)
3484 /* Debugging code to print out the size of the thing we just
3488 StgPtr start = gen->steps[0].scan;
3489 bdescr *start_bd = gen->steps[0].scan_bd;
3491 scavenge(&gen->steps[0]);
3492 if (start_bd != gen->steps[0].scan_bd) {
3493 size += (P_)BLOCK_ROUND_UP(start) - start;
3494 start_bd = start_bd->link;
3495 while (start_bd != gen->steps[0].scan_bd) {
3496 size += BLOCK_SIZE_W;
3497 start_bd = start_bd->link;
3499 size += gen->steps[0].scan -
3500 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3502 size = gen->steps[0].scan - start;
3504 debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3508 /* failed_to_evac might happen if we've got more than two
3509 * generations, we're collecting only generation 0, the
3510 * indirection resides in generation 2 and the indirectee is
3513 if (failed_to_evac) {
3514 failed_to_evac = rtsFalse;
3515 p->mut_link = new_list;
3518 /* the mut_link field of an IND_STATIC is overloaded as the
3519 * static link field too (it just so happens that we don't need
3520 * both at the same time), so we need to NULL it out when
3521 * removing this object from the mutable list because the static
3522 * link fields are all assumed to be NULL before doing a major
3530 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3531 * it from the mutable list if possible by promoting whatever it
3534 if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3535 /* didn't manage to promote everything, so put the
3536 * MUT_CONS back on the list.
3538 p->mut_link = new_list;
3544 // shouldn't have anything else on the mutables list
3545 barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3549 gen->mut_once_list = new_list;
3554 scavenge_mutable_list(generation *gen)
3556 const StgInfoTable *info;
3557 StgMutClosure *p, *next;
3559 p = gen->saved_mut_list;
3563 failed_to_evac = rtsFalse;
3565 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3567 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3570 if (info->type==RBH)
3571 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3573 switch(info->type) {
3576 // follow everything
3577 p->mut_link = gen->mut_list;
3582 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3583 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3584 (StgClosure *)*q = evacuate((StgClosure *)*q);
3589 // Happens if a MUT_ARR_PTRS in the old generation is frozen
3590 case MUT_ARR_PTRS_FROZEN:
3595 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3596 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3597 (StgClosure *)*q = evacuate((StgClosure *)*q);
3600 // Set the mut_link field to NULL, so that we will put this
3601 // array back on the mutable list if it is subsequently thawed
3604 if (failed_to_evac) {
3605 failed_to_evac = rtsFalse;
3606 mkMutCons((StgClosure *)p, gen);
3612 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3613 p->mut_link = gen->mut_list;
3619 StgMVar *mvar = (StgMVar *)p;
3620 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3621 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3622 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3623 p->mut_link = gen->mut_list;
3630 StgTSO *tso = (StgTSO *)p;
3634 /* Don't take this TSO off the mutable list - it might still
3635 * point to some younger objects (because we set evac_gen to 0
3638 tso->mut_link = gen->mut_list;
3639 gen->mut_list = (StgMutClosure *)tso;
3645 StgBlockingQueue *bh = (StgBlockingQueue *)p;
3646 (StgClosure *)bh->blocking_queue =
3647 evacuate((StgClosure *)bh->blocking_queue);
3648 p->mut_link = gen->mut_list;
3653 /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3656 case IND_OLDGEN_PERM:
3657 /* Try to pull the indirectee into this generation, so we can
3658 * remove the indirection from the mutable list.
3661 ((StgIndOldGen *)p)->indirectee =
3662 evacuate(((StgIndOldGen *)p)->indirectee);
3665 if (failed_to_evac) {
3666 failed_to_evac = rtsFalse;
3667 p->mut_link = gen->mut_once_list;
3668 gen->mut_once_list = p;
3675 // HWL: check whether all of these are necessary
3677 case RBH: // cf. BLACKHOLE_BQ
3679 // nat size, ptrs, nonptrs, vhs;
3681 // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3682 StgRBH *rbh = (StgRBH *)p;
3683 (StgClosure *)rbh->blocking_queue =
3684 evacuate((StgClosure *)rbh->blocking_queue);
3685 if (failed_to_evac) {
3686 failed_to_evac = rtsFalse;
3687 recordMutable((StgMutClosure *)rbh);
3689 // ToDo: use size of reverted closure here!
3690 p += BLACKHOLE_sizeW();
3696 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3697 // follow the pointer to the node which is being demanded
3698 (StgClosure *)bf->node =
3699 evacuate((StgClosure *)bf->node);
3700 // follow the link to the rest of the blocking queue
3701 (StgClosure *)bf->link =
3702 evacuate((StgClosure *)bf->link);
3703 if (failed_to_evac) {
3704 failed_to_evac = rtsFalse;
3705 recordMutable((StgMutClosure *)bf);
3707 p += sizeofW(StgBlockedFetch);
3713 barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3716 p += sizeofW(StgFetchMe);
3717 break; // nothing to do in this case
3719 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3721 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3722 (StgClosure *)fmbq->blocking_queue =
3723 evacuate((StgClosure *)fmbq->blocking_queue);
3724 if (failed_to_evac) {
3725 failed_to_evac = rtsFalse;
3726 recordMutable((StgMutClosure *)fmbq);
3728 p += sizeofW(StgFetchMeBlockingQueue);
3733 case TVAR_WAIT_QUEUE:
3735 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3736 (StgClosure *)wq->waiting_tso = evacuate((StgClosure*)wq->waiting_tso);
3737 (StgClosure *)wq->next_queue_entry = evacuate((StgClosure*)wq->next_queue_entry);
3738 (StgClosure *)wq->prev_queue_entry = evacuate((StgClosure*)wq->prev_queue_entry);
3739 p->mut_link = gen->mut_list;
3746 StgTVar *tvar = ((StgTVar *) p);
3747 (StgClosure *)tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3748 (StgClosure *)tvar->first_wait_queue_entry = evacuate((StgClosure*)tvar->first_wait_queue_entry);
3749 p->mut_link = gen->mut_list;
3757 StgTRecChunk *tc = ((StgTRecChunk *) p);
3758 TRecEntry *e = &(tc -> entries[0]);
3759 (StgClosure *)tc->prev_chunk = evacuate((StgClosure*)tc->prev_chunk);
3760 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3761 (StgClosure *)e->tvar = evacuate((StgClosure*)e->tvar);
3762 (StgClosure *)e->expected_value = evacuate((StgClosure*)e->expected_value);
3763 (StgClosure *)e->new_value = evacuate((StgClosure*)e->new_value);
3765 p->mut_link = gen->mut_list;
3772 StgTRecHeader *trec = ((StgTRecHeader *) p);
3773 (StgClosure *)trec->enclosing_trec = evacuate((StgClosure*)trec->enclosing_trec);
3774 (StgClosure *)trec->current_chunk = evacuate((StgClosure*)trec->current_chunk);
3775 p->mut_link = gen->mut_list;
3781 // shouldn't have anything else on the mutables list
3782 barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3789 scavenge_static(void)
3791 StgClosure* p = static_objects;
3792 const StgInfoTable *info;
3794 /* Always evacuate straight to the oldest generation for static
3796 evac_gen = oldest_gen->no;
3798 /* keep going until we've scavenged all the objects on the linked
3800 while (p != END_OF_STATIC_LIST) {
3802 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3805 if (info->type==RBH)
3806 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3808 // make sure the info pointer is into text space
3810 /* Take this object *off* the static_objects list,
3811 * and put it on the scavenged_static_objects list.
3813 static_objects = STATIC_LINK(info,p);
3814 STATIC_LINK(info,p) = scavenged_static_objects;
3815 scavenged_static_objects = p;
3817 switch (info -> type) {
3821 StgInd *ind = (StgInd *)p;
3822 ind->indirectee = evacuate(ind->indirectee);
3824 /* might fail to evacuate it, in which case we have to pop it
3825 * back on the mutable list (and take it off the
3826 * scavenged_static list because the static link and mut link
3827 * pointers are one and the same).
3829 if (failed_to_evac) {
3830 failed_to_evac = rtsFalse;
3831 scavenged_static_objects = IND_STATIC_LINK(p);
3832 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3833 oldest_gen->mut_once_list = (StgMutClosure *)ind;
3839 scavenge_thunk_srt(info);
3843 scavenge_fun_srt(info);
3850 next = (P_)p->payload + info->layout.payload.ptrs;
3851 // evacuate the pointers
3852 for (q = (P_)p->payload; q < next; q++) {
3853 (StgClosure *)*q = evacuate((StgClosure *)*q);
3859 barf("scavenge_static: strange closure %d", (int)(info->type));
3862 ASSERT(failed_to_evac == rtsFalse);
3864 /* get the next static object from the list. Remember, there might
3865 * be more stuff on this list now that we've done some evacuating!
3866 * (static_objects is a global)
3872 /* -----------------------------------------------------------------------------
3873 scavenge a chunk of memory described by a bitmap
3874 -------------------------------------------------------------------------- */
3877 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
3883 bitmap = large_bitmap->bitmap[b];
3884 for (i = 0; i < size; ) {
3885 if ((bitmap & 1) == 0) {
3886 (StgClosure *)*p = evacuate((StgClosure *)*p);
3890 if (i % BITS_IN(W_) == 0) {
3892 bitmap = large_bitmap->bitmap[b];
3894 bitmap = bitmap >> 1;
3899 STATIC_INLINE StgPtr
3900 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
3903 if ((bitmap & 1) == 0) {
3904 (StgClosure *)*p = evacuate((StgClosure *)*p);
3907 bitmap = bitmap >> 1;
3913 /* -----------------------------------------------------------------------------
3914 scavenge_stack walks over a section of stack and evacuates all the
3915 objects pointed to by it. We can use the same code for walking
3916 AP_STACK_UPDs, since these are just sections of copied stack.
3917 -------------------------------------------------------------------------- */
3921 scavenge_stack(StgPtr p, StgPtr stack_end)
3923 const StgRetInfoTable* info;
3927 //IF_DEBUG(sanity, debugBelch(" scavenging stack between %p and %p", p, stack_end));
3930 * Each time around this loop, we are looking at a chunk of stack
3931 * that starts with an activation record.
3934 while (p < stack_end) {
3935 info = get_ret_itbl((StgClosure *)p);
3937 switch (info->i.type) {
3940 ((StgUpdateFrame *)p)->updatee
3941 = evacuate(((StgUpdateFrame *)p)->updatee);
3942 p += sizeofW(StgUpdateFrame);
3945 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3946 case CATCH_STM_FRAME:
3947 case CATCH_RETRY_FRAME:
3948 case ATOMICALLY_FRAME:
3953 bitmap = BITMAP_BITS(info->i.layout.bitmap);
3954 size = BITMAP_SIZE(info->i.layout.bitmap);
3955 // NOTE: the payload starts immediately after the info-ptr, we
3956 // don't have an StgHeader in the same sense as a heap closure.
3958 p = scavenge_small_bitmap(p, size, bitmap);
3961 scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
3969 (StgClosure *)*p = evacuate((StgClosure *)*p);
3972 size = BCO_BITMAP_SIZE(bco);
3973 scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
3978 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3984 size = GET_LARGE_BITMAP(&info->i)->size;
3986 scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
3988 // and don't forget to follow the SRT
3992 // Dynamic bitmap: the mask is stored on the stack, and
3993 // there are a number of non-pointers followed by a number
3994 // of pointers above the bitmapped area. (see StgMacros.h,
3999 dyn = ((StgRetDyn *)p)->liveness;
4001 // traverse the bitmap first
4002 bitmap = RET_DYN_LIVENESS(dyn);
4003 p = (P_)&((StgRetDyn *)p)->payload[0];
4004 size = RET_DYN_BITMAP_SIZE;
4005 p = scavenge_small_bitmap(p, size, bitmap);
4007 // skip over the non-ptr words
4008 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
4010 // follow the ptr words
4011 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
4012 (StgClosure *)*p = evacuate((StgClosure *)*p);
4020 StgRetFun *ret_fun = (StgRetFun *)p;
4021 StgFunInfoTable *fun_info;
4023 ret_fun->fun = evacuate(ret_fun->fun);
4024 fun_info = get_fun_itbl(ret_fun->fun);
4025 p = scavenge_arg_block(fun_info, ret_fun->payload);
4030 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
4035 /*-----------------------------------------------------------------------------
4036 scavenge the large object list.
4038 evac_gen set by caller; similar games played with evac_gen as with
4039 scavenge() - see comment at the top of scavenge(). Most large
4040 objects are (repeatedly) mutable, so most of the time evac_gen will
4042 --------------------------------------------------------------------------- */
4045 scavenge_large(step *stp)
4050 bd = stp->new_large_objects;
4052 for (; bd != NULL; bd = stp->new_large_objects) {
4054 /* take this object *off* the large objects list and put it on
4055 * the scavenged large objects list. This is so that we can
4056 * treat new_large_objects as a stack and push new objects on
4057 * the front when evacuating.
4059 stp->new_large_objects = bd->link;
4060 dbl_link_onto(bd, &stp->scavenged_large_objects);
4062 // update the block count in this step.
4063 stp->n_scavenged_large_blocks += bd->blocks;
4066 if (scavenge_one(p)) {
4067 mkMutCons((StgClosure *)p, stp->gen);
4072 /* -----------------------------------------------------------------------------
4073 Initialising the static object & mutable lists
4074 -------------------------------------------------------------------------- */
4077 zero_static_object_list(StgClosure* first_static)
4081 const StgInfoTable *info;
4083 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
4085 link = STATIC_LINK(info, p);
4086 STATIC_LINK(info,p) = NULL;
4090 /* This function is only needed because we share the mutable link
4091 * field with the static link field in an IND_STATIC, so we have to
4092 * zero the mut_link field before doing a major GC, which needs the
4093 * static link field.
4095 * It doesn't do any harm to zero all the mutable link fields on the
4100 zero_mutable_list( StgMutClosure *first )
4102 StgMutClosure *next, *c;
4104 for (c = first; c != END_MUT_LIST; c = next) {
4110 /* -----------------------------------------------------------------------------
4112 -------------------------------------------------------------------------- */
4119 for (c = (StgIndStatic *)caf_list; c != NULL;
4120 c = (StgIndStatic *)c->static_link)
4122 SET_INFO(c, c->saved_info);
4123 c->saved_info = NULL;
4124 // could, but not necessary: c->static_link = NULL;
4130 markCAFs( evac_fn evac )
4134 for (c = (StgIndStatic *)caf_list; c != NULL;
4135 c = (StgIndStatic *)c->static_link)
4137 evac(&c->indirectee);
4141 /* -----------------------------------------------------------------------------
4142 Sanity code for CAF garbage collection.
4144 With DEBUG turned on, we manage a CAF list in addition to the SRT
4145 mechanism. After GC, we run down the CAF list and blackhole any
4146 CAFs which have been garbage collected. This means we get an error
4147 whenever the program tries to enter a garbage collected CAF.
4149 Any garbage collected CAFs are taken off the CAF list at the same
4151 -------------------------------------------------------------------------- */
4153 #if 0 && defined(DEBUG)
4160 const StgInfoTable *info;
4171 ASSERT(info->type == IND_STATIC);
4173 if (STATIC_LINK(info,p) == NULL) {
4174 IF_DEBUG(gccafs, debugBelch("CAF gc'd at 0x%04lx", (long)p));
4176 SET_INFO(p,&stg_BLACKHOLE_info);
4177 p = STATIC_LINK2(info,p);
4181 pp = &STATIC_LINK2(info,p);
4188 // debugBelch("%d CAFs live", i);
4193 /* -----------------------------------------------------------------------------
4196 Whenever a thread returns to the scheduler after possibly doing
4197 some work, we have to run down the stack and black-hole all the
4198 closures referred to by update frames.
4199 -------------------------------------------------------------------------- */
4202 threadLazyBlackHole(StgTSO *tso)
4205 StgRetInfoTable *info;
4206 StgBlockingQueue *bh;
4209 stack_end = &tso->stack[tso->stack_size];
4211 frame = (StgClosure *)tso->sp;
4214 info = get_ret_itbl(frame);
4216 switch (info->i.type) {
4219 bh = (StgBlockingQueue *)((StgUpdateFrame *)frame)->updatee;
4221 /* if the thunk is already blackholed, it means we've also
4222 * already blackholed the rest of the thunks on this stack,
4223 * so we can stop early.
4225 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
4226 * don't interfere with this optimisation.
4228 if (bh->header.info == &stg_BLACKHOLE_info) {
4232 if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
4233 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4234 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4235 debugBelch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4239 // We pretend that bh is now dead.
4240 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4242 SET_INFO(bh,&stg_BLACKHOLE_info);
4244 // We pretend that bh has just been created.
4245 LDV_RECORD_CREATE(bh);
4248 frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4254 // normal stack frames; do nothing except advance the pointer
4256 (StgPtr)frame += stack_frame_sizeW(frame);
4262 /* -----------------------------------------------------------------------------
4265 * Code largely pinched from old RTS, then hacked to bits. We also do
4266 * lazy black holing here.
4268 * -------------------------------------------------------------------------- */
4270 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4273 threadSqueezeStack(StgTSO *tso)
4276 rtsBool prev_was_update_frame;
4277 StgClosure *updatee = NULL;
4279 StgRetInfoTable *info;
4280 StgWord current_gap_size;
4281 struct stack_gap *gap;
4284 // Traverse the stack upwards, replacing adjacent update frames
4285 // with a single update frame and a "stack gap". A stack gap
4286 // contains two values: the size of the gap, and the distance
4287 // to the next gap (or the stack top).
4289 bottom = &(tso->stack[tso->stack_size]);
4293 ASSERT(frame < bottom);
4295 prev_was_update_frame = rtsFalse;
4296 current_gap_size = 0;
4297 gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4299 while (frame < bottom) {
4301 info = get_ret_itbl((StgClosure *)frame);
4302 switch (info->i.type) {
4306 StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4308 if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
4310 // found a BLACKHOLE'd update frame; we've been here
4311 // before, in a previous GC, so just break out.
4313 // Mark the end of the gap, if we're in one.
4314 if (current_gap_size != 0) {
4315 gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
4318 frame += sizeofW(StgUpdateFrame);
4319 goto done_traversing;
4322 if (prev_was_update_frame) {
4324 TICK_UPD_SQUEEZED();
4325 /* wasn't there something about update squeezing and ticky to be
4326 * sorted out? oh yes: we aren't counting each enter properly
4327 * in this case. See the log somewhere. KSW 1999-04-21
4329 * Check two things: that the two update frames don't point to
4330 * the same object, and that the updatee_bypass isn't already an
4331 * indirection. Both of these cases only happen when we're in a
4332 * block hole-style loop (and there are multiple update frames
4333 * on the stack pointing to the same closure), but they can both
4334 * screw us up if we don't check.
4336 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4337 // this wakes the threads up
4338 UPD_IND_NOLOCK(upd->updatee, updatee);
4341 // now mark this update frame as a stack gap. The gap
4342 // marker resides in the bottom-most update frame of
4343 // the series of adjacent frames, and covers all the
4344 // frames in this series.
4345 current_gap_size += sizeofW(StgUpdateFrame);
4346 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4347 ((struct stack_gap *)frame)->next_gap = gap;
4349 frame += sizeofW(StgUpdateFrame);
4353 // single update frame, or the topmost update frame in a series
4355 StgBlockingQueue *bh = (StgBlockingQueue *)upd->updatee;
4357 // Do lazy black-holing
4358 if (bh->header.info != &stg_BLACKHOLE_info &&
4359 bh->header.info != &stg_BLACKHOLE_BQ_info &&
4360 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4361 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4362 debugBelch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4365 /* zero out the slop so that the sanity checker can tell
4366 * where the next closure is.
4369 StgInfoTable *bh_info = get_itbl(bh);
4370 nat np = bh_info->layout.payload.ptrs,
4371 nw = bh_info->layout.payload.nptrs, i;
4372 /* don't zero out slop for a THUNK_SELECTOR,
4373 * because its layout info is used for a
4374 * different purpose, and it's exactly the
4375 * same size as a BLACKHOLE in any case.
4377 if (bh_info->type != THUNK_SELECTOR) {
4378 for (i = 0; i < np + nw; i++) {
4379 ((StgClosure *)bh)->payload[i] = INVALID_OBJECT;
4385 // We pretend that bh is now dead.
4386 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4388 // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
4389 SET_INFO(bh,&stg_BLACKHOLE_info);
4391 // We pretend that bh has just been created.
4392 LDV_RECORD_CREATE(bh);
4395 prev_was_update_frame = rtsTrue;
4396 updatee = upd->updatee;
4397 frame += sizeofW(StgUpdateFrame);
4403 prev_was_update_frame = rtsFalse;
4405 // we're not in a gap... check whether this is the end of a gap
4406 // (an update frame can't be the end of a gap).
4407 if (current_gap_size != 0) {
4408 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4410 current_gap_size = 0;
4412 frame += stack_frame_sizeW((StgClosure *)frame);
4419 // Now we have a stack with gaps in it, and we have to walk down
4420 // shoving the stack up to fill in the gaps. A diagram might
4424 // | ********* | <- sp
4428 // | stack_gap | <- gap | chunk_size
4430 // | ......... | <- gap_end v
4436 // 'sp' points the the current top-of-stack
4437 // 'gap' points to the stack_gap structure inside the gap
4438 // ***** indicates real stack data
4439 // ..... indicates gap
4440 // <empty> indicates unused
4444 void *gap_start, *next_gap_start, *gap_end;
4447 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4448 sp = next_gap_start;
4450 while ((StgPtr)gap > tso->sp) {
4452 // we're working in *bytes* now...
4453 gap_start = next_gap_start;
4454 gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4456 gap = gap->next_gap;
4457 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4459 chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4460 (unsigned char*)sp -= chunk_size;
4461 memmove(sp, next_gap_start, chunk_size);
4464 tso->sp = (StgPtr)sp;
4468 /* -----------------------------------------------------------------------------
4471 * We have to prepare for GC - this means doing lazy black holing
4472 * here. We also take the opportunity to do stack squeezing if it's
4474 * -------------------------------------------------------------------------- */
4476 threadPaused(StgTSO *tso)
4478 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4479 threadSqueezeStack(tso); // does black holing too
4481 threadLazyBlackHole(tso);
4484 /* -----------------------------------------------------------------------------
4486 * -------------------------------------------------------------------------- */
4490 printMutOnceList(generation *gen)
4492 StgMutClosure *p, *next;
4494 p = gen->mut_once_list;
4497 debugBelch("@@ Mut once list %p: ", gen->mut_once_list);
4498 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4499 debugBelch("%p (%s), ",
4500 p, info_type((StgClosure *)p));
4506 printMutableList(generation *gen)
4508 StgMutClosure *p, *next;
4513 debugBelch("@@ Mutable list %p: ", gen->mut_list);
4514 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4515 debugBelch("%p (%s), ",
4516 p, info_type((StgClosure *)p));
4521 STATIC_INLINE rtsBool
4522 maybeLarge(StgClosure *closure)
4524 StgInfoTable *info = get_itbl(closure);
4526 /* closure types that may be found on the new_large_objects list;
4527 see scavenge_large */
4528 return (info->type == MUT_ARR_PTRS ||
4529 info->type == MUT_ARR_PTRS_FROZEN ||
4530 info->type == TSO ||
4531 info->type == ARR_WORDS);