1 /* -----------------------------------------------------------------------------
2 * $Id: GC.c,v 1.168 2004/08/13 13:09:49 simonmar Exp $
4 * (c) The GHC Team 1998-2003
6 * Generational garbage collector
8 * ---------------------------------------------------------------------------*/
10 #include "PosixSource.h"
16 #include "LdvProfile.h"
20 #include "SchedAPI.h" // for ReverCAFs prototype
22 #include "BlockAlloc.h"
28 #include "ParTicky.h" // ToDo: move into Rts.h
29 #include "GCCompact.h"
31 #if defined(GRAN) || defined(PAR)
32 # include "GranSimRts.h"
33 # include "ParallelRts.h"
37 # include "ParallelDebug.h"
42 #if defined(RTS_GTK_FRONTPANEL)
43 #include "FrontPanel.h"
46 #include "RetainerProfile.h"
50 /* STATIC OBJECT LIST.
53 * We maintain a linked list of static objects that are still live.
54 * The requirements for this list are:
56 * - we need to scan the list while adding to it, in order to
57 * scavenge all the static objects (in the same way that
58 * breadth-first scavenging works for dynamic objects).
60 * - we need to be able to tell whether an object is already on
61 * the list, to break loops.
63 * Each static object has a "static link field", which we use for
64 * linking objects on to the list. We use a stack-type list, consing
65 * objects on the front as they are added (this means that the
66 * scavenge phase is depth-first, not breadth-first, but that
69 * A separate list is kept for objects that have been scavenged
70 * already - this is so that we can zero all the marks afterwards.
72 * An object is on the list if its static link field is non-zero; this
73 * means that we have to mark the end of the list with '1', not NULL.
75 * Extra notes for generational GC:
77 * Each generation has a static object list associated with it. When
78 * collecting generations up to N, we treat the static object lists
79 * from generations > N as roots.
81 * We build up a static object list while collecting generations 0..N,
82 * which is then appended to the static object list of generation N+1.
84 static StgClosure* static_objects; // live static objects
85 StgClosure* scavenged_static_objects; // static objects scavenged so far
87 /* N is the oldest generation being collected, where the generations
88 * are numbered starting at 0. A major GC (indicated by the major_gc
89 * flag) is when we're collecting all generations. We only attempt to
90 * deal with static objects and GC CAFs when doing a major GC.
93 static rtsBool major_gc;
95 /* Youngest generation that objects should be evacuated to in
96 * evacuate(). (Logically an argument to evacuate, but it's static
97 * a lot of the time so we optimise it into a global variable).
103 StgWeak *old_weak_ptr_list; // also pending finaliser list
105 /* Which stage of processing various kinds of weak pointer are we at?
106 * (see traverse_weak_ptr_list() below for discussion).
108 typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage;
109 static WeakStage weak_stage;
111 /* List of all threads during GC
113 static StgTSO *old_all_threads;
114 StgTSO *resurrected_threads;
116 /* Flag indicating failure to evacuate an object to the desired
119 static rtsBool failed_to_evac;
121 /* Old to-space (used for two-space collector only)
123 static bdescr *old_to_blocks;
125 /* Data used for allocation area sizing.
127 static lnat new_blocks; // blocks allocated during this GC
128 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC
130 /* Used to avoid long recursion due to selector thunks
132 static lnat thunk_selector_depth = 0;
133 #define MAX_THUNK_SELECTOR_DEPTH 8
135 /* -----------------------------------------------------------------------------
136 Static function declarations
137 -------------------------------------------------------------------------- */
139 static bdescr * gc_alloc_block ( step *stp );
140 static void mark_root ( StgClosure **root );
142 // Use a register argument for evacuate, if available.
144 #define REGPARM1 __attribute__((regparm(1)))
149 REGPARM1 static StgClosure * evacuate (StgClosure *q);
151 static void zero_static_object_list ( StgClosure* first_static );
152 static void zero_mutable_list ( StgMutClosure *first );
154 static rtsBool traverse_weak_ptr_list ( void );
155 static void mark_weak_ptr_list ( StgWeak **list );
157 static StgClosure * eval_thunk_selector ( nat field, StgSelector * p );
160 static void scavenge ( step * );
161 static void scavenge_mark_stack ( void );
162 static void scavenge_stack ( StgPtr p, StgPtr stack_end );
163 static rtsBool scavenge_one ( StgPtr p );
164 static void scavenge_large ( step * );
165 static void scavenge_static ( void );
166 static void scavenge_mutable_list ( generation *g );
167 static void scavenge_mut_once_list ( generation *g );
169 static void scavenge_large_bitmap ( StgPtr p,
170 StgLargeBitmap *large_bitmap,
173 #if 0 && defined(DEBUG)
174 static void gcCAFs ( void );
177 /* -----------------------------------------------------------------------------
178 inline functions etc. for dealing with the mark bitmap & stack.
179 -------------------------------------------------------------------------- */
181 #define MARK_STACK_BLOCKS 4
183 static bdescr *mark_stack_bdescr;
184 static StgPtr *mark_stack;
185 static StgPtr *mark_sp;
186 static StgPtr *mark_splim;
188 // Flag and pointers used for falling back to a linear scan when the
189 // mark stack overflows.
190 static rtsBool mark_stack_overflowed;
191 static bdescr *oldgen_scan_bd;
192 static StgPtr oldgen_scan;
194 STATIC_INLINE rtsBool
195 mark_stack_empty(void)
197 return mark_sp == mark_stack;
200 STATIC_INLINE rtsBool
201 mark_stack_full(void)
203 return mark_sp >= mark_splim;
207 reset_mark_stack(void)
209 mark_sp = mark_stack;
213 push_mark_stack(StgPtr p)
224 /* -----------------------------------------------------------------------------
225 Allocate a new to-space block in the given step.
226 -------------------------------------------------------------------------- */
229 gc_alloc_block(step *stp)
231 bdescr *bd = allocBlock();
232 bd->gen_no = stp->gen_no;
236 // blocks in to-space in generations up to and including N
237 // get the BF_EVACUATED flag.
238 if (stp->gen_no <= N) {
239 bd->flags = BF_EVACUATED;
244 // Start a new to-space block, chain it on after the previous one.
245 if (stp->hp_bd == NULL) {
248 stp->hp_bd->free = stp->hp;
249 stp->hp_bd->link = bd;
254 stp->hpLim = stp->hp + BLOCK_SIZE_W;
262 /* -----------------------------------------------------------------------------
265 Rough outline of the algorithm: for garbage collecting generation N
266 (and all younger generations):
268 - follow all pointers in the root set. the root set includes all
269 mutable objects in all generations (mutable_list and mut_once_list).
271 - for each pointer, evacuate the object it points to into either
273 + to-space of the step given by step->to, which is the next
274 highest step in this generation or the first step in the next
275 generation if this is the last step.
277 + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
278 When we evacuate an object we attempt to evacuate
279 everything it points to into the same generation - this is
280 achieved by setting evac_gen to the desired generation. If
281 we can't do this, then an entry in the mut_once list has to
282 be made for the cross-generation pointer.
284 + if the object is already in a generation > N, then leave
287 - repeatedly scavenge to-space from each step in each generation
288 being collected until no more objects can be evacuated.
290 - free from-space in each step, and set from-space = to-space.
292 Locks held: sched_mutex
294 -------------------------------------------------------------------------- */
297 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
301 lnat live, allocated, collected = 0, copied = 0;
302 lnat oldgen_saved_blocks = 0;
306 CostCentreStack *prev_CCS;
309 #if defined(DEBUG) && defined(GRAN)
310 IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n",
314 #if defined(RTS_USER_SIGNALS)
319 // tell the stats department that we've started a GC
322 // Init stats and print par specific (timing) info
323 PAR_TICKY_PAR_START();
325 // attribute any costs to CCS_GC
331 /* Approximate how much we allocated.
332 * Todo: only when generating stats?
334 allocated = calcAllocated();
336 /* Figure out which generation to collect
338 if (force_major_gc) {
339 N = RtsFlags.GcFlags.generations - 1;
343 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
344 if (generations[g].steps[0].n_blocks +
345 generations[g].steps[0].n_large_blocks
346 >= generations[g].max_blocks) {
350 major_gc = (N == RtsFlags.GcFlags.generations-1);
353 #ifdef RTS_GTK_FRONTPANEL
354 if (RtsFlags.GcFlags.frontpanel) {
355 updateFrontPanelBeforeGC(N);
359 // check stack sanity *before* GC (ToDo: check all threads)
361 // ToDo!: check sanity IF_DEBUG(sanity, checkTSOsSanity());
363 IF_DEBUG(sanity, checkFreeListSanity());
365 /* Initialise the static object lists
367 static_objects = END_OF_STATIC_LIST;
368 scavenged_static_objects = END_OF_STATIC_LIST;
370 /* zero the mutable list for the oldest generation (see comment by
371 * zero_mutable_list below).
374 zero_mutable_list(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
377 /* Save the old to-space if we're doing a two-space collection
379 if (RtsFlags.GcFlags.generations == 1) {
380 old_to_blocks = g0s0->to_blocks;
381 g0s0->to_blocks = NULL;
382 g0s0->n_to_blocks = 0;
385 /* Keep a count of how many new blocks we allocated during this GC
386 * (used for resizing the allocation area, later).
390 // Initialise to-space in all the generations/steps that we're
393 for (g = 0; g <= N; g++) {
394 generations[g].mut_once_list = END_MUT_LIST;
395 generations[g].mut_list = END_MUT_LIST;
397 for (s = 0; s < generations[g].n_steps; s++) {
399 // generation 0, step 0 doesn't need to-space
400 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
404 stp = &generations[g].steps[s];
405 ASSERT(stp->gen_no == g);
407 // start a new to-space for this step.
410 stp->to_blocks = NULL;
412 // allocate the first to-space block; extra blocks will be
413 // chained on as necessary.
414 bd = gc_alloc_block(stp);
416 stp->scan = bd->start;
419 // initialise the large object queues.
420 stp->new_large_objects = NULL;
421 stp->scavenged_large_objects = NULL;
422 stp->n_scavenged_large_blocks = 0;
424 // mark the large objects as not evacuated yet
425 for (bd = stp->large_objects; bd; bd = bd->link) {
426 bd->flags &= ~BF_EVACUATED;
429 // for a compacted step, we need to allocate the bitmap
430 if (stp->is_compacted) {
431 nat bitmap_size; // in bytes
432 bdescr *bitmap_bdescr;
435 bitmap_size = stp->n_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
437 if (bitmap_size > 0) {
438 bitmap_bdescr = allocGroup((nat)BLOCK_ROUND_UP(bitmap_size)
440 stp->bitmap = bitmap_bdescr;
441 bitmap = bitmap_bdescr->start;
443 IF_DEBUG(gc, belch("bitmap_size: %d, bitmap: %p",
444 bitmap_size, bitmap););
446 // don't forget to fill it with zeros!
447 memset(bitmap, 0, bitmap_size);
449 // For each block in this step, point to its bitmap from the
451 for (bd=stp->blocks; bd != NULL; bd = bd->link) {
452 bd->u.bitmap = bitmap;
453 bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
455 // Also at this point we set the BF_COMPACTED flag
456 // for this block. The invariant is that
457 // BF_COMPACTED is always unset, except during GC
458 // when it is set on those blocks which will be
460 bd->flags |= BF_COMPACTED;
467 /* make sure the older generations have at least one block to
468 * allocate into (this makes things easier for copy(), see below).
470 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
471 for (s = 0; s < generations[g].n_steps; s++) {
472 stp = &generations[g].steps[s];
473 if (stp->hp_bd == NULL) {
474 ASSERT(stp->blocks == NULL);
475 bd = gc_alloc_block(stp);
479 /* Set the scan pointer for older generations: remember we
480 * still have to scavenge objects that have been promoted. */
482 stp->scan_bd = stp->hp_bd;
483 stp->to_blocks = NULL;
484 stp->n_to_blocks = 0;
485 stp->new_large_objects = NULL;
486 stp->scavenged_large_objects = NULL;
487 stp->n_scavenged_large_blocks = 0;
491 /* Allocate a mark stack if we're doing a major collection.
494 mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
495 mark_stack = (StgPtr *)mark_stack_bdescr->start;
496 mark_sp = mark_stack;
497 mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
499 mark_stack_bdescr = NULL;
502 /* -----------------------------------------------------------------------
503 * follow all the roots that we know about:
504 * - mutable lists from each generation > N
505 * we want to *scavenge* these roots, not evacuate them: they're not
506 * going to move in this GC.
507 * Also: do them in reverse generation order. This is because we
508 * often want to promote objects that are pointed to by older
509 * generations early, so we don't have to repeatedly copy them.
510 * Doing the generations in reverse order ensures that we don't end
511 * up in the situation where we want to evac an object to gen 3 and
512 * it has already been evaced to gen 2.
516 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
517 generations[g].saved_mut_list = generations[g].mut_list;
518 generations[g].mut_list = END_MUT_LIST;
521 // Do the mut-once lists first
522 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
523 IF_PAR_DEBUG(verbose,
524 printMutOnceList(&generations[g]));
525 scavenge_mut_once_list(&generations[g]);
527 for (st = generations[g].n_steps-1; st >= 0; st--) {
528 scavenge(&generations[g].steps[st]);
532 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
533 IF_PAR_DEBUG(verbose,
534 printMutableList(&generations[g]));
535 scavenge_mutable_list(&generations[g]);
537 for (st = generations[g].n_steps-1; st >= 0; st--) {
538 scavenge(&generations[g].steps[st]);
543 /* follow roots from the CAF list (used by GHCi)
548 /* follow all the roots that the application knows about.
551 get_roots(mark_root);
554 /* And don't forget to mark the TSO if we got here direct from
556 /* Not needed in a seq version?
558 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
562 // Mark the entries in the GALA table of the parallel system
563 markLocalGAs(major_gc);
564 // Mark all entries on the list of pending fetches
565 markPendingFetches(major_gc);
568 /* Mark the weak pointer list, and prepare to detect dead weak
571 mark_weak_ptr_list(&weak_ptr_list);
572 old_weak_ptr_list = weak_ptr_list;
573 weak_ptr_list = NULL;
574 weak_stage = WeakPtrs;
576 /* The all_threads list is like the weak_ptr_list.
577 * See traverse_weak_ptr_list() for the details.
579 old_all_threads = all_threads;
580 all_threads = END_TSO_QUEUE;
581 resurrected_threads = END_TSO_QUEUE;
583 /* Mark the stable pointer table.
585 markStablePtrTable(mark_root);
587 /* -------------------------------------------------------------------------
588 * Repeatedly scavenge all the areas we know about until there's no
589 * more scavenging to be done.
596 // scavenge static objects
597 if (major_gc && static_objects != END_OF_STATIC_LIST) {
598 IF_DEBUG(sanity, checkStaticObjects(static_objects));
602 /* When scavenging the older generations: Objects may have been
603 * evacuated from generations <= N into older generations, and we
604 * need to scavenge these objects. We're going to try to ensure that
605 * any evacuations that occur move the objects into at least the
606 * same generation as the object being scavenged, otherwise we
607 * have to create new entries on the mutable list for the older
611 // scavenge each step in generations 0..maxgen
617 // scavenge objects in compacted generation
618 if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
619 (mark_stack_bdescr != NULL && !mark_stack_empty())) {
620 scavenge_mark_stack();
624 for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
625 for (st = generations[gen].n_steps; --st >= 0; ) {
626 if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
629 stp = &generations[gen].steps[st];
631 if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
636 if (stp->new_large_objects != NULL) {
645 if (flag) { goto loop; }
647 // must be last... invariant is that everything is fully
648 // scavenged at this point.
649 if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something
654 /* Update the pointers from the "main thread" list - these are
655 * treated as weak pointers because we want to allow a main thread
656 * to get a BlockedOnDeadMVar exception in the same way as any other
657 * thread. Note that the threads should all have been retained by
658 * GC by virtue of being on the all_threads list, we're just
659 * updating pointers here.
664 for (m = main_threads; m != NULL; m = m->link) {
665 tso = (StgTSO *) isAlive((StgClosure *)m->tso);
667 barf("main thread has been GC'd");
674 // Reconstruct the Global Address tables used in GUM
675 rebuildGAtables(major_gc);
676 IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
679 // Now see which stable names are still alive.
682 // Tidy the end of the to-space chains
683 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
684 for (s = 0; s < generations[g].n_steps; s++) {
685 stp = &generations[g].steps[s];
686 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
687 ASSERT(Bdescr(stp->hp) == stp->hp_bd);
688 stp->hp_bd->free = stp->hp;
694 // We call processHeapClosureForDead() on every closure destroyed during
695 // the current garbage collection, so we invoke LdvCensusForDead().
696 if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
697 || RtsFlags.ProfFlags.bioSelector != NULL)
701 // NO MORE EVACUATION AFTER THIS POINT!
702 // Finally: compaction of the oldest generation.
703 if (major_gc && oldest_gen->steps[0].is_compacted) {
704 // save number of blocks for stats
705 oldgen_saved_blocks = oldest_gen->steps[0].n_blocks;
709 IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
711 /* run through all the generations/steps and tidy up
713 copied = new_blocks * BLOCK_SIZE_W;
714 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
717 generations[g].collections++; // for stats
720 for (s = 0; s < generations[g].n_steps; s++) {
722 stp = &generations[g].steps[s];
724 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
725 // stats information: how much we copied
727 copied -= stp->hp_bd->start + BLOCK_SIZE_W -
732 // for generations we collected...
735 // rough calculation of garbage collected, for stats output
736 if (stp->is_compacted) {
737 collected += (oldgen_saved_blocks - stp->n_blocks) * BLOCK_SIZE_W;
739 collected += stp->n_blocks * BLOCK_SIZE_W;
742 /* free old memory and shift to-space into from-space for all
743 * the collected steps (except the allocation area). These
744 * freed blocks will probaby be quickly recycled.
746 if (!(g == 0 && s == 0)) {
747 if (stp->is_compacted) {
748 // for a compacted step, just shift the new to-space
749 // onto the front of the now-compacted existing blocks.
750 for (bd = stp->to_blocks; bd != NULL; bd = bd->link) {
751 bd->flags &= ~BF_EVACUATED; // now from-space
753 // tack the new blocks on the end of the existing blocks
754 if (stp->blocks == NULL) {
755 stp->blocks = stp->to_blocks;
757 for (bd = stp->blocks; bd != NULL; bd = next) {
760 bd->link = stp->to_blocks;
762 // NB. this step might not be compacted next
763 // time, so reset the BF_COMPACTED flags.
764 // They are set before GC if we're going to
765 // compact. (search for BF_COMPACTED above).
766 bd->flags &= ~BF_COMPACTED;
769 // add the new blocks to the block tally
770 stp->n_blocks += stp->n_to_blocks;
772 freeChain(stp->blocks);
773 stp->blocks = stp->to_blocks;
774 stp->n_blocks = stp->n_to_blocks;
775 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
776 bd->flags &= ~BF_EVACUATED; // now from-space
779 stp->to_blocks = NULL;
780 stp->n_to_blocks = 0;
783 /* LARGE OBJECTS. The current live large objects are chained on
784 * scavenged_large, having been moved during garbage
785 * collection from large_objects. Any objects left on
786 * large_objects list are therefore dead, so we free them here.
788 for (bd = stp->large_objects; bd != NULL; bd = next) {
794 // update the count of blocks used by large objects
795 for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
796 bd->flags &= ~BF_EVACUATED;
798 stp->large_objects = stp->scavenged_large_objects;
799 stp->n_large_blocks = stp->n_scavenged_large_blocks;
802 // for older generations...
804 /* For older generations, we need to append the
805 * scavenged_large_object list (i.e. large objects that have been
806 * promoted during this GC) to the large_object list for that step.
808 for (bd = stp->scavenged_large_objects; bd; bd = next) {
810 bd->flags &= ~BF_EVACUATED;
811 dbl_link_onto(bd, &stp->large_objects);
814 // add the new blocks we promoted during this GC
815 stp->n_blocks += stp->n_to_blocks;
816 stp->n_to_blocks = 0;
817 stp->n_large_blocks += stp->n_scavenged_large_blocks;
822 /* Reset the sizes of the older generations when we do a major
825 * CURRENT STRATEGY: make all generations except zero the same size.
826 * We have to stay within the maximum heap size, and leave a certain
827 * percentage of the maximum heap size available to allocate into.
829 if (major_gc && RtsFlags.GcFlags.generations > 1) {
830 nat live, size, min_alloc;
831 nat max = RtsFlags.GcFlags.maxHeapSize;
832 nat gens = RtsFlags.GcFlags.generations;
834 // live in the oldest generations
835 live = oldest_gen->steps[0].n_blocks +
836 oldest_gen->steps[0].n_large_blocks;
838 // default max size for all generations except zero
839 size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
840 RtsFlags.GcFlags.minOldGenSize);
842 // minimum size for generation zero
843 min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
844 RtsFlags.GcFlags.minAllocAreaSize);
846 // Auto-enable compaction when the residency reaches a
847 // certain percentage of the maximum heap size (default: 30%).
848 if (RtsFlags.GcFlags.generations > 1 &&
849 (RtsFlags.GcFlags.compact ||
851 oldest_gen->steps[0].n_blocks >
852 (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
853 oldest_gen->steps[0].is_compacted = 1;
854 // fprintf(stderr,"compaction: on\n", live);
856 oldest_gen->steps[0].is_compacted = 0;
857 // fprintf(stderr,"compaction: off\n", live);
860 // if we're going to go over the maximum heap size, reduce the
861 // size of the generations accordingly. The calculation is
862 // different if compaction is turned on, because we don't need
863 // to double the space required to collect the old generation.
866 // this test is necessary to ensure that the calculations
867 // below don't have any negative results - we're working
868 // with unsigned values here.
869 if (max < min_alloc) {
873 if (oldest_gen->steps[0].is_compacted) {
874 if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
875 size = (max - min_alloc) / ((gens - 1) * 2 - 1);
878 if ( (size * (gens - 1) * 2) + min_alloc > max ) {
879 size = (max - min_alloc) / ((gens - 1) * 2);
889 fprintf(stderr,"live: %d, min_alloc: %d, size : %d, max = %d\n", live,
890 min_alloc, size, max);
893 for (g = 0; g < gens; g++) {
894 generations[g].max_blocks = size;
898 // Guess the amount of live data for stats.
901 /* Free the small objects allocated via allocate(), since this will
902 * all have been copied into G0S1 now.
904 if (small_alloc_list != NULL) {
905 freeChain(small_alloc_list);
907 small_alloc_list = NULL;
911 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
913 // Start a new pinned_object_block
914 pinned_object_block = NULL;
916 /* Free the mark stack.
918 if (mark_stack_bdescr != NULL) {
919 freeGroup(mark_stack_bdescr);
924 for (g = 0; g <= N; g++) {
925 for (s = 0; s < generations[g].n_steps; s++) {
926 stp = &generations[g].steps[s];
927 if (stp->is_compacted && stp->bitmap != NULL) {
928 freeGroup(stp->bitmap);
933 /* Two-space collector:
934 * Free the old to-space, and estimate the amount of live data.
936 if (RtsFlags.GcFlags.generations == 1) {
939 if (old_to_blocks != NULL) {
940 freeChain(old_to_blocks);
942 for (bd = g0s0->to_blocks; bd != NULL; bd = bd->link) {
943 bd->flags = 0; // now from-space
946 /* For a two-space collector, we need to resize the nursery. */
948 /* set up a new nursery. Allocate a nursery size based on a
949 * function of the amount of live data (by default a factor of 2)
950 * Use the blocks from the old nursery if possible, freeing up any
953 * If we get near the maximum heap size, then adjust our nursery
954 * size accordingly. If the nursery is the same size as the live
955 * data (L), then we need 3L bytes. We can reduce the size of the
956 * nursery to bring the required memory down near 2L bytes.
958 * A normal 2-space collector would need 4L bytes to give the same
959 * performance we get from 3L bytes, reducing to the same
960 * performance at 2L bytes.
962 blocks = g0s0->n_to_blocks;
964 if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
965 blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
966 RtsFlags.GcFlags.maxHeapSize ) {
967 long adjusted_blocks; // signed on purpose
970 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
971 IF_DEBUG(gc, belch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
972 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
973 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
976 blocks = adjusted_blocks;
979 blocks *= RtsFlags.GcFlags.oldGenFactor;
980 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
981 blocks = RtsFlags.GcFlags.minAllocAreaSize;
984 resizeNursery(blocks);
987 /* Generational collector:
988 * If the user has given us a suggested heap size, adjust our
989 * allocation area to make best use of the memory available.
992 if (RtsFlags.GcFlags.heapSizeSuggestion) {
994 nat needed = calcNeeded(); // approx blocks needed at next GC
996 /* Guess how much will be live in generation 0 step 0 next time.
997 * A good approximation is obtained by finding the
998 * percentage of g0s0 that was live at the last minor GC.
1001 g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
1004 /* Estimate a size for the allocation area based on the
1005 * information available. We might end up going slightly under
1006 * or over the suggested heap size, but we should be pretty
1009 * Formula: suggested - needed
1010 * ----------------------------
1011 * 1 + g0s0_pcnt_kept/100
1013 * where 'needed' is the amount of memory needed at the next
1014 * collection for collecting all steps except g0s0.
1017 (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
1018 (100 + (long)g0s0_pcnt_kept);
1020 if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
1021 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1024 resizeNursery((nat)blocks);
1027 // we might have added extra large blocks to the nursery, so
1028 // resize back to minAllocAreaSize again.
1029 resizeNursery(RtsFlags.GcFlags.minAllocAreaSize);
1033 // mark the garbage collected CAFs as dead
1034 #if 0 && defined(DEBUG) // doesn't work at the moment
1035 if (major_gc) { gcCAFs(); }
1039 // resetStaticObjectForRetainerProfiling() must be called before
1041 resetStaticObjectForRetainerProfiling();
1044 // zero the scavenged static object list
1046 zero_static_object_list(scavenged_static_objects);
1049 // Reset the nursery
1052 RELEASE_LOCK(&sched_mutex);
1054 // start any pending finalizers
1055 scheduleFinalizers(old_weak_ptr_list);
1057 // send exceptions to any threads which were about to die
1058 resurrectThreads(resurrected_threads);
1060 ACQUIRE_LOCK(&sched_mutex);
1062 // Update the stable pointer hash table.
1063 updateStablePtrTable(major_gc);
1065 // check sanity after GC
1066 IF_DEBUG(sanity, checkSanity());
1068 // extra GC trace info
1069 IF_DEBUG(gc, statDescribeGens());
1072 // symbol-table based profiling
1073 /* heapCensus(to_blocks); */ /* ToDo */
1076 // restore enclosing cost centre
1081 // check for memory leaks if sanity checking is on
1082 IF_DEBUG(sanity, memInventory());
1084 #ifdef RTS_GTK_FRONTPANEL
1085 if (RtsFlags.GcFlags.frontpanel) {
1086 updateFrontPanelAfterGC( N, live );
1090 // ok, GC over: tell the stats department what happened.
1091 stat_endGC(allocated, collected, live, copied, N);
1093 #if defined(RTS_USER_SIGNALS)
1094 // unblock signals again
1095 unblockUserSignals();
1102 /* -----------------------------------------------------------------------------
1105 traverse_weak_ptr_list is called possibly many times during garbage
1106 collection. It returns a flag indicating whether it did any work
1107 (i.e. called evacuate on any live pointers).
1109 Invariant: traverse_weak_ptr_list is called when the heap is in an
1110 idempotent state. That means that there are no pending
1111 evacuate/scavenge operations. This invariant helps the weak
1112 pointer code decide which weak pointers are dead - if there are no
1113 new live weak pointers, then all the currently unreachable ones are
1116 For generational GC: we just don't try to finalize weak pointers in
1117 older generations than the one we're collecting. This could
1118 probably be optimised by keeping per-generation lists of weak
1119 pointers, but for a few weak pointers this scheme will work.
1121 There are three distinct stages to processing weak pointers:
1123 - weak_stage == WeakPtrs
1125 We process all the weak pointers whos keys are alive (evacuate
1126 their values and finalizers), and repeat until we can find no new
1127 live keys. If no live keys are found in this pass, then we
1128 evacuate the finalizers of all the dead weak pointers in order to
1131 - weak_stage == WeakThreads
1133 Now, we discover which *threads* are still alive. Pointers to
1134 threads from the all_threads and main thread lists are the
1135 weakest of all: a pointers from the finalizer of a dead weak
1136 pointer can keep a thread alive. Any threads found to be unreachable
1137 are evacuated and placed on the resurrected_threads list so we
1138 can send them a signal later.
1140 - weak_stage == WeakDone
1142 No more evacuation is done.
1144 -------------------------------------------------------------------------- */
1147 traverse_weak_ptr_list(void)
1149 StgWeak *w, **last_w, *next_w;
1151 rtsBool flag = rtsFalse;
1153 switch (weak_stage) {
1159 /* doesn't matter where we evacuate values/finalizers to, since
1160 * these pointers are treated as roots (iff the keys are alive).
1164 last_w = &old_weak_ptr_list;
1165 for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1167 /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1168 * called on a live weak pointer object. Just remove it.
1170 if (w->header.info == &stg_DEAD_WEAK_info) {
1171 next_w = ((StgDeadWeak *)w)->link;
1176 switch (get_itbl(w)->type) {
1179 next_w = (StgWeak *)((StgEvacuated *)w)->evacuee;
1184 /* Now, check whether the key is reachable.
1186 new = isAlive(w->key);
1189 // evacuate the value and finalizer
1190 w->value = evacuate(w->value);
1191 w->finalizer = evacuate(w->finalizer);
1192 // remove this weak ptr from the old_weak_ptr list
1194 // and put it on the new weak ptr list
1196 w->link = weak_ptr_list;
1199 IF_DEBUG(weak, belch("Weak pointer still alive at %p -> %p",
1204 last_w = &(w->link);
1210 barf("traverse_weak_ptr_list: not WEAK");
1214 /* If we didn't make any changes, then we can go round and kill all
1215 * the dead weak pointers. The old_weak_ptr list is used as a list
1216 * of pending finalizers later on.
1218 if (flag == rtsFalse) {
1219 for (w = old_weak_ptr_list; w; w = w->link) {
1220 w->finalizer = evacuate(w->finalizer);
1223 // Next, move to the WeakThreads stage after fully
1224 // scavenging the finalizers we've just evacuated.
1225 weak_stage = WeakThreads;
1231 /* Now deal with the all_threads list, which behaves somewhat like
1232 * the weak ptr list. If we discover any threads that are about to
1233 * become garbage, we wake them up and administer an exception.
1236 StgTSO *t, *tmp, *next, **prev;
1238 prev = &old_all_threads;
1239 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1241 (StgClosure *)tmp = isAlive((StgClosure *)t);
1247 ASSERT(get_itbl(t)->type == TSO);
1248 switch (t->what_next) {
1249 case ThreadRelocated:
1254 case ThreadComplete:
1255 // finshed or died. The thread might still be alive, but we
1256 // don't keep it on the all_threads list. Don't forget to
1257 // stub out its global_link field.
1258 next = t->global_link;
1259 t->global_link = END_TSO_QUEUE;
1267 // not alive (yet): leave this thread on the
1268 // old_all_threads list.
1269 prev = &(t->global_link);
1270 next = t->global_link;
1273 // alive: move this thread onto the all_threads list.
1274 next = t->global_link;
1275 t->global_link = all_threads;
1282 /* And resurrect any threads which were about to become garbage.
1285 StgTSO *t, *tmp, *next;
1286 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1287 next = t->global_link;
1288 (StgClosure *)tmp = evacuate((StgClosure *)t);
1289 tmp->global_link = resurrected_threads;
1290 resurrected_threads = tmp;
1294 weak_stage = WeakDone; // *now* we're done,
1295 return rtsTrue; // but one more round of scavenging, please
1298 barf("traverse_weak_ptr_list");
1304 /* -----------------------------------------------------------------------------
1305 After GC, the live weak pointer list may have forwarding pointers
1306 on it, because a weak pointer object was evacuated after being
1307 moved to the live weak pointer list. We remove those forwarding
1310 Also, we don't consider weak pointer objects to be reachable, but
1311 we must nevertheless consider them to be "live" and retain them.
1312 Therefore any weak pointer objects which haven't as yet been
1313 evacuated need to be evacuated now.
1314 -------------------------------------------------------------------------- */
1318 mark_weak_ptr_list ( StgWeak **list )
1320 StgWeak *w, **last_w;
1323 for (w = *list; w; w = w->link) {
1324 // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
1325 ASSERT(w->header.info == &stg_DEAD_WEAK_info
1326 || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
1327 (StgClosure *)w = evacuate((StgClosure *)w);
1329 last_w = &(w->link);
1333 /* -----------------------------------------------------------------------------
1334 isAlive determines whether the given closure is still alive (after
1335 a garbage collection) or not. It returns the new address of the
1336 closure if it is alive, or NULL otherwise.
1338 NOTE: Use it before compaction only!
1339 -------------------------------------------------------------------------- */
1343 isAlive(StgClosure *p)
1345 const StgInfoTable *info;
1350 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1353 // ignore static closures
1355 // ToDo: for static closures, check the static link field.
1356 // Problem here is that we sometimes don't set the link field, eg.
1357 // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1359 if (!HEAP_ALLOCED(p)) {
1363 // ignore closures in generations that we're not collecting.
1365 if (bd->gen_no > N) {
1369 // if it's a pointer into to-space, then we're done
1370 if (bd->flags & BF_EVACUATED) {
1374 // large objects use the evacuated flag
1375 if (bd->flags & BF_LARGE) {
1379 // check the mark bit for compacted steps
1380 if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1384 switch (info->type) {
1389 case IND_OLDGEN: // rely on compatible layout with StgInd
1390 case IND_OLDGEN_PERM:
1391 // follow indirections
1392 p = ((StgInd *)p)->indirectee;
1397 return ((StgEvacuated *)p)->evacuee;
1400 if (((StgTSO *)p)->what_next == ThreadRelocated) {
1401 p = (StgClosure *)((StgTSO *)p)->link;
1414 mark_root(StgClosure **root)
1416 *root = evacuate(*root);
1420 upd_evacuee(StgClosure *p, StgClosure *dest)
1422 // Source object must be in from-space:
1423 ASSERT((Bdescr((P_)p)->flags & BF_EVACUATED) == 0);
1424 // not true: (ToDo: perhaps it should be)
1425 // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
1426 SET_INFO(p, &stg_EVACUATED_info);
1427 ((StgEvacuated *)p)->evacuee = dest;
1431 STATIC_INLINE StgClosure *
1432 copy(StgClosure *src, nat size, step *stp)
1437 nat size_org = size;
1440 TICK_GC_WORDS_COPIED(size);
1441 /* Find out where we're going, using the handy "to" pointer in
1442 * the step of the source object. If it turns out we need to
1443 * evacuate to an older generation, adjust it here (see comment
1446 if (stp->gen_no < evac_gen) {
1447 #ifdef NO_EAGER_PROMOTION
1448 failed_to_evac = rtsTrue;
1450 stp = &generations[evac_gen].steps[0];
1454 /* chain a new block onto the to-space for the destination step if
1457 if (stp->hp + size >= stp->hpLim) {
1458 gc_alloc_block(stp);
1461 for(to = stp->hp, from = (P_)src; size>0; --size) {
1467 upd_evacuee(src,(StgClosure *)dest);
1469 // We store the size of the just evacuated object in the LDV word so that
1470 // the profiler can guess the position of the next object later.
1471 SET_EVACUAEE_FOR_LDV(src, size_org);
1473 return (StgClosure *)dest;
1476 /* Special version of copy() for when we only want to copy the info
1477 * pointer of an object, but reserve some padding after it. This is
1478 * used to optimise evacuation of BLACKHOLEs.
1483 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1488 nat size_to_copy_org = size_to_copy;
1491 TICK_GC_WORDS_COPIED(size_to_copy);
1492 if (stp->gen_no < evac_gen) {
1493 #ifdef NO_EAGER_PROMOTION
1494 failed_to_evac = rtsTrue;
1496 stp = &generations[evac_gen].steps[0];
1500 if (stp->hp + size_to_reserve >= stp->hpLim) {
1501 gc_alloc_block(stp);
1504 for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1509 stp->hp += size_to_reserve;
1510 upd_evacuee(src,(StgClosure *)dest);
1512 // We store the size of the just evacuated object in the LDV word so that
1513 // the profiler can guess the position of the next object later.
1514 // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1516 SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1518 if (size_to_reserve - size_to_copy_org > 0)
1519 FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1521 return (StgClosure *)dest;
1525 /* -----------------------------------------------------------------------------
1526 Evacuate a large object
1528 This just consists of removing the object from the (doubly-linked)
1529 step->large_objects list, and linking it on to the (singly-linked)
1530 step->new_large_objects list, from where it will be scavenged later.
1532 Convention: bd->flags has BF_EVACUATED set for a large object
1533 that has been evacuated, or unset otherwise.
1534 -------------------------------------------------------------------------- */
1538 evacuate_large(StgPtr p)
1540 bdescr *bd = Bdescr(p);
1543 // object must be at the beginning of the block (or be a ByteArray)
1544 ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1545 (((W_)p & BLOCK_MASK) == 0));
1547 // already evacuated?
1548 if (bd->flags & BF_EVACUATED) {
1549 /* Don't forget to set the failed_to_evac flag if we didn't get
1550 * the desired destination (see comments in evacuate()).
1552 if (bd->gen_no < evac_gen) {
1553 failed_to_evac = rtsTrue;
1554 TICK_GC_FAILED_PROMOTION();
1560 // remove from large_object list
1562 bd->u.back->link = bd->link;
1563 } else { // first object in the list
1564 stp->large_objects = bd->link;
1567 bd->link->u.back = bd->u.back;
1570 /* link it on to the evacuated large object list of the destination step
1573 if (stp->gen_no < evac_gen) {
1574 #ifdef NO_EAGER_PROMOTION
1575 failed_to_evac = rtsTrue;
1577 stp = &generations[evac_gen].steps[0];
1582 bd->gen_no = stp->gen_no;
1583 bd->link = stp->new_large_objects;
1584 stp->new_large_objects = bd;
1585 bd->flags |= BF_EVACUATED;
1588 /* -----------------------------------------------------------------------------
1589 Adding a MUT_CONS to an older generation.
1591 This is necessary from time to time when we end up with an
1592 old-to-new generation pointer in a non-mutable object. We defer
1593 the promotion until the next GC.
1594 -------------------------------------------------------------------------- */
1597 mkMutCons(StgClosure *ptr, generation *gen)
1602 stp = &gen->steps[0];
1604 /* chain a new block onto the to-space for the destination step if
1607 if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
1608 gc_alloc_block(stp);
1611 q = (StgMutVar *)stp->hp;
1612 stp->hp += sizeofW(StgMutVar);
1614 SET_HDR(q,&stg_MUT_CONS_info,CCS_GC);
1616 recordOldToNewPtrs((StgMutClosure *)q);
1618 return (StgClosure *)q;
1621 /* -----------------------------------------------------------------------------
1624 This is called (eventually) for every live object in the system.
1626 The caller to evacuate specifies a desired generation in the
1627 evac_gen global variable. The following conditions apply to
1628 evacuating an object which resides in generation M when we're
1629 collecting up to generation N
1633 else evac to step->to
1635 if M < evac_gen evac to evac_gen, step 0
1637 if the object is already evacuated, then we check which generation
1640 if M >= evac_gen do nothing
1641 if M < evac_gen set failed_to_evac flag to indicate that we
1642 didn't manage to evacuate this object into evac_gen.
1647 evacuate() is the single most important function performance-wise
1648 in the GC. Various things have been tried to speed it up, but as
1649 far as I can tell the code generated by gcc 3.2 with -O2 is about
1650 as good as it's going to get. We pass the argument to evacuate()
1651 in a register using the 'regparm' attribute (see the prototype for
1652 evacuate() near the top of this file).
1654 Changing evacuate() to take an (StgClosure **) rather than
1655 returning the new pointer seems attractive, because we can avoid
1656 writing back the pointer when it hasn't changed (eg. for a static
1657 object, or an object in a generation > N). However, I tried it and
1658 it doesn't help. One reason is that the (StgClosure **) pointer
1659 gets spilled to the stack inside evacuate(), resulting in far more
1660 extra reads/writes than we save.
1661 -------------------------------------------------------------------------- */
1663 REGPARM1 static StgClosure *
1664 evacuate(StgClosure *q)
1669 const StgInfoTable *info;
1672 if (HEAP_ALLOCED(q)) {
1675 if (bd->gen_no > N) {
1676 /* Can't evacuate this object, because it's in a generation
1677 * older than the ones we're collecting. Let's hope that it's
1678 * in evac_gen or older, or we will have to arrange to track
1679 * this pointer using the mutable list.
1681 if (bd->gen_no < evac_gen) {
1683 failed_to_evac = rtsTrue;
1684 TICK_GC_FAILED_PROMOTION();
1689 /* evacuate large objects by re-linking them onto a different list.
1691 if (bd->flags & BF_LARGE) {
1693 if (info->type == TSO &&
1694 ((StgTSO *)q)->what_next == ThreadRelocated) {
1695 q = (StgClosure *)((StgTSO *)q)->link;
1698 evacuate_large((P_)q);
1702 /* If the object is in a step that we're compacting, then we
1703 * need to use an alternative evacuate procedure.
1705 if (bd->flags & BF_COMPACTED) {
1706 if (!is_marked((P_)q,bd)) {
1708 if (mark_stack_full()) {
1709 mark_stack_overflowed = rtsTrue;
1712 push_mark_stack((P_)q);
1720 else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1723 // make sure the info pointer is into text space
1724 ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
1727 switch (info -> type) {
1731 return copy(q,sizeW_fromITBL(info),stp);
1735 StgWord w = (StgWord)q->payload[0];
1736 if (q->header.info == Czh_con_info &&
1737 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
1738 (StgChar)w <= MAX_CHARLIKE) {
1739 return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1741 if (q->header.info == Izh_con_info &&
1742 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1743 return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1745 // else, fall through ...
1751 return copy(q,sizeofW(StgHeader)+1,stp);
1753 case THUNK_1_0: // here because of MIN_UPD_SIZE
1758 #ifdef NO_PROMOTE_THUNKS
1759 if (bd->gen_no == 0 &&
1760 bd->step->no != 0 &&
1761 bd->step->no == generations[bd->gen_no].n_steps-1) {
1765 return copy(q,sizeofW(StgHeader)+2,stp);
1773 return copy(q,sizeofW(StgHeader)+2,stp);
1779 case IND_OLDGEN_PERM:
1783 return copy(q,sizeW_fromITBL(info),stp);
1786 return copy(q,bco_sizeW((StgBCO *)q),stp);
1789 case SE_CAF_BLACKHOLE:
1792 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1795 to = copy(q,BLACKHOLE_sizeW(),stp);
1798 case THUNK_SELECTOR:
1802 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
1803 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1806 p = eval_thunk_selector(info->layout.selector_offset,
1810 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1812 // q is still BLACKHOLE'd.
1813 thunk_selector_depth++;
1815 thunk_selector_depth--;
1818 // We store the size of the just evacuated object in the
1819 // LDV word so that the profiler can guess the position of
1820 // the next object later.
1821 SET_EVACUAEE_FOR_LDV(q, THUNK_SELECTOR_sizeW());
1829 // follow chains of indirections, don't evacuate them
1830 q = ((StgInd*)q)->indirectee;
1834 if (info->srt_bitmap != 0 && major_gc &&
1835 THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1836 THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1837 static_objects = (StgClosure *)q;
1842 if (info->srt_bitmap != 0 && major_gc &&
1843 FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1844 FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1845 static_objects = (StgClosure *)q;
1850 /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1851 * on the CAF list, so don't do anything with it here (we'll
1852 * scavenge it later).
1855 && ((StgIndStatic *)q)->saved_info == NULL
1856 && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1857 IND_STATIC_LINK((StgClosure *)q) = static_objects;
1858 static_objects = (StgClosure *)q;
1863 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1864 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1865 static_objects = (StgClosure *)q;
1869 case CONSTR_INTLIKE:
1870 case CONSTR_CHARLIKE:
1871 case CONSTR_NOCAF_STATIC:
1872 /* no need to put these on the static linked list, they don't need
1886 // shouldn't see these
1887 barf("evacuate: stack frame at %p\n", q);
1891 return copy(q,pap_sizeW((StgPAP*)q),stp);
1894 return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
1897 /* Already evacuated, just return the forwarding address.
1898 * HOWEVER: if the requested destination generation (evac_gen) is
1899 * older than the actual generation (because the object was
1900 * already evacuated to a younger generation) then we have to
1901 * set the failed_to_evac flag to indicate that we couldn't
1902 * manage to promote the object to the desired generation.
1904 if (evac_gen > 0) { // optimisation
1905 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1906 if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
1907 failed_to_evac = rtsTrue;
1908 TICK_GC_FAILED_PROMOTION();
1911 return ((StgEvacuated*)q)->evacuee;
1914 // just copy the block
1915 return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1918 case MUT_ARR_PTRS_FROZEN:
1919 // just copy the block
1920 return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1924 StgTSO *tso = (StgTSO *)q;
1926 /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1928 if (tso->what_next == ThreadRelocated) {
1929 q = (StgClosure *)tso->link;
1933 /* To evacuate a small TSO, we need to relocate the update frame
1940 new_tso = (StgTSO *)copyPart((StgClosure *)tso,
1942 sizeofW(StgTSO), stp);
1943 move_TSO(tso, new_tso);
1944 for (p = tso->sp, q = new_tso->sp;
1945 p < tso->stack+tso->stack_size;) {
1949 return (StgClosure *)new_tso;
1954 case RBH: // cf. BLACKHOLE_BQ
1956 //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1957 to = copy(q,BLACKHOLE_sizeW(),stp);
1958 //ToDo: derive size etc from reverted IP
1959 //to = copy(q,size,stp);
1961 belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1962 q, info_type(q), to, info_type(to)));
1967 ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1968 to = copy(q,sizeofW(StgBlockedFetch),stp);
1970 belch("@@ evacuate: %p (%s) to %p (%s)",
1971 q, info_type(q), to, info_type(to)));
1978 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1979 to = copy(q,sizeofW(StgFetchMe),stp);
1981 belch("@@ evacuate: %p (%s) to %p (%s)",
1982 q, info_type(q), to, info_type(to)));
1986 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1987 to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1989 belch("@@ evacuate: %p (%s) to %p (%s)",
1990 q, info_type(q), to, info_type(to)));
1995 barf("evacuate: strange closure type %d", (int)(info->type));
2001 /* -----------------------------------------------------------------------------
2002 Evaluate a THUNK_SELECTOR if possible.
2004 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2005 a closure pointer if we evaluated it and this is the result. Note
2006 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2007 reducing it to HNF, just that we have eliminated the selection.
2008 The result might be another thunk, or even another THUNK_SELECTOR.
2010 If the return value is non-NULL, the original selector thunk has
2011 been BLACKHOLE'd, and should be updated with an indirection or a
2012 forwarding pointer. If the return value is NULL, then the selector
2014 -------------------------------------------------------------------------- */
2016 static inline rtsBool
2017 is_to_space ( StgClosure *p )
2021 bd = Bdescr((StgPtr)p);
2022 if (HEAP_ALLOCED(p) &&
2023 ((bd->flags & BF_EVACUATED)
2024 || ((bd->flags & BF_COMPACTED) &&
2025 is_marked((P_)p,bd)))) {
2033 eval_thunk_selector( nat field, StgSelector * p )
2036 const StgInfoTable *info_ptr;
2037 StgClosure *selectee;
2039 selectee = p->selectee;
2041 // Save the real info pointer (NOTE: not the same as get_itbl()).
2042 info_ptr = p->header.info;
2044 // If the THUNK_SELECTOR is in a generation that we are not
2045 // collecting, then bail out early. We won't be able to save any
2046 // space in any case, and updating with an indirection is trickier
2048 if (Bdescr((StgPtr)p)->gen_no > N) {
2052 // BLACKHOLE the selector thunk, since it is now under evaluation.
2053 // This is important to stop us going into an infinite loop if
2054 // this selector thunk eventually refers to itself.
2055 SET_INFO(p,&stg_BLACKHOLE_info);
2059 // We don't want to end up in to-space, because this causes
2060 // problems when the GC later tries to evacuate the result of
2061 // eval_thunk_selector(). There are various ways this could
2064 // 1. following an IND_STATIC
2066 // 2. when the old generation is compacted, the mark phase updates
2067 // from-space pointers to be to-space pointers, and we can't
2068 // reliably tell which we're following (eg. from an IND_STATIC).
2070 // 3. compacting GC again: if we're looking at a constructor in
2071 // the compacted generation, it might point directly to objects
2072 // in to-space. We must bale out here, otherwise doing the selection
2073 // will result in a to-space pointer being returned.
2075 // (1) is dealt with using a BF_EVACUATED test on the
2076 // selectee. (2) and (3): we can tell if we're looking at an
2077 // object in the compacted generation that might point to
2078 // to-space objects by testing that (a) it is BF_COMPACTED, (b)
2079 // the compacted generation is being collected, and (c) the
2080 // object is marked. Only a marked object may have pointers that
2081 // point to to-space objects, because that happens when
2084 // The to-space test is now embodied in the in_to_space() inline
2085 // function, as it is re-used below.
2087 if (is_to_space(selectee)) {
2091 info = get_itbl(selectee);
2092 switch (info->type) {
2100 case CONSTR_NOCAF_STATIC:
2101 // check that the size is in range
2102 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
2103 info->layout.payload.nptrs));
2105 // Select the right field from the constructor, and check
2106 // that the result isn't in to-space. It might be in
2107 // to-space if, for example, this constructor contains
2108 // pointers to younger-gen objects (and is on the mut-once
2113 q = selectee->payload[field];
2114 if (is_to_space(q)) {
2124 case IND_OLDGEN_PERM:
2126 selectee = ((StgInd *)selectee)->indirectee;
2130 // We don't follow pointers into to-space; the constructor
2131 // has already been evacuated, so we won't save any space
2132 // leaks by evaluating this selector thunk anyhow.
2135 case THUNK_SELECTOR:
2139 // check that we don't recurse too much, re-using the
2140 // depth bound also used in evacuate().
2141 thunk_selector_depth++;
2142 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2146 val = eval_thunk_selector(info->layout.selector_offset,
2147 (StgSelector *)selectee);
2149 thunk_selector_depth--;
2154 // We evaluated this selector thunk, so update it with
2155 // an indirection. NOTE: we don't use UPD_IND here,
2156 // because we are guaranteed that p is in a generation
2157 // that we are collecting, and we never want to put the
2158 // indirection on a mutable list.
2160 // For the purposes of LDV profiling, we have destroyed
2161 // the original selector thunk.
2162 SET_INFO(p, info_ptr);
2163 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2165 ((StgInd *)selectee)->indirectee = val;
2166 SET_INFO(selectee,&stg_IND_info);
2168 // For the purposes of LDV profiling, we have created an
2170 LDV_RECORD_CREATE(selectee);
2187 case SE_CAF_BLACKHOLE:
2200 // not evaluated yet
2204 barf("eval_thunk_selector: strange selectee %d",
2209 // We didn't manage to evaluate this thunk; restore the old info pointer
2210 SET_INFO(p, info_ptr);
2214 /* -----------------------------------------------------------------------------
2215 move_TSO is called to update the TSO structure after it has been
2216 moved from one place to another.
2217 -------------------------------------------------------------------------- */
2220 move_TSO (StgTSO *src, StgTSO *dest)
2224 // relocate the stack pointer...
2225 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2226 dest->sp = (StgPtr)dest->sp + diff;
2229 /* Similar to scavenge_large_bitmap(), but we don't write back the
2230 * pointers we get back from evacuate().
2233 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2240 bitmap = large_srt->l.bitmap[b];
2241 size = (nat)large_srt->l.size;
2242 p = (StgClosure **)large_srt->srt;
2243 for (i = 0; i < size; ) {
2244 if ((bitmap & 1) != 0) {
2249 if (i % BITS_IN(W_) == 0) {
2251 bitmap = large_srt->l.bitmap[b];
2253 bitmap = bitmap >> 1;
2258 /* evacuate the SRT. If srt_bitmap is zero, then there isn't an
2259 * srt field in the info table. That's ok, because we'll
2260 * never dereference it.
2263 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2268 bitmap = srt_bitmap;
2271 if (bitmap == (StgHalfWord)(-1)) {
2272 scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2276 while (bitmap != 0) {
2277 if ((bitmap & 1) != 0) {
2278 #ifdef ENABLE_WIN32_DLL_SUPPORT
2279 // Special-case to handle references to closures hiding out in DLLs, since
2280 // double indirections required to get at those. The code generator knows
2281 // which is which when generating the SRT, so it stores the (indirect)
2282 // reference to the DLL closure in the table by first adding one to it.
2283 // We check for this here, and undo the addition before evacuating it.
2285 // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2286 // closure that's fixed at link-time, and no extra magic is required.
2287 if ( (unsigned long)(*srt) & 0x1 ) {
2288 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2297 bitmap = bitmap >> 1;
2303 scavenge_thunk_srt(const StgInfoTable *info)
2305 StgThunkInfoTable *thunk_info;
2307 thunk_info = itbl_to_thunk_itbl(info);
2308 scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_bitmap);
2312 scavenge_fun_srt(const StgInfoTable *info)
2314 StgFunInfoTable *fun_info;
2316 fun_info = itbl_to_fun_itbl(info);
2317 scavenge_srt((StgClosure **)fun_info->f.srt, fun_info->i.srt_bitmap);
2321 scavenge_ret_srt(const StgInfoTable *info)
2323 StgRetInfoTable *ret_info;
2325 ret_info = itbl_to_ret_itbl(info);
2326 scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_bitmap);
2329 /* -----------------------------------------------------------------------------
2331 -------------------------------------------------------------------------- */
2334 scavengeTSO (StgTSO *tso)
2336 // chase the link field for any TSOs on the same queue
2337 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2338 if ( tso->why_blocked == BlockedOnMVar
2339 || tso->why_blocked == BlockedOnBlackHole
2340 || tso->why_blocked == BlockedOnException
2342 || tso->why_blocked == BlockedOnGA
2343 || tso->why_blocked == BlockedOnGA_NoSend
2346 tso->block_info.closure = evacuate(tso->block_info.closure);
2348 if ( tso->blocked_exceptions != NULL ) {
2349 tso->blocked_exceptions =
2350 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2353 // scavenge this thread's stack
2354 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2357 /* -----------------------------------------------------------------------------
2358 Blocks of function args occur on the stack (at the top) and
2360 -------------------------------------------------------------------------- */
2362 STATIC_INLINE StgPtr
2363 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2370 switch (fun_info->f.fun_type) {
2372 bitmap = BITMAP_BITS(fun_info->f.bitmap);
2373 size = BITMAP_SIZE(fun_info->f.bitmap);
2376 size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
2377 scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
2381 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2382 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2385 if ((bitmap & 1) == 0) {
2386 (StgClosure *)*p = evacuate((StgClosure *)*p);
2389 bitmap = bitmap >> 1;
2397 STATIC_INLINE StgPtr
2398 scavenge_PAP (StgPAP *pap)
2401 StgWord bitmap, size;
2402 StgFunInfoTable *fun_info;
2404 pap->fun = evacuate(pap->fun);
2405 fun_info = get_fun_itbl(pap->fun);
2406 ASSERT(fun_info->i.type != PAP);
2408 p = (StgPtr)pap->payload;
2411 switch (fun_info->f.fun_type) {
2413 bitmap = BITMAP_BITS(fun_info->f.bitmap);
2416 scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
2420 scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
2424 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2428 if ((bitmap & 1) == 0) {
2429 (StgClosure *)*p = evacuate((StgClosure *)*p);
2432 bitmap = bitmap >> 1;
2440 /* -----------------------------------------------------------------------------
2441 Scavenge a given step until there are no more objects in this step
2444 evac_gen is set by the caller to be either zero (for a step in a
2445 generation < N) or G where G is the generation of the step being
2448 We sometimes temporarily change evac_gen back to zero if we're
2449 scavenging a mutable object where early promotion isn't such a good
2451 -------------------------------------------------------------------------- */
2459 nat saved_evac_gen = evac_gen;
2464 failed_to_evac = rtsFalse;
2466 /* scavenge phase - standard breadth-first scavenging of the
2470 while (bd != stp->hp_bd || p < stp->hp) {
2472 // If we're at the end of this block, move on to the next block
2473 if (bd != stp->hp_bd && p == bd->free) {
2479 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2480 info = get_itbl((StgClosure *)p);
2482 ASSERT(thunk_selector_depth == 0);
2485 switch (info->type) {
2488 /* treat MVars specially, because we don't want to evacuate the
2489 * mut_link field in the middle of the closure.
2492 StgMVar *mvar = ((StgMVar *)p);
2494 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2495 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2496 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2497 evac_gen = saved_evac_gen;
2498 recordMutable((StgMutClosure *)mvar);
2499 failed_to_evac = rtsFalse; // mutable.
2500 p += sizeofW(StgMVar);
2505 scavenge_fun_srt(info);
2506 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2507 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2508 p += sizeofW(StgHeader) + 2;
2512 scavenge_thunk_srt(info);
2514 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2515 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2516 p += sizeofW(StgHeader) + 2;
2520 scavenge_thunk_srt(info);
2521 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2522 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2526 scavenge_fun_srt(info);
2528 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2529 p += sizeofW(StgHeader) + 1;
2533 scavenge_thunk_srt(info);
2534 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2538 scavenge_fun_srt(info);
2540 p += sizeofW(StgHeader) + 1;
2544 scavenge_thunk_srt(info);
2545 p += sizeofW(StgHeader) + 2;
2549 scavenge_fun_srt(info);
2551 p += sizeofW(StgHeader) + 2;
2555 scavenge_thunk_srt(info);
2556 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2557 p += sizeofW(StgHeader) + 2;
2561 scavenge_fun_srt(info);
2563 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2564 p += sizeofW(StgHeader) + 2;
2568 scavenge_fun_srt(info);
2572 scavenge_thunk_srt(info);
2583 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2584 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2585 (StgClosure *)*p = evacuate((StgClosure *)*p);
2587 p += info->layout.payload.nptrs;
2592 StgBCO *bco = (StgBCO *)p;
2593 (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2594 (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2595 (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2596 (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2597 p += bco_sizeW(bco);
2602 if (stp->gen->no != 0) {
2605 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2606 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2607 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2610 // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2612 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2614 // We pretend that p has just been created.
2615 LDV_RECORD_CREATE((StgClosure *)p);
2618 case IND_OLDGEN_PERM:
2619 ((StgIndOldGen *)p)->indirectee =
2620 evacuate(((StgIndOldGen *)p)->indirectee);
2621 if (failed_to_evac) {
2622 failed_to_evac = rtsFalse;
2623 recordOldToNewPtrs((StgMutClosure *)p);
2625 p += sizeofW(StgIndOldGen);
2630 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2631 evac_gen = saved_evac_gen;
2632 recordMutable((StgMutClosure *)p);
2633 failed_to_evac = rtsFalse; // mutable anyhow
2634 p += sizeofW(StgMutVar);
2639 failed_to_evac = rtsFalse; // mutable anyhow
2640 p += sizeofW(StgMutVar);
2644 case SE_CAF_BLACKHOLE:
2647 p += BLACKHOLE_sizeW();
2652 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2653 (StgClosure *)bh->blocking_queue =
2654 evacuate((StgClosure *)bh->blocking_queue);
2655 recordMutable((StgMutClosure *)bh);
2656 failed_to_evac = rtsFalse;
2657 p += BLACKHOLE_sizeW();
2661 case THUNK_SELECTOR:
2663 StgSelector *s = (StgSelector *)p;
2664 s->selectee = evacuate(s->selectee);
2665 p += THUNK_SELECTOR_sizeW();
2669 // A chunk of stack saved in a heap object
2672 StgAP_STACK *ap = (StgAP_STACK *)p;
2674 ap->fun = evacuate(ap->fun);
2675 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2676 p = (StgPtr)ap->payload + ap->size;
2682 p = scavenge_PAP((StgPAP *)p);
2686 // nothing to follow
2687 p += arr_words_sizeW((StgArrWords *)p);
2691 // follow everything
2695 evac_gen = 0; // repeatedly mutable
2696 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2697 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2698 (StgClosure *)*p = evacuate((StgClosure *)*p);
2700 evac_gen = saved_evac_gen;
2701 recordMutable((StgMutClosure *)q);
2702 failed_to_evac = rtsFalse; // mutable anyhow.
2706 case MUT_ARR_PTRS_FROZEN:
2707 // follow everything
2711 // Set the mut_link field to NULL, so that we will put this
2712 // array back on the mutable list if it is subsequently thawed
2714 ((StgMutArrPtrs*)p)->mut_link = NULL;
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 // it's tempting to recordMutable() if failed_to_evac is
2721 // false, but that breaks some assumptions (eg. every
2722 // closure on the mutable list is supposed to have the MUT
2723 // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2729 StgTSO *tso = (StgTSO *)p;
2732 evac_gen = saved_evac_gen;
2733 recordMutable((StgMutClosure *)tso);
2734 failed_to_evac = rtsFalse; // mutable anyhow.
2735 p += tso_sizeW(tso);
2740 case RBH: // cf. BLACKHOLE_BQ
2743 nat size, ptrs, nonptrs, vhs;
2745 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2747 StgRBH *rbh = (StgRBH *)p;
2748 (StgClosure *)rbh->blocking_queue =
2749 evacuate((StgClosure *)rbh->blocking_queue);
2750 recordMutable((StgMutClosure *)to);
2751 failed_to_evac = rtsFalse; // mutable anyhow.
2753 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2754 p, info_type(p), (StgClosure *)rbh->blocking_queue));
2755 // ToDo: use size of reverted closure here!
2756 p += BLACKHOLE_sizeW();
2762 StgBlockedFetch *bf = (StgBlockedFetch *)p;
2763 // follow the pointer to the node which is being demanded
2764 (StgClosure *)bf->node =
2765 evacuate((StgClosure *)bf->node);
2766 // follow the link to the rest of the blocking queue
2767 (StgClosure *)bf->link =
2768 evacuate((StgClosure *)bf->link);
2769 if (failed_to_evac) {
2770 failed_to_evac = rtsFalse;
2771 recordMutable((StgMutClosure *)bf);
2774 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2775 bf, info_type((StgClosure *)bf),
2776 bf->node, info_type(bf->node)));
2777 p += sizeofW(StgBlockedFetch);
2785 p += sizeofW(StgFetchMe);
2786 break; // nothing to do in this case
2788 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2790 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2791 (StgClosure *)fmbq->blocking_queue =
2792 evacuate((StgClosure *)fmbq->blocking_queue);
2793 if (failed_to_evac) {
2794 failed_to_evac = rtsFalse;
2795 recordMutable((StgMutClosure *)fmbq);
2798 belch("@@ scavenge: %p (%s) exciting, isn't it",
2799 p, info_type((StgClosure *)p)));
2800 p += sizeofW(StgFetchMeBlockingQueue);
2806 barf("scavenge: unimplemented/strange closure type %d @ %p",
2810 /* If we didn't manage to promote all the objects pointed to by
2811 * the current object, then we have to designate this object as
2812 * mutable (because it contains old-to-new generation pointers).
2814 if (failed_to_evac) {
2815 failed_to_evac = rtsFalse;
2816 mkMutCons((StgClosure *)q, &generations[evac_gen]);
2824 /* -----------------------------------------------------------------------------
2825 Scavenge everything on the mark stack.
2827 This is slightly different from scavenge():
2828 - we don't walk linearly through the objects, so the scavenger
2829 doesn't need to advance the pointer on to the next object.
2830 -------------------------------------------------------------------------- */
2833 scavenge_mark_stack(void)
2839 evac_gen = oldest_gen->no;
2840 saved_evac_gen = evac_gen;
2843 while (!mark_stack_empty()) {
2844 p = pop_mark_stack();
2846 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2847 info = get_itbl((StgClosure *)p);
2850 switch (info->type) {
2853 /* treat MVars specially, because we don't want to evacuate the
2854 * mut_link field in the middle of the closure.
2857 StgMVar *mvar = ((StgMVar *)p);
2859 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2860 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2861 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2862 evac_gen = saved_evac_gen;
2863 failed_to_evac = rtsFalse; // mutable.
2868 scavenge_fun_srt(info);
2869 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2870 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2874 scavenge_thunk_srt(info);
2876 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2877 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2882 scavenge_fun_srt(info);
2883 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2888 scavenge_thunk_srt(info);
2891 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2896 scavenge_fun_srt(info);
2901 scavenge_thunk_srt(info);
2909 scavenge_fun_srt(info);
2913 scavenge_thunk_srt(info);
2924 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2925 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2926 (StgClosure *)*p = evacuate((StgClosure *)*p);
2932 StgBCO *bco = (StgBCO *)p;
2933 (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2934 (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2935 (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2936 (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2941 // don't need to do anything here: the only possible case
2942 // is that we're in a 1-space compacting collector, with
2943 // no "old" generation.
2947 case IND_OLDGEN_PERM:
2948 ((StgIndOldGen *)p)->indirectee =
2949 evacuate(((StgIndOldGen *)p)->indirectee);
2950 if (failed_to_evac) {
2951 recordOldToNewPtrs((StgMutClosure *)p);
2953 failed_to_evac = rtsFalse;
2958 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2959 evac_gen = saved_evac_gen;
2960 failed_to_evac = rtsFalse;
2965 failed_to_evac = rtsFalse;
2969 case SE_CAF_BLACKHOLE:
2977 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2978 (StgClosure *)bh->blocking_queue =
2979 evacuate((StgClosure *)bh->blocking_queue);
2980 failed_to_evac = rtsFalse;
2984 case THUNK_SELECTOR:
2986 StgSelector *s = (StgSelector *)p;
2987 s->selectee = evacuate(s->selectee);
2991 // A chunk of stack saved in a heap object
2994 StgAP_STACK *ap = (StgAP_STACK *)p;
2996 ap->fun = evacuate(ap->fun);
2997 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3003 scavenge_PAP((StgPAP *)p);
3007 // follow everything
3011 evac_gen = 0; // repeatedly mutable
3012 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3013 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3014 (StgClosure *)*p = evacuate((StgClosure *)*p);
3016 evac_gen = saved_evac_gen;
3017 failed_to_evac = rtsFalse; // mutable anyhow.
3021 case MUT_ARR_PTRS_FROZEN:
3022 // follow everything
3026 // Set the mut_link field to NULL, so that we will put this
3027 // array on the mutable list if it is subsequently thawed
3029 ((StgMutArrPtrs*)p)->mut_link = NULL;
3031 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3032 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3033 (StgClosure *)*p = evacuate((StgClosure *)*p);
3040 StgTSO *tso = (StgTSO *)p;
3043 evac_gen = saved_evac_gen;
3044 failed_to_evac = rtsFalse;
3049 case RBH: // cf. BLACKHOLE_BQ
3052 nat size, ptrs, nonptrs, vhs;
3054 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3056 StgRBH *rbh = (StgRBH *)p;
3057 (StgClosure *)rbh->blocking_queue =
3058 evacuate((StgClosure *)rbh->blocking_queue);
3059 recordMutable((StgMutClosure *)rbh);
3060 failed_to_evac = rtsFalse; // mutable anyhow.
3062 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3063 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3069 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3070 // follow the pointer to the node which is being demanded
3071 (StgClosure *)bf->node =
3072 evacuate((StgClosure *)bf->node);
3073 // follow the link to the rest of the blocking queue
3074 (StgClosure *)bf->link =
3075 evacuate((StgClosure *)bf->link);
3076 if (failed_to_evac) {
3077 failed_to_evac = rtsFalse;
3078 recordMutable((StgMutClosure *)bf);
3081 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3082 bf, info_type((StgClosure *)bf),
3083 bf->node, info_type(bf->node)));
3091 break; // nothing to do in this case
3093 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3095 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3096 (StgClosure *)fmbq->blocking_queue =
3097 evacuate((StgClosure *)fmbq->blocking_queue);
3098 if (failed_to_evac) {
3099 failed_to_evac = rtsFalse;
3100 recordMutable((StgMutClosure *)fmbq);
3103 belch("@@ scavenge: %p (%s) exciting, isn't it",
3104 p, info_type((StgClosure *)p)));
3110 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3114 if (failed_to_evac) {
3115 failed_to_evac = rtsFalse;
3116 mkMutCons((StgClosure *)q, &generations[evac_gen]);
3119 // mark the next bit to indicate "scavenged"
3120 mark(q+1, Bdescr(q));
3122 } // while (!mark_stack_empty())
3124 // start a new linear scan if the mark stack overflowed at some point
3125 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3126 IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
3127 mark_stack_overflowed = rtsFalse;
3128 oldgen_scan_bd = oldest_gen->steps[0].blocks;
3129 oldgen_scan = oldgen_scan_bd->start;
3132 if (oldgen_scan_bd) {
3133 // push a new thing on the mark stack
3135 // find a closure that is marked but not scavenged, and start
3137 while (oldgen_scan < oldgen_scan_bd->free
3138 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3142 if (oldgen_scan < oldgen_scan_bd->free) {
3144 // already scavenged?
3145 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3146 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3149 push_mark_stack(oldgen_scan);
3150 // ToDo: bump the linear scan by the actual size of the object
3151 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3155 oldgen_scan_bd = oldgen_scan_bd->link;
3156 if (oldgen_scan_bd != NULL) {
3157 oldgen_scan = oldgen_scan_bd->start;
3163 /* -----------------------------------------------------------------------------
3164 Scavenge one object.
3166 This is used for objects that are temporarily marked as mutable
3167 because they contain old-to-new generation pointers. Only certain
3168 objects can have this property.
3169 -------------------------------------------------------------------------- */
3172 scavenge_one(StgPtr p)
3174 const StgInfoTable *info;
3175 nat saved_evac_gen = evac_gen;
3178 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3179 info = get_itbl((StgClosure *)p);
3181 switch (info->type) {
3184 case FUN_1_0: // hardly worth specialising these guys
3204 case IND_OLDGEN_PERM:
3208 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3209 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3210 (StgClosure *)*q = evacuate((StgClosure *)*q);
3216 case SE_CAF_BLACKHOLE:
3221 case THUNK_SELECTOR:
3223 StgSelector *s = (StgSelector *)p;
3224 s->selectee = evacuate(s->selectee);
3229 // nothing to follow
3234 // follow everything
3237 evac_gen = 0; // repeatedly mutable
3238 recordMutable((StgMutClosure *)p);
3239 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3240 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3241 (StgClosure *)*p = evacuate((StgClosure *)*p);
3243 evac_gen = saved_evac_gen;
3244 failed_to_evac = rtsFalse;
3248 case MUT_ARR_PTRS_FROZEN:
3250 // follow everything
3253 // Set the mut_link field to NULL, so that we will put this
3254 // array on the mutable list if it is subsequently thawed
3256 ((StgMutArrPtrs*)p)->mut_link = NULL;
3258 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3259 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3260 (StgClosure *)*p = evacuate((StgClosure *)*p);
3267 StgTSO *tso = (StgTSO *)p;
3269 evac_gen = 0; // repeatedly mutable
3271 recordMutable((StgMutClosure *)tso);
3272 evac_gen = saved_evac_gen;
3273 failed_to_evac = rtsFalse;
3279 StgAP_STACK *ap = (StgAP_STACK *)p;
3281 ap->fun = evacuate(ap->fun);
3282 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3283 p = (StgPtr)ap->payload + ap->size;
3289 p = scavenge_PAP((StgPAP *)p);
3293 // This might happen if for instance a MUT_CONS was pointing to a
3294 // THUNK which has since been updated. The IND_OLDGEN will
3295 // be on the mutable list anyway, so we don't need to do anything
3300 barf("scavenge_one: strange object %d", (int)(info->type));
3303 no_luck = failed_to_evac;
3304 failed_to_evac = rtsFalse;
3308 /* -----------------------------------------------------------------------------
3309 Scavenging mutable lists.
3311 We treat the mutable list of each generation > N (i.e. all the
3312 generations older than the one being collected) as roots. We also
3313 remove non-mutable objects from the mutable list at this point.
3314 -------------------------------------------------------------------------- */
3317 scavenge_mut_once_list(generation *gen)
3319 const StgInfoTable *info;
3320 StgMutClosure *p, *next, *new_list;
3322 p = gen->mut_once_list;
3323 new_list = END_MUT_LIST;
3327 failed_to_evac = rtsFalse;
3329 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3331 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3334 if (info->type==RBH)
3335 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3337 switch(info->type) {
3340 case IND_OLDGEN_PERM:
3342 /* Try to pull the indirectee into this generation, so we can
3343 * remove the indirection from the mutable list.
3345 ((StgIndOldGen *)p)->indirectee =
3346 evacuate(((StgIndOldGen *)p)->indirectee);
3348 #if 0 && defined(DEBUG)
3349 if (RtsFlags.DebugFlags.gc)
3350 /* Debugging code to print out the size of the thing we just
3354 StgPtr start = gen->steps[0].scan;
3355 bdescr *start_bd = gen->steps[0].scan_bd;
3357 scavenge(&gen->steps[0]);
3358 if (start_bd != gen->steps[0].scan_bd) {
3359 size += (P_)BLOCK_ROUND_UP(start) - start;
3360 start_bd = start_bd->link;
3361 while (start_bd != gen->steps[0].scan_bd) {
3362 size += BLOCK_SIZE_W;
3363 start_bd = start_bd->link;
3365 size += gen->steps[0].scan -
3366 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3368 size = gen->steps[0].scan - start;
3370 belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3374 /* failed_to_evac might happen if we've got more than two
3375 * generations, we're collecting only generation 0, the
3376 * indirection resides in generation 2 and the indirectee is
3379 if (failed_to_evac) {
3380 failed_to_evac = rtsFalse;
3381 p->mut_link = new_list;
3384 /* the mut_link field of an IND_STATIC is overloaded as the
3385 * static link field too (it just so happens that we don't need
3386 * both at the same time), so we need to NULL it out when
3387 * removing this object from the mutable list because the static
3388 * link fields are all assumed to be NULL before doing a major
3396 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3397 * it from the mutable list if possible by promoting whatever it
3400 if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3401 /* didn't manage to promote everything, so put the
3402 * MUT_CONS back on the list.
3404 p->mut_link = new_list;
3410 // shouldn't have anything else on the mutables list
3411 barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3415 gen->mut_once_list = new_list;
3420 scavenge_mutable_list(generation *gen)
3422 const StgInfoTable *info;
3423 StgMutClosure *p, *next;
3425 p = gen->saved_mut_list;
3429 failed_to_evac = rtsFalse;
3431 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3433 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3436 if (info->type==RBH)
3437 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3439 switch(info->type) {
3442 // follow everything
3443 p->mut_link = gen->mut_list;
3448 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3449 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3450 (StgClosure *)*q = evacuate((StgClosure *)*q);
3455 // Happens if a MUT_ARR_PTRS in the old generation is frozen
3456 case MUT_ARR_PTRS_FROZEN:
3461 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3462 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3463 (StgClosure *)*q = evacuate((StgClosure *)*q);
3466 // Set the mut_link field to NULL, so that we will put this
3467 // array back on the mutable list if it is subsequently thawed
3470 if (failed_to_evac) {
3471 failed_to_evac = rtsFalse;
3472 mkMutCons((StgClosure *)p, gen);
3478 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3479 p->mut_link = gen->mut_list;
3485 StgMVar *mvar = (StgMVar *)p;
3486 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3487 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3488 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3489 p->mut_link = gen->mut_list;
3496 StgTSO *tso = (StgTSO *)p;
3500 /* Don't take this TSO off the mutable list - it might still
3501 * point to some younger objects (because we set evac_gen to 0
3504 tso->mut_link = gen->mut_list;
3505 gen->mut_list = (StgMutClosure *)tso;
3511 StgBlockingQueue *bh = (StgBlockingQueue *)p;
3512 (StgClosure *)bh->blocking_queue =
3513 evacuate((StgClosure *)bh->blocking_queue);
3514 p->mut_link = gen->mut_list;
3519 /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3522 case IND_OLDGEN_PERM:
3523 /* Try to pull the indirectee into this generation, so we can
3524 * remove the indirection from the mutable list.
3527 ((StgIndOldGen *)p)->indirectee =
3528 evacuate(((StgIndOldGen *)p)->indirectee);
3531 if (failed_to_evac) {
3532 failed_to_evac = rtsFalse;
3533 p->mut_link = gen->mut_once_list;
3534 gen->mut_once_list = p;
3541 // HWL: check whether all of these are necessary
3543 case RBH: // cf. BLACKHOLE_BQ
3545 // nat size, ptrs, nonptrs, vhs;
3547 // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3548 StgRBH *rbh = (StgRBH *)p;
3549 (StgClosure *)rbh->blocking_queue =
3550 evacuate((StgClosure *)rbh->blocking_queue);
3551 if (failed_to_evac) {
3552 failed_to_evac = rtsFalse;
3553 recordMutable((StgMutClosure *)rbh);
3555 // ToDo: use size of reverted closure here!
3556 p += BLACKHOLE_sizeW();
3562 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3563 // follow the pointer to the node which is being demanded
3564 (StgClosure *)bf->node =
3565 evacuate((StgClosure *)bf->node);
3566 // follow the link to the rest of the blocking queue
3567 (StgClosure *)bf->link =
3568 evacuate((StgClosure *)bf->link);
3569 if (failed_to_evac) {
3570 failed_to_evac = rtsFalse;
3571 recordMutable((StgMutClosure *)bf);
3573 p += sizeofW(StgBlockedFetch);
3579 barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3582 p += sizeofW(StgFetchMe);
3583 break; // nothing to do in this case
3585 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3587 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3588 (StgClosure *)fmbq->blocking_queue =
3589 evacuate((StgClosure *)fmbq->blocking_queue);
3590 if (failed_to_evac) {
3591 failed_to_evac = rtsFalse;
3592 recordMutable((StgMutClosure *)fmbq);
3594 p += sizeofW(StgFetchMeBlockingQueue);
3600 // shouldn't have anything else on the mutables list
3601 barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3608 scavenge_static(void)
3610 StgClosure* p = static_objects;
3611 const StgInfoTable *info;
3613 /* Always evacuate straight to the oldest generation for static
3615 evac_gen = oldest_gen->no;
3617 /* keep going until we've scavenged all the objects on the linked
3619 while (p != END_OF_STATIC_LIST) {
3621 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3624 if (info->type==RBH)
3625 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3627 // make sure the info pointer is into text space
3629 /* Take this object *off* the static_objects list,
3630 * and put it on the scavenged_static_objects list.
3632 static_objects = STATIC_LINK(info,p);
3633 STATIC_LINK(info,p) = scavenged_static_objects;
3634 scavenged_static_objects = p;
3636 switch (info -> type) {
3640 StgInd *ind = (StgInd *)p;
3641 ind->indirectee = evacuate(ind->indirectee);
3643 /* might fail to evacuate it, in which case we have to pop it
3644 * back on the mutable list (and take it off the
3645 * scavenged_static list because the static link and mut link
3646 * pointers are one and the same).
3648 if (failed_to_evac) {
3649 failed_to_evac = rtsFalse;
3650 scavenged_static_objects = IND_STATIC_LINK(p);
3651 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3652 oldest_gen->mut_once_list = (StgMutClosure *)ind;
3658 scavenge_thunk_srt(info);
3662 scavenge_fun_srt(info);
3669 next = (P_)p->payload + info->layout.payload.ptrs;
3670 // evacuate the pointers
3671 for (q = (P_)p->payload; q < next; q++) {
3672 (StgClosure *)*q = evacuate((StgClosure *)*q);
3678 barf("scavenge_static: strange closure %d", (int)(info->type));
3681 ASSERT(failed_to_evac == rtsFalse);
3683 /* get the next static object from the list. Remember, there might
3684 * be more stuff on this list now that we've done some evacuating!
3685 * (static_objects is a global)
3691 /* -----------------------------------------------------------------------------
3692 scavenge a chunk of memory described by a bitmap
3693 -------------------------------------------------------------------------- */
3696 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
3702 bitmap = large_bitmap->bitmap[b];
3703 for (i = 0; i < size; ) {
3704 if ((bitmap & 1) == 0) {
3705 (StgClosure *)*p = evacuate((StgClosure *)*p);
3709 if (i % BITS_IN(W_) == 0) {
3711 bitmap = large_bitmap->bitmap[b];
3713 bitmap = bitmap >> 1;
3718 STATIC_INLINE StgPtr
3719 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
3722 if ((bitmap & 1) == 0) {
3723 (StgClosure *)*p = evacuate((StgClosure *)*p);
3726 bitmap = bitmap >> 1;
3732 /* -----------------------------------------------------------------------------
3733 scavenge_stack walks over a section of stack and evacuates all the
3734 objects pointed to by it. We can use the same code for walking
3735 AP_STACK_UPDs, since these are just sections of copied stack.
3736 -------------------------------------------------------------------------- */
3740 scavenge_stack(StgPtr p, StgPtr stack_end)
3742 const StgRetInfoTable* info;
3746 //IF_DEBUG(sanity, belch(" scavenging stack between %p and %p", p, stack_end));
3749 * Each time around this loop, we are looking at a chunk of stack
3750 * that starts with an activation record.
3753 while (p < stack_end) {
3754 info = get_ret_itbl((StgClosure *)p);
3756 switch (info->i.type) {
3759 ((StgUpdateFrame *)p)->updatee
3760 = evacuate(((StgUpdateFrame *)p)->updatee);
3761 p += sizeofW(StgUpdateFrame);
3764 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3769 bitmap = BITMAP_BITS(info->i.layout.bitmap);
3770 size = BITMAP_SIZE(info->i.layout.bitmap);
3771 // NOTE: the payload starts immediately after the info-ptr, we
3772 // don't have an StgHeader in the same sense as a heap closure.
3774 p = scavenge_small_bitmap(p, size, bitmap);
3777 scavenge_srt((StgClosure **)info->srt, info->i.srt_bitmap);
3785 (StgClosure *)*p = evacuate((StgClosure *)*p);
3788 size = BCO_BITMAP_SIZE(bco);
3789 scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
3794 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3800 size = info->i.layout.large_bitmap->size;
3802 scavenge_large_bitmap(p, info->i.layout.large_bitmap, size);
3804 // and don't forget to follow the SRT
3808 // Dynamic bitmap: the mask is stored on the stack, and
3809 // there are a number of non-pointers followed by a number
3810 // of pointers above the bitmapped area. (see StgMacros.h,
3815 dyn = ((StgRetDyn *)p)->liveness;
3817 // traverse the bitmap first
3818 bitmap = RET_DYN_LIVENESS(dyn);
3819 p = (P_)&((StgRetDyn *)p)->payload[0];
3820 size = RET_DYN_BITMAP_SIZE;
3821 p = scavenge_small_bitmap(p, size, bitmap);
3823 // skip over the non-ptr words
3824 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
3826 // follow the ptr words
3827 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
3828 (StgClosure *)*p = evacuate((StgClosure *)*p);
3836 StgRetFun *ret_fun = (StgRetFun *)p;
3837 StgFunInfoTable *fun_info;
3839 ret_fun->fun = evacuate(ret_fun->fun);
3840 fun_info = get_fun_itbl(ret_fun->fun);
3841 p = scavenge_arg_block(fun_info, ret_fun->payload);
3846 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
3851 /*-----------------------------------------------------------------------------
3852 scavenge the large object list.
3854 evac_gen set by caller; similar games played with evac_gen as with
3855 scavenge() - see comment at the top of scavenge(). Most large
3856 objects are (repeatedly) mutable, so most of the time evac_gen will
3858 --------------------------------------------------------------------------- */
3861 scavenge_large(step *stp)
3866 bd = stp->new_large_objects;
3868 for (; bd != NULL; bd = stp->new_large_objects) {
3870 /* take this object *off* the large objects list and put it on
3871 * the scavenged large objects list. This is so that we can
3872 * treat new_large_objects as a stack and push new objects on
3873 * the front when evacuating.
3875 stp->new_large_objects = bd->link;
3876 dbl_link_onto(bd, &stp->scavenged_large_objects);
3878 // update the block count in this step.
3879 stp->n_scavenged_large_blocks += bd->blocks;
3882 if (scavenge_one(p)) {
3883 mkMutCons((StgClosure *)p, stp->gen);
3888 /* -----------------------------------------------------------------------------
3889 Initialising the static object & mutable lists
3890 -------------------------------------------------------------------------- */
3893 zero_static_object_list(StgClosure* first_static)
3897 const StgInfoTable *info;
3899 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3901 link = STATIC_LINK(info, p);
3902 STATIC_LINK(info,p) = NULL;
3906 /* This function is only needed because we share the mutable link
3907 * field with the static link field in an IND_STATIC, so we have to
3908 * zero the mut_link field before doing a major GC, which needs the
3909 * static link field.
3911 * It doesn't do any harm to zero all the mutable link fields on the
3916 zero_mutable_list( StgMutClosure *first )
3918 StgMutClosure *next, *c;
3920 for (c = first; c != END_MUT_LIST; c = next) {
3926 /* -----------------------------------------------------------------------------
3928 -------------------------------------------------------------------------- */
3935 for (c = (StgIndStatic *)caf_list; c != NULL;
3936 c = (StgIndStatic *)c->static_link)
3938 SET_INFO(c, c->saved_info);
3939 c->saved_info = NULL;
3940 // could, but not necessary: c->static_link = NULL;
3946 markCAFs( evac_fn evac )
3950 for (c = (StgIndStatic *)caf_list; c != NULL;
3951 c = (StgIndStatic *)c->static_link)
3953 evac(&c->indirectee);
3957 /* -----------------------------------------------------------------------------
3958 Sanity code for CAF garbage collection.
3960 With DEBUG turned on, we manage a CAF list in addition to the SRT
3961 mechanism. After GC, we run down the CAF list and blackhole any
3962 CAFs which have been garbage collected. This means we get an error
3963 whenever the program tries to enter a garbage collected CAF.
3965 Any garbage collected CAFs are taken off the CAF list at the same
3967 -------------------------------------------------------------------------- */
3969 #if 0 && defined(DEBUG)
3976 const StgInfoTable *info;
3987 ASSERT(info->type == IND_STATIC);
3989 if (STATIC_LINK(info,p) == NULL) {
3990 IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3992 SET_INFO(p,&stg_BLACKHOLE_info);
3993 p = STATIC_LINK2(info,p);
3997 pp = &STATIC_LINK2(info,p);
4004 // belch("%d CAFs live", i);
4009 /* -----------------------------------------------------------------------------
4012 Whenever a thread returns to the scheduler after possibly doing
4013 some work, we have to run down the stack and black-hole all the
4014 closures referred to by update frames.
4015 -------------------------------------------------------------------------- */
4018 threadLazyBlackHole(StgTSO *tso)
4021 StgRetInfoTable *info;
4022 StgBlockingQueue *bh;
4025 stack_end = &tso->stack[tso->stack_size];
4027 frame = (StgClosure *)tso->sp;
4030 info = get_ret_itbl(frame);
4032 switch (info->i.type) {
4035 bh = (StgBlockingQueue *)((StgUpdateFrame *)frame)->updatee;
4037 /* if the thunk is already blackholed, it means we've also
4038 * already blackholed the rest of the thunks on this stack,
4039 * so we can stop early.
4041 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
4042 * don't interfere with this optimisation.
4044 if (bh->header.info == &stg_BLACKHOLE_info) {
4048 if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
4049 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4050 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4051 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4055 // We pretend that bh is now dead.
4056 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4058 SET_INFO(bh,&stg_BLACKHOLE_info);
4060 // We pretend that bh has just been created.
4061 LDV_RECORD_CREATE(bh);
4064 frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4070 // normal stack frames; do nothing except advance the pointer
4072 (StgPtr)frame += stack_frame_sizeW(frame);
4078 /* -----------------------------------------------------------------------------
4081 * Code largely pinched from old RTS, then hacked to bits. We also do
4082 * lazy black holing here.
4084 * -------------------------------------------------------------------------- */
4086 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4089 threadSqueezeStack(StgTSO *tso)
4092 rtsBool prev_was_update_frame;
4093 StgClosure *updatee = NULL;
4095 StgRetInfoTable *info;
4096 StgWord current_gap_size;
4097 struct stack_gap *gap;
4100 // Traverse the stack upwards, replacing adjacent update frames
4101 // with a single update frame and a "stack gap". A stack gap
4102 // contains two values: the size of the gap, and the distance
4103 // to the next gap (or the stack top).
4105 bottom = &(tso->stack[tso->stack_size]);
4109 ASSERT(frame < bottom);
4111 prev_was_update_frame = rtsFalse;
4112 current_gap_size = 0;
4113 gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4115 while (frame < bottom) {
4117 info = get_ret_itbl((StgClosure *)frame);
4118 switch (info->i.type) {
4122 StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4124 if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
4126 // found a BLACKHOLE'd update frame; we've been here
4127 // before, in a previous GC, so just break out.
4129 // Mark the end of the gap, if we're in one.
4130 if (current_gap_size != 0) {
4131 gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
4134 frame += sizeofW(StgUpdateFrame);
4135 goto done_traversing;
4138 if (prev_was_update_frame) {
4140 TICK_UPD_SQUEEZED();
4141 /* wasn't there something about update squeezing and ticky to be
4142 * sorted out? oh yes: we aren't counting each enter properly
4143 * in this case. See the log somewhere. KSW 1999-04-21
4145 * Check two things: that the two update frames don't point to
4146 * the same object, and that the updatee_bypass isn't already an
4147 * indirection. Both of these cases only happen when we're in a
4148 * block hole-style loop (and there are multiple update frames
4149 * on the stack pointing to the same closure), but they can both
4150 * screw us up if we don't check.
4152 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4153 // this wakes the threads up
4154 UPD_IND_NOLOCK(upd->updatee, updatee);
4157 // now mark this update frame as a stack gap. The gap
4158 // marker resides in the bottom-most update frame of
4159 // the series of adjacent frames, and covers all the
4160 // frames in this series.
4161 current_gap_size += sizeofW(StgUpdateFrame);
4162 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4163 ((struct stack_gap *)frame)->next_gap = gap;
4165 frame += sizeofW(StgUpdateFrame);
4169 // single update frame, or the topmost update frame in a series
4171 StgBlockingQueue *bh = (StgBlockingQueue *)upd->updatee;
4173 // Do lazy black-holing
4174 if (bh->header.info != &stg_BLACKHOLE_info &&
4175 bh->header.info != &stg_BLACKHOLE_BQ_info &&
4176 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4177 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4178 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4181 /* zero out the slop so that the sanity checker can tell
4182 * where the next closure is.
4185 StgInfoTable *bh_info = get_itbl(bh);
4186 nat np = bh_info->layout.payload.ptrs,
4187 nw = bh_info->layout.payload.nptrs, i;
4188 /* don't zero out slop for a THUNK_SELECTOR,
4189 * because its layout info is used for a
4190 * different purpose, and it's exactly the
4191 * same size as a BLACKHOLE in any case.
4193 if (bh_info->type != THUNK_SELECTOR) {
4194 for (i = np; i < np + nw; i++) {
4195 ((StgClosure *)bh)->payload[i] = 0;
4201 // We pretend that bh is now dead.
4202 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4204 // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
4205 SET_INFO(bh,&stg_BLACKHOLE_info);
4207 // We pretend that bh has just been created.
4208 LDV_RECORD_CREATE(bh);
4211 prev_was_update_frame = rtsTrue;
4212 updatee = upd->updatee;
4213 frame += sizeofW(StgUpdateFrame);
4219 prev_was_update_frame = rtsFalse;
4221 // we're not in a gap... check whether this is the end of a gap
4222 // (an update frame can't be the end of a gap).
4223 if (current_gap_size != 0) {
4224 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4226 current_gap_size = 0;
4228 frame += stack_frame_sizeW((StgClosure *)frame);
4235 // Now we have a stack with gaps in it, and we have to walk down
4236 // shoving the stack up to fill in the gaps. A diagram might
4240 // | ********* | <- sp
4244 // | stack_gap | <- gap | chunk_size
4246 // | ......... | <- gap_end v
4252 // 'sp' points the the current top-of-stack
4253 // 'gap' points to the stack_gap structure inside the gap
4254 // ***** indicates real stack data
4255 // ..... indicates gap
4256 // <empty> indicates unused
4260 void *gap_start, *next_gap_start, *gap_end;
4263 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4264 sp = next_gap_start;
4266 while ((StgPtr)gap > tso->sp) {
4268 // we're working in *bytes* now...
4269 gap_start = next_gap_start;
4270 gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4272 gap = gap->next_gap;
4273 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4275 chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4276 (unsigned char*)sp -= chunk_size;
4277 memmove(sp, next_gap_start, chunk_size);
4280 tso->sp = (StgPtr)sp;
4284 /* -----------------------------------------------------------------------------
4287 * We have to prepare for GC - this means doing lazy black holing
4288 * here. We also take the opportunity to do stack squeezing if it's
4290 * -------------------------------------------------------------------------- */
4292 threadPaused(StgTSO *tso)
4294 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4295 threadSqueezeStack(tso); // does black holing too
4297 threadLazyBlackHole(tso);
4300 /* -----------------------------------------------------------------------------
4302 * -------------------------------------------------------------------------- */
4306 printMutOnceList(generation *gen)
4308 StgMutClosure *p, *next;
4310 p = gen->mut_once_list;
4313 fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4314 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4315 fprintf(stderr, "%p (%s), ",
4316 p, info_type((StgClosure *)p));
4318 fputc('\n', stderr);
4322 printMutableList(generation *gen)
4324 StgMutClosure *p, *next;
4329 fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4330 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4331 fprintf(stderr, "%p (%s), ",
4332 p, info_type((StgClosure *)p));
4334 fputc('\n', stderr);
4337 STATIC_INLINE rtsBool
4338 maybeLarge(StgClosure *closure)
4340 StgInfoTable *info = get_itbl(closure);
4342 /* closure types that may be found on the new_large_objects list;
4343 see scavenge_large */
4344 return (info->type == MUT_ARR_PTRS ||
4345 info->type == MUT_ARR_PTRS_FROZEN ||
4346 info->type == TSO ||
4347 info->type == ARR_WORDS);