1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team 1998-2003
5 * Generational garbage collector
7 * ---------------------------------------------------------------------------*/
9 #include "PosixSource.h"
14 #include "OSThreads.h"
16 #include "LdvProfile.h"
21 #include "BlockAlloc.h"
27 #include "ParTicky.h" // ToDo: move into Rts.h
28 #include "GCCompact.h"
29 #include "RtsSignals.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 // Turn off inlining when debugging - it obfuscates things
53 # define STATIC_INLINE static
56 /* STATIC OBJECT LIST.
59 * We maintain a linked list of static objects that are still live.
60 * The requirements for this list are:
62 * - we need to scan the list while adding to it, in order to
63 * scavenge all the static objects (in the same way that
64 * breadth-first scavenging works for dynamic objects).
66 * - we need to be able to tell whether an object is already on
67 * the list, to break loops.
69 * Each static object has a "static link field", which we use for
70 * linking objects on to the list. We use a stack-type list, consing
71 * objects on the front as they are added (this means that the
72 * scavenge phase is depth-first, not breadth-first, but that
75 * A separate list is kept for objects that have been scavenged
76 * already - this is so that we can zero all the marks afterwards.
78 * An object is on the list if its static link field is non-zero; this
79 * means that we have to mark the end of the list with '1', not NULL.
81 * Extra notes for generational GC:
83 * Each generation has a static object list associated with it. When
84 * collecting generations up to N, we treat the static object lists
85 * from generations > N as roots.
87 * We build up a static object list while collecting generations 0..N,
88 * which is then appended to the static object list of generation N+1.
90 static StgClosure* static_objects; // live static objects
91 StgClosure* scavenged_static_objects; // static objects scavenged so far
93 /* N is the oldest generation being collected, where the generations
94 * are numbered starting at 0. A major GC (indicated by the major_gc
95 * flag) is when we're collecting all generations. We only attempt to
96 * deal with static objects and GC CAFs when doing a major GC.
99 static rtsBool major_gc;
101 /* Youngest generation that objects should be evacuated to in
102 * evacuate(). (Logically an argument to evacuate, but it's static
103 * a lot of the time so we optimise it into a global variable).
107 /* Whether to do eager promotion or not.
109 static rtsBool eager_promotion;
113 StgWeak *old_weak_ptr_list; // also pending finaliser list
115 /* Which stage of processing various kinds of weak pointer are we at?
116 * (see traverse_weak_ptr_list() below for discussion).
118 typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage;
119 static WeakStage weak_stage;
121 /* List of all threads during GC
123 static StgTSO *old_all_threads;
124 StgTSO *resurrected_threads;
126 /* Flag indicating failure to evacuate an object to the desired
129 static rtsBool failed_to_evac;
131 /* Saved nursery (used for 2-space collector only)
133 static bdescr *saved_nursery;
134 static nat saved_n_blocks;
136 /* Data used for allocation area sizing.
138 static lnat new_blocks; // blocks allocated during this GC
139 static lnat new_scavd_blocks; // ditto, but depth-first blocks
140 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC
142 /* Used to avoid long recursion due to selector thunks
144 static lnat thunk_selector_depth = 0;
145 #define MAX_THUNK_SELECTOR_DEPTH 8
155 /* -----------------------------------------------------------------------------
156 Static function declarations
157 -------------------------------------------------------------------------- */
159 static bdescr * gc_alloc_block ( step *stp );
160 static void mark_root ( StgClosure **root );
162 // Use a register argument for evacuate, if available.
164 #define REGPARM1 __attribute__((regparm(1)))
169 REGPARM1 static StgClosure * evacuate (StgClosure *q);
171 static void zero_static_object_list ( StgClosure* first_static );
173 static rtsBool traverse_weak_ptr_list ( void );
174 static void mark_weak_ptr_list ( StgWeak **list );
175 static rtsBool traverse_blackhole_queue ( void );
177 static StgClosure * eval_thunk_selector ( nat field, StgSelector * p );
180 static void scavenge ( step * );
181 static void scavenge_mark_stack ( void );
182 static void scavenge_stack ( StgPtr p, StgPtr stack_end );
183 static rtsBool scavenge_one ( StgPtr p );
184 static void scavenge_large ( step * );
185 static void scavenge_static ( void );
186 static void scavenge_mutable_list ( generation *g );
188 static void scavenge_large_bitmap ( StgPtr p,
189 StgLargeBitmap *large_bitmap,
192 #if 0 && defined(DEBUG)
193 static void gcCAFs ( void );
196 /* -----------------------------------------------------------------------------
197 inline functions etc. for dealing with the mark bitmap & stack.
198 -------------------------------------------------------------------------- */
200 #define MARK_STACK_BLOCKS 4
202 static bdescr *mark_stack_bdescr;
203 static StgPtr *mark_stack;
204 static StgPtr *mark_sp;
205 static StgPtr *mark_splim;
207 // Flag and pointers used for falling back to a linear scan when the
208 // mark stack overflows.
209 static rtsBool mark_stack_overflowed;
210 static bdescr *oldgen_scan_bd;
211 static StgPtr oldgen_scan;
213 STATIC_INLINE rtsBool
214 mark_stack_empty(void)
216 return mark_sp == mark_stack;
219 STATIC_INLINE rtsBool
220 mark_stack_full(void)
222 return mark_sp >= mark_splim;
226 reset_mark_stack(void)
228 mark_sp = mark_stack;
232 push_mark_stack(StgPtr p)
243 /* -----------------------------------------------------------------------------
244 Allocate a new to-space block in the given step.
245 -------------------------------------------------------------------------- */
248 gc_alloc_block(step *stp)
250 bdescr *bd = allocBlock();
251 bd->gen_no = stp->gen_no;
255 // blocks in to-space in generations up to and including N
256 // get the BF_EVACUATED flag.
257 if (stp->gen_no <= N) {
258 bd->flags = BF_EVACUATED;
263 // Start a new to-space block, chain it on after the previous one.
264 if (stp->hp_bd != NULL) {
265 stp->hp_bd->free = stp->hp;
266 stp->hp_bd->link = bd;
271 stp->hpLim = stp->hp + BLOCK_SIZE_W;
280 gc_alloc_scavd_block(step *stp)
282 bdescr *bd = allocBlock();
283 bd->gen_no = stp->gen_no;
286 // blocks in to-space in generations up to and including N
287 // get the BF_EVACUATED flag.
288 if (stp->gen_no <= N) {
289 bd->flags = BF_EVACUATED;
294 bd->link = stp->blocks;
297 if (stp->scavd_hp != NULL) {
298 Bdescr(stp->scavd_hp)->free = stp->scavd_hp;
300 stp->scavd_hp = bd->start;
301 stp->scavd_hpLim = stp->scavd_hp + BLOCK_SIZE_W;
309 /* -----------------------------------------------------------------------------
312 Rough outline of the algorithm: for garbage collecting generation N
313 (and all younger generations):
315 - follow all pointers in the root set. the root set includes all
316 mutable objects in all generations (mutable_list).
318 - for each pointer, evacuate the object it points to into either
320 + to-space of the step given by step->to, which is the next
321 highest step in this generation or the first step in the next
322 generation if this is the last step.
324 + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
325 When we evacuate an object we attempt to evacuate
326 everything it points to into the same generation - this is
327 achieved by setting evac_gen to the desired generation. If
328 we can't do this, then an entry in the mut list has to
329 be made for the cross-generation pointer.
331 + if the object is already in a generation > N, then leave
334 - repeatedly scavenge to-space from each step in each generation
335 being collected until no more objects can be evacuated.
337 - free from-space in each step, and set from-space = to-space.
339 Locks held: all capabilities are held throughout GarbageCollect().
341 -------------------------------------------------------------------------- */
344 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
348 lnat live, allocated, copied = 0, scavd_copied = 0;
349 lnat oldgen_saved_blocks = 0;
355 CostCentreStack *prev_CCS;
358 #if defined(DEBUG) && defined(GRAN)
359 IF_DEBUG(gc, debugBelch("@@ Starting garbage collection at %ld (%lx)\n",
363 #if defined(RTS_USER_SIGNALS)
368 // tell the STM to discard any cached closures its hoping to re-use
371 // tell the stats department that we've started a GC
375 // check for memory leaks if DEBUG is on
385 // Init stats and print par specific (timing) info
386 PAR_TICKY_PAR_START();
388 // attribute any costs to CCS_GC
394 /* Approximate how much we allocated.
395 * Todo: only when generating stats?
397 allocated = calcAllocated();
399 /* Figure out which generation to collect
401 if (force_major_gc) {
402 N = RtsFlags.GcFlags.generations - 1;
406 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
407 if (generations[g].steps[0].n_blocks +
408 generations[g].steps[0].n_large_blocks
409 >= generations[g].max_blocks) {
413 major_gc = (N == RtsFlags.GcFlags.generations-1);
416 #ifdef RTS_GTK_FRONTPANEL
417 if (RtsFlags.GcFlags.frontpanel) {
418 updateFrontPanelBeforeGC(N);
422 // check stack sanity *before* GC (ToDo: check all threads)
424 // ToDo!: check sanity IF_DEBUG(sanity, checkTSOsSanity());
426 IF_DEBUG(sanity, checkFreeListSanity());
428 /* Initialise the static object lists
430 static_objects = END_OF_STATIC_LIST;
431 scavenged_static_objects = END_OF_STATIC_LIST;
433 /* Save the nursery if we're doing a two-space collection.
434 * g0s0->blocks will be used for to-space, so we need to get the
435 * nursery out of the way.
437 if (RtsFlags.GcFlags.generations == 1) {
438 saved_nursery = g0s0->blocks;
439 saved_n_blocks = g0s0->n_blocks;
444 /* Keep a count of how many new blocks we allocated during this GC
445 * (used for resizing the allocation area, later).
448 new_scavd_blocks = 0;
450 // Initialise to-space in all the generations/steps that we're
453 for (g = 0; g <= N; g++) {
455 // throw away the mutable list. Invariant: the mutable list
456 // always has at least one block; this means we can avoid a check for
457 // NULL in recordMutable().
459 freeChain(generations[g].mut_list);
460 generations[g].mut_list = allocBlock();
461 for (i = 0; i < n_capabilities; i++) {
462 freeChain(capabilities[i].mut_lists[g]);
463 capabilities[i].mut_lists[g] = allocBlock();
467 for (s = 0; s < generations[g].n_steps; s++) {
469 // generation 0, step 0 doesn't need to-space
470 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
474 stp = &generations[g].steps[s];
475 ASSERT(stp->gen_no == g);
477 // start a new to-space for this step.
478 stp->old_blocks = stp->blocks;
479 stp->n_old_blocks = stp->n_blocks;
481 // allocate the first to-space block; extra blocks will be
482 // chained on as necessary.
484 bd = gc_alloc_block(stp);
487 stp->scan = bd->start;
490 // allocate a block for "already scavenged" objects. This goes
491 // on the front of the stp->blocks list, so it won't be
492 // traversed by the scavenging sweep.
493 gc_alloc_scavd_block(stp);
495 // initialise the large object queues.
496 stp->new_large_objects = NULL;
497 stp->scavenged_large_objects = NULL;
498 stp->n_scavenged_large_blocks = 0;
500 // mark the large objects as not evacuated yet
501 for (bd = stp->large_objects; bd; bd = bd->link) {
502 bd->flags &= ~BF_EVACUATED;
505 // for a compacted step, we need to allocate the bitmap
506 if (stp->is_compacted) {
507 nat bitmap_size; // in bytes
508 bdescr *bitmap_bdescr;
511 bitmap_size = stp->n_old_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
513 if (bitmap_size > 0) {
514 bitmap_bdescr = allocGroup((lnat)BLOCK_ROUND_UP(bitmap_size)
516 stp->bitmap = bitmap_bdescr;
517 bitmap = bitmap_bdescr->start;
519 IF_DEBUG(gc, debugBelch("bitmap_size: %d, bitmap: %p",
520 bitmap_size, bitmap););
522 // don't forget to fill it with zeros!
523 memset(bitmap, 0, bitmap_size);
525 // For each block in this step, point to its bitmap from the
527 for (bd=stp->old_blocks; bd != NULL; bd = bd->link) {
528 bd->u.bitmap = bitmap;
529 bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
531 // Also at this point we set the BF_COMPACTED flag
532 // for this block. The invariant is that
533 // BF_COMPACTED is always unset, except during GC
534 // when it is set on those blocks which will be
536 bd->flags |= BF_COMPACTED;
543 /* make sure the older generations have at least one block to
544 * allocate into (this makes things easier for copy(), see below).
546 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
547 for (s = 0; s < generations[g].n_steps; s++) {
548 stp = &generations[g].steps[s];
549 if (stp->hp_bd == NULL) {
550 ASSERT(stp->blocks == NULL);
551 bd = gc_alloc_block(stp);
555 if (stp->scavd_hp == NULL) {
556 gc_alloc_scavd_block(stp);
559 /* Set the scan pointer for older generations: remember we
560 * still have to scavenge objects that have been promoted. */
562 stp->scan_bd = stp->hp_bd;
563 stp->new_large_objects = NULL;
564 stp->scavenged_large_objects = NULL;
565 stp->n_scavenged_large_blocks = 0;
568 /* Move the private mutable lists from each capability onto the
569 * main mutable list for the generation.
571 for (i = 0; i < n_capabilities; i++) {
572 for (bd = capabilities[i].mut_lists[g];
573 bd->link != NULL; bd = bd->link) {
576 bd->link = generations[g].mut_list;
577 generations[g].mut_list = capabilities[i].mut_lists[g];
578 capabilities[i].mut_lists[g] = allocBlock();
582 /* Allocate a mark stack if we're doing a major collection.
585 mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
586 mark_stack = (StgPtr *)mark_stack_bdescr->start;
587 mark_sp = mark_stack;
588 mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
590 mark_stack_bdescr = NULL;
593 eager_promotion = rtsTrue; // for now
595 /* -----------------------------------------------------------------------
596 * follow all the roots that we know about:
597 * - mutable lists from each generation > N
598 * we want to *scavenge* these roots, not evacuate them: they're not
599 * going to move in this GC.
600 * Also: do them in reverse generation order. This is because we
601 * often want to promote objects that are pointed to by older
602 * generations early, so we don't have to repeatedly copy them.
603 * Doing the generations in reverse order ensures that we don't end
604 * up in the situation where we want to evac an object to gen 3 and
605 * it has already been evaced to gen 2.
609 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
610 generations[g].saved_mut_list = generations[g].mut_list;
611 generations[g].mut_list = allocBlock();
612 // mut_list always has at least one block.
615 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
616 IF_PAR_DEBUG(verbose, printMutableList(&generations[g]));
617 scavenge_mutable_list(&generations[g]);
619 for (st = generations[g].n_steps-1; st >= 0; st--) {
620 scavenge(&generations[g].steps[st]);
625 /* follow roots from the CAF list (used by GHCi)
630 /* follow all the roots that the application knows about.
633 get_roots(mark_root);
636 /* And don't forget to mark the TSO if we got here direct from
638 /* Not needed in a seq version?
640 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
644 // Mark the entries in the GALA table of the parallel system
645 markLocalGAs(major_gc);
646 // Mark all entries on the list of pending fetches
647 markPendingFetches(major_gc);
650 /* Mark the weak pointer list, and prepare to detect dead weak
653 mark_weak_ptr_list(&weak_ptr_list);
654 old_weak_ptr_list = weak_ptr_list;
655 weak_ptr_list = NULL;
656 weak_stage = WeakPtrs;
658 /* The all_threads list is like the weak_ptr_list.
659 * See traverse_weak_ptr_list() for the details.
661 old_all_threads = all_threads;
662 all_threads = END_TSO_QUEUE;
663 resurrected_threads = END_TSO_QUEUE;
665 /* Mark the stable pointer table.
667 markStablePtrTable(mark_root);
669 /* -------------------------------------------------------------------------
670 * Repeatedly scavenge all the areas we know about until there's no
671 * more scavenging to be done.
678 // scavenge static objects
679 if (major_gc && static_objects != END_OF_STATIC_LIST) {
680 IF_DEBUG(sanity, checkStaticObjects(static_objects));
684 /* When scavenging the older generations: Objects may have been
685 * evacuated from generations <= N into older generations, and we
686 * need to scavenge these objects. We're going to try to ensure that
687 * any evacuations that occur move the objects into at least the
688 * same generation as the object being scavenged, otherwise we
689 * have to create new entries on the mutable list for the older
693 // scavenge each step in generations 0..maxgen
699 // scavenge objects in compacted generation
700 if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
701 (mark_stack_bdescr != NULL && !mark_stack_empty())) {
702 scavenge_mark_stack();
706 for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
707 for (st = generations[gen].n_steps; --st >= 0; ) {
708 if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
711 stp = &generations[gen].steps[st];
713 if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
718 if (stp->new_large_objects != NULL) {
727 // if any blackholes are alive, make the threads that wait on
729 if (traverse_blackhole_queue())
732 if (flag) { goto loop; }
734 // must be last... invariant is that everything is fully
735 // scavenged at this point.
736 if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something
741 /* Update the pointers from the task list - these are
742 * treated as weak pointers because we want to allow a main thread
743 * to get a BlockedOnDeadMVar exception in the same way as any other
744 * thread. Note that the threads should all have been retained by
745 * GC by virtue of being on the all_threads list, we're just
746 * updating pointers here.
751 for (task = all_tasks; task != NULL; task = task->all_link) {
752 if (!task->stopped && task->tso) {
753 ASSERT(task->tso->bound == task);
754 tso = (StgTSO *) isAlive((StgClosure *)task->tso);
756 barf("task %p: main thread %d has been GC'd",
770 // Reconstruct the Global Address tables used in GUM
771 rebuildGAtables(major_gc);
772 IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
775 // Now see which stable names are still alive.
778 // Tidy the end of the to-space chains
779 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
780 for (s = 0; s < generations[g].n_steps; s++) {
781 stp = &generations[g].steps[s];
782 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
783 ASSERT(Bdescr(stp->hp) == stp->hp_bd);
784 stp->hp_bd->free = stp->hp;
785 Bdescr(stp->scavd_hp)->free = stp->scavd_hp;
791 // We call processHeapClosureForDead() on every closure destroyed during
792 // the current garbage collection, so we invoke LdvCensusForDead().
793 if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
794 || RtsFlags.ProfFlags.bioSelector != NULL)
798 // NO MORE EVACUATION AFTER THIS POINT!
799 // Finally: compaction of the oldest generation.
800 if (major_gc && oldest_gen->steps[0].is_compacted) {
801 // save number of blocks for stats
802 oldgen_saved_blocks = oldest_gen->steps[0].n_old_blocks;
806 IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
808 /* run through all the generations/steps and tidy up
810 copied = new_blocks * BLOCK_SIZE_W;
811 scavd_copied = new_scavd_blocks * BLOCK_SIZE_W;
812 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
815 generations[g].collections++; // for stats
818 // Count the mutable list as bytes "copied" for the purposes of
819 // stats. Every mutable list is copied during every GC.
821 nat mut_list_size = 0;
822 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
823 mut_list_size += bd->free - bd->start;
825 copied += mut_list_size;
827 IF_DEBUG(gc, debugBelch("mut_list_size: %ld (%d vars, %d arrays, %d others)\n", mut_list_size * sizeof(W_), mutlist_MUTVARS, mutlist_MUTARRS, mutlist_OTHERS));
830 for (s = 0; s < generations[g].n_steps; s++) {
832 stp = &generations[g].steps[s];
834 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
835 // stats information: how much we copied
837 copied -= stp->hp_bd->start + BLOCK_SIZE_W -
839 scavd_copied -= (P_)(BLOCK_ROUND_UP(stp->scavd_hp)) - stp->scavd_hp;
843 // for generations we collected...
846 /* free old memory and shift to-space into from-space for all
847 * the collected steps (except the allocation area). These
848 * freed blocks will probaby be quickly recycled.
850 if (!(g == 0 && s == 0)) {
851 if (stp->is_compacted) {
852 // for a compacted step, just shift the new to-space
853 // onto the front of the now-compacted existing blocks.
854 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
855 bd->flags &= ~BF_EVACUATED; // now from-space
857 // tack the new blocks on the end of the existing blocks
858 if (stp->old_blocks != NULL) {
859 for (bd = stp->old_blocks; bd != NULL; bd = next) {
860 // NB. this step might not be compacted next
861 // time, so reset the BF_COMPACTED flags.
862 // They are set before GC if we're going to
863 // compact. (search for BF_COMPACTED above).
864 bd->flags &= ~BF_COMPACTED;
867 bd->link = stp->blocks;
870 stp->blocks = stp->old_blocks;
872 // add the new blocks to the block tally
873 stp->n_blocks += stp->n_old_blocks;
874 ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
876 freeChain(stp->old_blocks);
877 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
878 bd->flags &= ~BF_EVACUATED; // now from-space
881 stp->old_blocks = NULL;
882 stp->n_old_blocks = 0;
885 /* LARGE OBJECTS. The current live large objects are chained on
886 * scavenged_large, having been moved during garbage
887 * collection from large_objects. Any objects left on
888 * large_objects list are therefore dead, so we free them here.
890 for (bd = stp->large_objects; bd != NULL; bd = next) {
896 // update the count of blocks used by large objects
897 for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
898 bd->flags &= ~BF_EVACUATED;
900 stp->large_objects = stp->scavenged_large_objects;
901 stp->n_large_blocks = stp->n_scavenged_large_blocks;
904 // for older generations...
906 /* For older generations, we need to append the
907 * scavenged_large_object list (i.e. large objects that have been
908 * promoted during this GC) to the large_object list for that step.
910 for (bd = stp->scavenged_large_objects; bd; bd = next) {
912 bd->flags &= ~BF_EVACUATED;
913 dbl_link_onto(bd, &stp->large_objects);
916 // add the new blocks we promoted during this GC
917 stp->n_large_blocks += stp->n_scavenged_large_blocks;
922 /* Reset the sizes of the older generations when we do a major
925 * CURRENT STRATEGY: make all generations except zero the same size.
926 * We have to stay within the maximum heap size, and leave a certain
927 * percentage of the maximum heap size available to allocate into.
929 if (major_gc && RtsFlags.GcFlags.generations > 1) {
930 nat live, size, min_alloc;
931 nat max = RtsFlags.GcFlags.maxHeapSize;
932 nat gens = RtsFlags.GcFlags.generations;
934 // live in the oldest generations
935 live = oldest_gen->steps[0].n_blocks +
936 oldest_gen->steps[0].n_large_blocks;
938 // default max size for all generations except zero
939 size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
940 RtsFlags.GcFlags.minOldGenSize);
942 // minimum size for generation zero
943 min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
944 RtsFlags.GcFlags.minAllocAreaSize);
946 // Auto-enable compaction when the residency reaches a
947 // certain percentage of the maximum heap size (default: 30%).
948 if (RtsFlags.GcFlags.generations > 1 &&
949 (RtsFlags.GcFlags.compact ||
951 oldest_gen->steps[0].n_blocks >
952 (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
953 oldest_gen->steps[0].is_compacted = 1;
954 // debugBelch("compaction: on\n", live);
956 oldest_gen->steps[0].is_compacted = 0;
957 // debugBelch("compaction: off\n", live);
960 // if we're going to go over the maximum heap size, reduce the
961 // size of the generations accordingly. The calculation is
962 // different if compaction is turned on, because we don't need
963 // to double the space required to collect the old generation.
966 // this test is necessary to ensure that the calculations
967 // below don't have any negative results - we're working
968 // with unsigned values here.
969 if (max < min_alloc) {
973 if (oldest_gen->steps[0].is_compacted) {
974 if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
975 size = (max - min_alloc) / ((gens - 1) * 2 - 1);
978 if ( (size * (gens - 1) * 2) + min_alloc > max ) {
979 size = (max - min_alloc) / ((gens - 1) * 2);
989 debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live,
990 min_alloc, size, max);
993 for (g = 0; g < gens; g++) {
994 generations[g].max_blocks = size;
998 // Guess the amount of live data for stats.
1001 /* Free the small objects allocated via allocate(), since this will
1002 * all have been copied into G0S1 now.
1004 if (small_alloc_list != NULL) {
1005 freeChain(small_alloc_list);
1007 small_alloc_list = NULL;
1011 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
1013 // Start a new pinned_object_block
1014 pinned_object_block = NULL;
1016 /* Free the mark stack.
1018 if (mark_stack_bdescr != NULL) {
1019 freeGroup(mark_stack_bdescr);
1022 /* Free any bitmaps.
1024 for (g = 0; g <= N; g++) {
1025 for (s = 0; s < generations[g].n_steps; s++) {
1026 stp = &generations[g].steps[s];
1027 if (stp->bitmap != NULL) {
1028 freeGroup(stp->bitmap);
1034 /* Two-space collector:
1035 * Free the old to-space, and estimate the amount of live data.
1037 if (RtsFlags.GcFlags.generations == 1) {
1040 if (g0s0->old_blocks != NULL) {
1041 freeChain(g0s0->old_blocks);
1043 for (bd = g0s0->blocks; bd != NULL; bd = bd->link) {
1044 bd->flags = 0; // now from-space
1046 g0s0->old_blocks = g0s0->blocks;
1047 g0s0->n_old_blocks = g0s0->n_blocks;
1048 g0s0->blocks = saved_nursery;
1049 g0s0->n_blocks = saved_n_blocks;
1051 /* For a two-space collector, we need to resize the nursery. */
1053 /* set up a new nursery. Allocate a nursery size based on a
1054 * function of the amount of live data (by default a factor of 2)
1055 * Use the blocks from the old nursery if possible, freeing up any
1058 * If we get near the maximum heap size, then adjust our nursery
1059 * size accordingly. If the nursery is the same size as the live
1060 * data (L), then we need 3L bytes. We can reduce the size of the
1061 * nursery to bring the required memory down near 2L bytes.
1063 * A normal 2-space collector would need 4L bytes to give the same
1064 * performance we get from 3L bytes, reducing to the same
1065 * performance at 2L bytes.
1067 blocks = g0s0->n_old_blocks;
1069 if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
1070 blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
1071 RtsFlags.GcFlags.maxHeapSize ) {
1072 long adjusted_blocks; // signed on purpose
1075 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
1076 IF_DEBUG(gc, debugBelch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
1077 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
1078 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
1081 blocks = adjusted_blocks;
1084 blocks *= RtsFlags.GcFlags.oldGenFactor;
1085 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
1086 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1089 resizeNurseries(blocks);
1092 /* Generational collector:
1093 * If the user has given us a suggested heap size, adjust our
1094 * allocation area to make best use of the memory available.
1097 if (RtsFlags.GcFlags.heapSizeSuggestion) {
1099 nat needed = calcNeeded(); // approx blocks needed at next GC
1101 /* Guess how much will be live in generation 0 step 0 next time.
1102 * A good approximation is obtained by finding the
1103 * percentage of g0s0 that was live at the last minor GC.
1106 g0s0_pcnt_kept = (new_blocks * 100) / countNurseryBlocks();
1109 /* Estimate a size for the allocation area based on the
1110 * information available. We might end up going slightly under
1111 * or over the suggested heap size, but we should be pretty
1114 * Formula: suggested - needed
1115 * ----------------------------
1116 * 1 + g0s0_pcnt_kept/100
1118 * where 'needed' is the amount of memory needed at the next
1119 * collection for collecting all steps except g0s0.
1122 (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
1123 (100 + (long)g0s0_pcnt_kept);
1125 if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
1126 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1129 resizeNurseries((nat)blocks);
1132 // we might have added extra large blocks to the nursery, so
1133 // resize back to minAllocAreaSize again.
1134 resizeNurseriesFixed(RtsFlags.GcFlags.minAllocAreaSize);
1138 // mark the garbage collected CAFs as dead
1139 #if 0 && defined(DEBUG) // doesn't work at the moment
1140 if (major_gc) { gcCAFs(); }
1144 // resetStaticObjectForRetainerProfiling() must be called before
1146 resetStaticObjectForRetainerProfiling();
1149 // zero the scavenged static object list
1151 zero_static_object_list(scavenged_static_objects);
1154 // Reset the nursery
1157 // start any pending finalizers
1159 scheduleFinalizers(last_free_capability, old_weak_ptr_list);
1162 // send exceptions to any threads which were about to die
1164 resurrectThreads(resurrected_threads);
1167 // Update the stable pointer hash table.
1168 updateStablePtrTable(major_gc);
1170 // check sanity after GC
1171 IF_DEBUG(sanity, checkSanity());
1173 // extra GC trace info
1174 IF_DEBUG(gc, statDescribeGens());
1177 // symbol-table based profiling
1178 /* heapCensus(to_blocks); */ /* ToDo */
1181 // restore enclosing cost centre
1187 // check for memory leaks if DEBUG is on
1191 #ifdef RTS_GTK_FRONTPANEL
1192 if (RtsFlags.GcFlags.frontpanel) {
1193 updateFrontPanelAfterGC( N, live );
1197 // ok, GC over: tell the stats department what happened.
1198 stat_endGC(allocated, live, copied, scavd_copied, N);
1200 #if defined(RTS_USER_SIGNALS)
1201 // unblock signals again
1202 unblockUserSignals();
1211 /* -----------------------------------------------------------------------------
1214 traverse_weak_ptr_list is called possibly many times during garbage
1215 collection. It returns a flag indicating whether it did any work
1216 (i.e. called evacuate on any live pointers).
1218 Invariant: traverse_weak_ptr_list is called when the heap is in an
1219 idempotent state. That means that there are no pending
1220 evacuate/scavenge operations. This invariant helps the weak
1221 pointer code decide which weak pointers are dead - if there are no
1222 new live weak pointers, then all the currently unreachable ones are
1225 For generational GC: we just don't try to finalize weak pointers in
1226 older generations than the one we're collecting. This could
1227 probably be optimised by keeping per-generation lists of weak
1228 pointers, but for a few weak pointers this scheme will work.
1230 There are three distinct stages to processing weak pointers:
1232 - weak_stage == WeakPtrs
1234 We process all the weak pointers whos keys are alive (evacuate
1235 their values and finalizers), and repeat until we can find no new
1236 live keys. If no live keys are found in this pass, then we
1237 evacuate the finalizers of all the dead weak pointers in order to
1240 - weak_stage == WeakThreads
1242 Now, we discover which *threads* are still alive. Pointers to
1243 threads from the all_threads and main thread lists are the
1244 weakest of all: a pointers from the finalizer of a dead weak
1245 pointer can keep a thread alive. Any threads found to be unreachable
1246 are evacuated and placed on the resurrected_threads list so we
1247 can send them a signal later.
1249 - weak_stage == WeakDone
1251 No more evacuation is done.
1253 -------------------------------------------------------------------------- */
1256 traverse_weak_ptr_list(void)
1258 StgWeak *w, **last_w, *next_w;
1260 rtsBool flag = rtsFalse;
1262 switch (weak_stage) {
1268 /* doesn't matter where we evacuate values/finalizers to, since
1269 * these pointers are treated as roots (iff the keys are alive).
1273 last_w = &old_weak_ptr_list;
1274 for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1276 /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1277 * called on a live weak pointer object. Just remove it.
1279 if (w->header.info == &stg_DEAD_WEAK_info) {
1280 next_w = ((StgDeadWeak *)w)->link;
1285 switch (get_itbl(w)->type) {
1288 next_w = (StgWeak *)((StgEvacuated *)w)->evacuee;
1293 /* Now, check whether the key is reachable.
1295 new = isAlive(w->key);
1298 // evacuate the value and finalizer
1299 w->value = evacuate(w->value);
1300 w->finalizer = evacuate(w->finalizer);
1301 // remove this weak ptr from the old_weak_ptr list
1303 // and put it on the new weak ptr list
1305 w->link = weak_ptr_list;
1308 IF_DEBUG(weak, debugBelch("Weak pointer still alive at %p -> %p",
1313 last_w = &(w->link);
1319 barf("traverse_weak_ptr_list: not WEAK");
1323 /* If we didn't make any changes, then we can go round and kill all
1324 * the dead weak pointers. The old_weak_ptr list is used as a list
1325 * of pending finalizers later on.
1327 if (flag == rtsFalse) {
1328 for (w = old_weak_ptr_list; w; w = w->link) {
1329 w->finalizer = evacuate(w->finalizer);
1332 // Next, move to the WeakThreads stage after fully
1333 // scavenging the finalizers we've just evacuated.
1334 weak_stage = WeakThreads;
1340 /* Now deal with the all_threads list, which behaves somewhat like
1341 * the weak ptr list. If we discover any threads that are about to
1342 * become garbage, we wake them up and administer an exception.
1345 StgTSO *t, *tmp, *next, **prev;
1347 prev = &old_all_threads;
1348 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1350 tmp = (StgTSO *)isAlive((StgClosure *)t);
1356 ASSERT(get_itbl(t)->type == TSO);
1357 switch (t->what_next) {
1358 case ThreadRelocated:
1363 case ThreadComplete:
1364 // finshed or died. The thread might still be alive, but we
1365 // don't keep it on the all_threads list. Don't forget to
1366 // stub out its global_link field.
1367 next = t->global_link;
1368 t->global_link = END_TSO_QUEUE;
1376 // not alive (yet): leave this thread on the
1377 // old_all_threads list.
1378 prev = &(t->global_link);
1379 next = t->global_link;
1382 // alive: move this thread onto the all_threads list.
1383 next = t->global_link;
1384 t->global_link = all_threads;
1391 /* If we evacuated any threads, we need to go back to the scavenger.
1393 if (flag) return rtsTrue;
1395 /* And resurrect any threads which were about to become garbage.
1398 StgTSO *t, *tmp, *next;
1399 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1400 next = t->global_link;
1401 tmp = (StgTSO *)evacuate((StgClosure *)t);
1402 tmp->global_link = resurrected_threads;
1403 resurrected_threads = tmp;
1407 /* Finally, we can update the blackhole_queue. This queue
1408 * simply strings together TSOs blocked on black holes, it is
1409 * not intended to keep anything alive. Hence, we do not follow
1410 * pointers on the blackhole_queue until now, when we have
1411 * determined which TSOs are otherwise reachable. We know at
1412 * this point that all TSOs have been evacuated, however.
1416 for (pt = &blackhole_queue; *pt != END_TSO_QUEUE; pt = &((*pt)->link)) {
1417 *pt = (StgTSO *)isAlive((StgClosure *)*pt);
1418 ASSERT(*pt != NULL);
1422 weak_stage = WeakDone; // *now* we're done,
1423 return rtsTrue; // but one more round of scavenging, please
1426 barf("traverse_weak_ptr_list");
1432 /* -----------------------------------------------------------------------------
1435 Threads on this list behave like weak pointers during the normal
1436 phase of garbage collection: if the blackhole is reachable, then
1437 the thread is reachable too.
1438 -------------------------------------------------------------------------- */
1440 traverse_blackhole_queue (void)
1442 StgTSO *prev, *t, *tmp;
1448 for (t = blackhole_queue; t != END_TSO_QUEUE; prev=t, t = t->link) {
1449 if (! (tmp = (StgTSO *)isAlive((StgClosure*)t))) {
1450 if (isAlive(t->block_info.closure)) {
1451 t = (StgTSO *)evacuate((StgClosure *)t);
1452 if (prev) prev->link = t;
1460 /* -----------------------------------------------------------------------------
1461 After GC, the live weak pointer list may have forwarding pointers
1462 on it, because a weak pointer object was evacuated after being
1463 moved to the live weak pointer list. We remove those forwarding
1466 Also, we don't consider weak pointer objects to be reachable, but
1467 we must nevertheless consider them to be "live" and retain them.
1468 Therefore any weak pointer objects which haven't as yet been
1469 evacuated need to be evacuated now.
1470 -------------------------------------------------------------------------- */
1474 mark_weak_ptr_list ( StgWeak **list )
1476 StgWeak *w, **last_w;
1479 for (w = *list; w; w = w->link) {
1480 // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
1481 ASSERT(w->header.info == &stg_DEAD_WEAK_info
1482 || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
1483 w = (StgWeak *)evacuate((StgClosure *)w);
1485 last_w = &(w->link);
1489 /* -----------------------------------------------------------------------------
1490 isAlive determines whether the given closure is still alive (after
1491 a garbage collection) or not. It returns the new address of the
1492 closure if it is alive, or NULL otherwise.
1494 NOTE: Use it before compaction only!
1495 -------------------------------------------------------------------------- */
1499 isAlive(StgClosure *p)
1501 const StgInfoTable *info;
1506 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1509 // ignore static closures
1511 // ToDo: for static closures, check the static link field.
1512 // Problem here is that we sometimes don't set the link field, eg.
1513 // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1515 if (!HEAP_ALLOCED(p)) {
1519 // ignore closures in generations that we're not collecting.
1521 if (bd->gen_no > N) {
1525 // if it's a pointer into to-space, then we're done
1526 if (bd->flags & BF_EVACUATED) {
1530 // large objects use the evacuated flag
1531 if (bd->flags & BF_LARGE) {
1535 // check the mark bit for compacted steps
1536 if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1540 switch (info->type) {
1545 case IND_OLDGEN: // rely on compatible layout with StgInd
1546 case IND_OLDGEN_PERM:
1547 // follow indirections
1548 p = ((StgInd *)p)->indirectee;
1553 return ((StgEvacuated *)p)->evacuee;
1556 if (((StgTSO *)p)->what_next == ThreadRelocated) {
1557 p = (StgClosure *)((StgTSO *)p)->link;
1570 mark_root(StgClosure **root)
1572 *root = evacuate(*root);
1576 upd_evacuee(StgClosure *p, StgClosure *dest)
1578 // not true: (ToDo: perhaps it should be)
1579 // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
1580 SET_INFO(p, &stg_EVACUATED_info);
1581 ((StgEvacuated *)p)->evacuee = dest;
1585 STATIC_INLINE StgClosure *
1586 copy(StgClosure *src, nat size, step *stp)
1592 nat size_org = size;
1595 TICK_GC_WORDS_COPIED(size);
1596 /* Find out where we're going, using the handy "to" pointer in
1597 * the step of the source object. If it turns out we need to
1598 * evacuate to an older generation, adjust it here (see comment
1601 if (stp->gen_no < evac_gen) {
1602 if (eager_promotion) {
1603 stp = &generations[evac_gen].steps[0];
1605 failed_to_evac = rtsTrue;
1609 /* chain a new block onto the to-space for the destination step if
1612 if (stp->hp + size >= stp->hpLim) {
1613 gc_alloc_block(stp);
1618 stp->hp = to + size;
1619 for (i = 0; i < size; i++) { // unroll for small i
1622 upd_evacuee((StgClosure *)from,(StgClosure *)to);
1625 // We store the size of the just evacuated object in the LDV word so that
1626 // the profiler can guess the position of the next object later.
1627 SET_EVACUAEE_FOR_LDV(from, size_org);
1629 return (StgClosure *)to;
1632 // Same as copy() above, except the object will be allocated in memory
1633 // that will not be scavenged. Used for object that have no pointer
1635 STATIC_INLINE StgClosure *
1636 copy_noscav(StgClosure *src, nat size, step *stp)
1642 nat size_org = size;
1645 TICK_GC_WORDS_COPIED(size);
1646 /* Find out where we're going, using the handy "to" pointer in
1647 * the step of the source object. If it turns out we need to
1648 * evacuate to an older generation, adjust it here (see comment
1651 if (stp->gen_no < evac_gen) {
1652 if (eager_promotion) {
1653 stp = &generations[evac_gen].steps[0];
1655 failed_to_evac = rtsTrue;
1659 /* chain a new block onto the to-space for the destination step if
1662 if (stp->scavd_hp + size >= stp->scavd_hpLim) {
1663 gc_alloc_scavd_block(stp);
1668 stp->scavd_hp = to + size;
1669 for (i = 0; i < size; i++) { // unroll for small i
1672 upd_evacuee((StgClosure *)from,(StgClosure *)to);
1675 // We store the size of the just evacuated object in the LDV word so that
1676 // the profiler can guess the position of the next object later.
1677 SET_EVACUAEE_FOR_LDV(from, size_org);
1679 return (StgClosure *)to;
1682 /* Special version of copy() for when we only want to copy the info
1683 * pointer of an object, but reserve some padding after it. This is
1684 * used to optimise evacuation of BLACKHOLEs.
1689 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1694 nat size_to_copy_org = size_to_copy;
1697 TICK_GC_WORDS_COPIED(size_to_copy);
1698 if (stp->gen_no < evac_gen) {
1699 if (eager_promotion) {
1700 stp = &generations[evac_gen].steps[0];
1702 failed_to_evac = rtsTrue;
1706 if (stp->hp + size_to_reserve >= stp->hpLim) {
1707 gc_alloc_block(stp);
1710 for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1715 stp->hp += size_to_reserve;
1716 upd_evacuee(src,(StgClosure *)dest);
1718 // We store the size of the just evacuated object in the LDV word so that
1719 // the profiler can guess the position of the next object later.
1720 // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1722 SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1724 if (size_to_reserve - size_to_copy_org > 0)
1725 LDV_FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1727 return (StgClosure *)dest;
1731 /* -----------------------------------------------------------------------------
1732 Evacuate a large object
1734 This just consists of removing the object from the (doubly-linked)
1735 step->large_objects list, and linking it on to the (singly-linked)
1736 step->new_large_objects list, from where it will be scavenged later.
1738 Convention: bd->flags has BF_EVACUATED set for a large object
1739 that has been evacuated, or unset otherwise.
1740 -------------------------------------------------------------------------- */
1744 evacuate_large(StgPtr p)
1746 bdescr *bd = Bdescr(p);
1749 // object must be at the beginning of the block (or be a ByteArray)
1750 ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1751 (((W_)p & BLOCK_MASK) == 0));
1753 // already evacuated?
1754 if (bd->flags & BF_EVACUATED) {
1755 /* Don't forget to set the failed_to_evac flag if we didn't get
1756 * the desired destination (see comments in evacuate()).
1758 if (bd->gen_no < evac_gen) {
1759 failed_to_evac = rtsTrue;
1760 TICK_GC_FAILED_PROMOTION();
1766 // remove from large_object list
1768 bd->u.back->link = bd->link;
1769 } else { // first object in the list
1770 stp->large_objects = bd->link;
1773 bd->link->u.back = bd->u.back;
1776 /* link it on to the evacuated large object list of the destination step
1779 if (stp->gen_no < evac_gen) {
1780 if (eager_promotion) {
1781 stp = &generations[evac_gen].steps[0];
1783 failed_to_evac = rtsTrue;
1788 bd->gen_no = stp->gen_no;
1789 bd->link = stp->new_large_objects;
1790 stp->new_large_objects = bd;
1791 bd->flags |= BF_EVACUATED;
1794 /* -----------------------------------------------------------------------------
1797 This is called (eventually) for every live object in the system.
1799 The caller to evacuate specifies a desired generation in the
1800 evac_gen global variable. The following conditions apply to
1801 evacuating an object which resides in generation M when we're
1802 collecting up to generation N
1806 else evac to step->to
1808 if M < evac_gen evac to evac_gen, step 0
1810 if the object is already evacuated, then we check which generation
1813 if M >= evac_gen do nothing
1814 if M < evac_gen set failed_to_evac flag to indicate that we
1815 didn't manage to evacuate this object into evac_gen.
1820 evacuate() is the single most important function performance-wise
1821 in the GC. Various things have been tried to speed it up, but as
1822 far as I can tell the code generated by gcc 3.2 with -O2 is about
1823 as good as it's going to get. We pass the argument to evacuate()
1824 in a register using the 'regparm' attribute (see the prototype for
1825 evacuate() near the top of this file).
1827 Changing evacuate() to take an (StgClosure **) rather than
1828 returning the new pointer seems attractive, because we can avoid
1829 writing back the pointer when it hasn't changed (eg. for a static
1830 object, or an object in a generation > N). However, I tried it and
1831 it doesn't help. One reason is that the (StgClosure **) pointer
1832 gets spilled to the stack inside evacuate(), resulting in far more
1833 extra reads/writes than we save.
1834 -------------------------------------------------------------------------- */
1836 REGPARM1 static StgClosure *
1837 evacuate(StgClosure *q)
1844 const StgInfoTable *info;
1847 ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
1849 if (!HEAP_ALLOCED(q)) {
1851 if (!major_gc) return q;
1854 switch (info->type) {
1857 if (info->srt_bitmap != 0 &&
1858 *THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1859 *THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1860 static_objects = (StgClosure *)q;
1865 if (info->srt_bitmap != 0 &&
1866 *FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1867 *FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1868 static_objects = (StgClosure *)q;
1873 /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1874 * on the CAF list, so don't do anything with it here (we'll
1875 * scavenge it later).
1877 if (((StgIndStatic *)q)->saved_info == NULL
1878 && *IND_STATIC_LINK((StgClosure *)q) == NULL) {
1879 *IND_STATIC_LINK((StgClosure *)q) = static_objects;
1880 static_objects = (StgClosure *)q;
1885 if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
1886 *STATIC_LINK(info,(StgClosure *)q) = static_objects;
1887 static_objects = (StgClosure *)q;
1891 case CONSTR_INTLIKE:
1892 case CONSTR_CHARLIKE:
1893 case CONSTR_NOCAF_STATIC:
1894 /* no need to put these on the static linked list, they don't need
1900 barf("evacuate(static): strange closure type %d", (int)(info->type));
1906 if (bd->gen_no > N) {
1907 /* Can't evacuate this object, because it's in a generation
1908 * older than the ones we're collecting. Let's hope that it's
1909 * in evac_gen or older, or we will have to arrange to track
1910 * this pointer using the mutable list.
1912 if (bd->gen_no < evac_gen) {
1914 failed_to_evac = rtsTrue;
1915 TICK_GC_FAILED_PROMOTION();
1920 if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
1922 /* pointer into to-space: just return it. This normally
1923 * shouldn't happen, but alllowing it makes certain things
1924 * slightly easier (eg. the mutable list can contain the same
1925 * object twice, for example).
1927 if (bd->flags & BF_EVACUATED) {
1928 if (bd->gen_no < evac_gen) {
1929 failed_to_evac = rtsTrue;
1930 TICK_GC_FAILED_PROMOTION();
1935 /* evacuate large objects by re-linking them onto a different list.
1937 if (bd->flags & BF_LARGE) {
1939 if (info->type == TSO &&
1940 ((StgTSO *)q)->what_next == ThreadRelocated) {
1941 q = (StgClosure *)((StgTSO *)q)->link;
1944 evacuate_large((P_)q);
1948 /* If the object is in a step that we're compacting, then we
1949 * need to use an alternative evacuate procedure.
1951 if (bd->flags & BF_COMPACTED) {
1952 if (!is_marked((P_)q,bd)) {
1954 if (mark_stack_full()) {
1955 mark_stack_overflowed = rtsTrue;
1958 push_mark_stack((P_)q);
1968 switch (info->type) {
1973 return copy(q,sizeW_fromITBL(info),stp);
1977 StgWord w = (StgWord)q->payload[0];
1978 if (q->header.info == Czh_con_info &&
1979 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
1980 (StgChar)w <= MAX_CHARLIKE) {
1981 return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1983 if (q->header.info == Izh_con_info &&
1984 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1985 return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1988 return copy_noscav(q,sizeofW(StgHeader)+1,stp);
1994 return copy(q,sizeofW(StgHeader)+1,stp);
1998 return copy(q,sizeofW(StgThunk)+1,stp);
2003 #ifdef NO_PROMOTE_THUNKS
2004 if (bd->gen_no == 0 &&
2005 bd->step->no != 0 &&
2006 bd->step->no == generations[bd->gen_no].n_steps-1) {
2010 return copy(q,sizeofW(StgThunk)+2,stp);
2017 return copy(q,sizeofW(StgHeader)+2,stp);
2020 return copy_noscav(q,sizeofW(StgHeader)+2,stp);
2023 return copy(q,thunk_sizeW_fromITBL(info),stp);
2028 case IND_OLDGEN_PERM:
2031 return copy(q,sizeW_fromITBL(info),stp);
2034 return copy(q,bco_sizeW((StgBCO *)q),stp);
2037 case SE_CAF_BLACKHOLE:
2040 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
2042 case THUNK_SELECTOR:
2045 const StgInfoTable *info_ptr;
2047 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2048 return copy(q,THUNK_SELECTOR_sizeW(),stp);
2051 // stashed away for LDV profiling, see below
2052 info_ptr = q->header.info;
2054 p = eval_thunk_selector(info->layout.selector_offset,
2058 return copy(q,THUNK_SELECTOR_sizeW(),stp);
2061 // q is still BLACKHOLE'd.
2062 thunk_selector_depth++;
2064 thunk_selector_depth--;
2067 // For the purposes of LDV profiling, we have destroyed
2068 // the original selector thunk.
2069 SET_INFO(q, info_ptr);
2070 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(q);
2073 // Update the THUNK_SELECTOR with an indirection to the
2074 // EVACUATED closure now at p. Why do this rather than
2075 // upd_evacuee(q,p)? Because we have an invariant that an
2076 // EVACUATED closure always points to an object in the
2077 // same or an older generation (required by the short-cut
2078 // test in the EVACUATED case, below).
2079 SET_INFO(q, &stg_IND_info);
2080 ((StgInd *)q)->indirectee = p;
2082 // For the purposes of LDV profiling, we have created an
2084 LDV_RECORD_CREATE(q);
2092 // follow chains of indirections, don't evacuate them
2093 q = ((StgInd*)q)->indirectee;
2105 case CATCH_STM_FRAME:
2106 case CATCH_RETRY_FRAME:
2107 case ATOMICALLY_FRAME:
2108 // shouldn't see these
2109 barf("evacuate: stack frame at %p\n", q);
2112 return copy(q,pap_sizeW((StgPAP*)q),stp);
2115 return copy(q,ap_sizeW((StgAP*)q),stp);
2118 return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
2121 /* Already evacuated, just return the forwarding address.
2122 * HOWEVER: if the requested destination generation (evac_gen) is
2123 * older than the actual generation (because the object was
2124 * already evacuated to a younger generation) then we have to
2125 * set the failed_to_evac flag to indicate that we couldn't
2126 * manage to promote the object to the desired generation.
2129 * Optimisation: the check is fairly expensive, but we can often
2130 * shortcut it if either the required generation is 0, or the
2131 * current object (the EVACUATED) is in a high enough generation.
2132 * We know that an EVACUATED always points to an object in the
2133 * same or an older generation. stp is the lowest step that the
2134 * current object would be evacuated to, so we only do the full
2135 * check if stp is too low.
2137 if (evac_gen > 0 && stp->gen_no < evac_gen) { // optimisation
2138 StgClosure *p = ((StgEvacuated*)q)->evacuee;
2139 if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
2140 failed_to_evac = rtsTrue;
2141 TICK_GC_FAILED_PROMOTION();
2144 return ((StgEvacuated*)q)->evacuee;
2147 // just copy the block
2148 return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp);
2150 case MUT_ARR_PTRS_CLEAN:
2151 case MUT_ARR_PTRS_DIRTY:
2152 case MUT_ARR_PTRS_FROZEN:
2153 case MUT_ARR_PTRS_FROZEN0:
2154 // just copy the block
2155 return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
2159 StgTSO *tso = (StgTSO *)q;
2161 /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
2163 if (tso->what_next == ThreadRelocated) {
2164 q = (StgClosure *)tso->link;
2168 /* To evacuate a small TSO, we need to relocate the update frame
2175 new_tso = (StgTSO *)copyPart((StgClosure *)tso,
2177 sizeofW(StgTSO), stp);
2178 move_TSO(tso, new_tso);
2179 for (p = tso->sp, q = new_tso->sp;
2180 p < tso->stack+tso->stack_size;) {
2184 return (StgClosure *)new_tso;
2191 //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
2192 to = copy(q,BLACKHOLE_sizeW(),stp);
2193 //ToDo: derive size etc from reverted IP
2194 //to = copy(q,size,stp);
2196 debugBelch("@@ evacuate: RBH %p (%s) to %p (%s)",
2197 q, info_type(q), to, info_type(to)));
2202 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE);
2203 to = copy(q,sizeofW(StgBlockedFetch),stp);
2205 debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2206 q, info_type(q), to, info_type(to)));
2213 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2214 to = copy(q,sizeofW(StgFetchMe),stp);
2216 debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2217 q, info_type(q), to, info_type(to)));
2221 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2222 to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2224 debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2225 q, info_type(q), to, info_type(to)));
2230 return copy(q,sizeofW(StgTRecHeader),stp);
2232 case TVAR_WAIT_QUEUE:
2233 return copy(q,sizeofW(StgTVarWaitQueue),stp);
2236 return copy(q,sizeofW(StgTVar),stp);
2239 return copy(q,sizeofW(StgTRecChunk),stp);
2242 barf("evacuate: strange closure type %d", (int)(info->type));
2248 /* -----------------------------------------------------------------------------
2249 Evaluate a THUNK_SELECTOR if possible.
2251 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2252 a closure pointer if we evaluated it and this is the result. Note
2253 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2254 reducing it to HNF, just that we have eliminated the selection.
2255 The result might be another thunk, or even another THUNK_SELECTOR.
2257 If the return value is non-NULL, the original selector thunk has
2258 been BLACKHOLE'd, and should be updated with an indirection or a
2259 forwarding pointer. If the return value is NULL, then the selector
2263 ToDo: the treatment of THUNK_SELECTORS could be improved in the
2264 following way (from a suggestion by Ian Lynagh):
2266 We can have a chain like this:
2270 |-----> sel_0 --> (a,b)
2272 |-----> sel_0 --> ...
2274 and the depth limit means we don't go all the way to the end of the
2275 chain, which results in a space leak. This affects the recursive
2276 call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2277 the recursive call to eval_thunk_selector() in
2278 eval_thunk_selector().
2280 We could eliminate the depth bound in this case, in the following
2283 - traverse the chain once to discover the *value* of the
2284 THUNK_SELECTOR. Mark all THUNK_SELECTORS that we
2285 visit on the way as having been visited already (somehow).
2287 - in a second pass, traverse the chain again updating all
2288 THUNK_SEELCTORS that we find on the way with indirections to
2291 - if we encounter a "marked" THUNK_SELECTOR in a normal
2292 evacuate(), we konw it can't be updated so just evac it.
2294 Program that illustrates the problem:
2297 foo (x:xs) = let (ys, zs) = foo xs
2298 in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2300 main = bar [1..(100000000::Int)]
2301 bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2303 -------------------------------------------------------------------------- */
2305 static inline rtsBool
2306 is_to_space ( StgClosure *p )
2310 bd = Bdescr((StgPtr)p);
2311 if (HEAP_ALLOCED(p) &&
2312 ((bd->flags & BF_EVACUATED)
2313 || ((bd->flags & BF_COMPACTED) &&
2314 is_marked((P_)p,bd)))) {
2322 eval_thunk_selector( nat field, StgSelector * p )
2325 const StgInfoTable *info_ptr;
2326 StgClosure *selectee;
2328 selectee = p->selectee;
2330 // Save the real info pointer (NOTE: not the same as get_itbl()).
2331 info_ptr = p->header.info;
2333 // If the THUNK_SELECTOR is in a generation that we are not
2334 // collecting, then bail out early. We won't be able to save any
2335 // space in any case, and updating with an indirection is trickier
2337 if (Bdescr((StgPtr)p)->gen_no > N) {
2341 // BLACKHOLE the selector thunk, since it is now under evaluation.
2342 // This is important to stop us going into an infinite loop if
2343 // this selector thunk eventually refers to itself.
2344 SET_INFO(p,&stg_BLACKHOLE_info);
2348 // We don't want to end up in to-space, because this causes
2349 // problems when the GC later tries to evacuate the result of
2350 // eval_thunk_selector(). There are various ways this could
2353 // 1. following an IND_STATIC
2355 // 2. when the old generation is compacted, the mark phase updates
2356 // from-space pointers to be to-space pointers, and we can't
2357 // reliably tell which we're following (eg. from an IND_STATIC).
2359 // 3. compacting GC again: if we're looking at a constructor in
2360 // the compacted generation, it might point directly to objects
2361 // in to-space. We must bale out here, otherwise doing the selection
2362 // will result in a to-space pointer being returned.
2364 // (1) is dealt with using a BF_EVACUATED test on the
2365 // selectee. (2) and (3): we can tell if we're looking at an
2366 // object in the compacted generation that might point to
2367 // to-space objects by testing that (a) it is BF_COMPACTED, (b)
2368 // the compacted generation is being collected, and (c) the
2369 // object is marked. Only a marked object may have pointers that
2370 // point to to-space objects, because that happens when
2373 // The to-space test is now embodied in the in_to_space() inline
2374 // function, as it is re-used below.
2376 if (is_to_space(selectee)) {
2380 info = get_itbl(selectee);
2381 switch (info->type) {
2389 case CONSTR_NOCAF_STATIC:
2390 // check that the size is in range
2391 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
2392 info->layout.payload.nptrs));
2394 // Select the right field from the constructor, and check
2395 // that the result isn't in to-space. It might be in
2396 // to-space if, for example, this constructor contains
2397 // pointers to younger-gen objects (and is on the mut-once
2402 q = selectee->payload[field];
2403 if (is_to_space(q)) {
2413 case IND_OLDGEN_PERM:
2415 selectee = ((StgInd *)selectee)->indirectee;
2419 // We don't follow pointers into to-space; the constructor
2420 // has already been evacuated, so we won't save any space
2421 // leaks by evaluating this selector thunk anyhow.
2424 case THUNK_SELECTOR:
2428 // check that we don't recurse too much, re-using the
2429 // depth bound also used in evacuate().
2430 if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2433 thunk_selector_depth++;
2435 val = eval_thunk_selector(info->layout.selector_offset,
2436 (StgSelector *)selectee);
2438 thunk_selector_depth--;
2443 // We evaluated this selector thunk, so update it with
2444 // an indirection. NOTE: we don't use UPD_IND here,
2445 // because we are guaranteed that p is in a generation
2446 // that we are collecting, and we never want to put the
2447 // indirection on a mutable list.
2449 // For the purposes of LDV profiling, we have destroyed
2450 // the original selector thunk.
2451 SET_INFO(p, info_ptr);
2452 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2454 ((StgInd *)selectee)->indirectee = val;
2455 SET_INFO(selectee,&stg_IND_info);
2457 // For the purposes of LDV profiling, we have created an
2459 LDV_RECORD_CREATE(selectee);
2476 case SE_CAF_BLACKHOLE:
2488 // not evaluated yet
2492 barf("eval_thunk_selector: strange selectee %d",
2497 // We didn't manage to evaluate this thunk; restore the old info pointer
2498 SET_INFO(p, info_ptr);
2502 /* -----------------------------------------------------------------------------
2503 move_TSO is called to update the TSO structure after it has been
2504 moved from one place to another.
2505 -------------------------------------------------------------------------- */
2508 move_TSO (StgTSO *src, StgTSO *dest)
2512 // relocate the stack pointer...
2513 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2514 dest->sp = (StgPtr)dest->sp + diff;
2517 /* Similar to scavenge_large_bitmap(), but we don't write back the
2518 * pointers we get back from evacuate().
2521 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2528 bitmap = large_srt->l.bitmap[b];
2529 size = (nat)large_srt->l.size;
2530 p = (StgClosure **)large_srt->srt;
2531 for (i = 0; i < size; ) {
2532 if ((bitmap & 1) != 0) {
2537 if (i % BITS_IN(W_) == 0) {
2539 bitmap = large_srt->l.bitmap[b];
2541 bitmap = bitmap >> 1;
2546 /* evacuate the SRT. If srt_bitmap is zero, then there isn't an
2547 * srt field in the info table. That's ok, because we'll
2548 * never dereference it.
2551 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2556 bitmap = srt_bitmap;
2559 if (bitmap == (StgHalfWord)(-1)) {
2560 scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2564 while (bitmap != 0) {
2565 if ((bitmap & 1) != 0) {
2566 #ifdef ENABLE_WIN32_DLL_SUPPORT
2567 // Special-case to handle references to closures hiding out in DLLs, since
2568 // double indirections required to get at those. The code generator knows
2569 // which is which when generating the SRT, so it stores the (indirect)
2570 // reference to the DLL closure in the table by first adding one to it.
2571 // We check for this here, and undo the addition before evacuating it.
2573 // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2574 // closure that's fixed at link-time, and no extra magic is required.
2575 if ( (unsigned long)(*srt) & 0x1 ) {
2576 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2585 bitmap = bitmap >> 1;
2591 scavenge_thunk_srt(const StgInfoTable *info)
2593 StgThunkInfoTable *thunk_info;
2595 if (!major_gc) return;
2597 thunk_info = itbl_to_thunk_itbl(info);
2598 scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2602 scavenge_fun_srt(const StgInfoTable *info)
2604 StgFunInfoTable *fun_info;
2606 if (!major_gc) return;
2608 fun_info = itbl_to_fun_itbl(info);
2609 scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2612 /* -----------------------------------------------------------------------------
2614 -------------------------------------------------------------------------- */
2617 scavengeTSO (StgTSO *tso)
2619 if ( tso->why_blocked == BlockedOnMVar
2620 || tso->why_blocked == BlockedOnBlackHole
2621 || tso->why_blocked == BlockedOnException
2623 || tso->why_blocked == BlockedOnGA
2624 || tso->why_blocked == BlockedOnGA_NoSend
2627 tso->block_info.closure = evacuate(tso->block_info.closure);
2629 if ( tso->blocked_exceptions != NULL ) {
2630 tso->blocked_exceptions =
2631 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2634 // We don't always chase the link field: TSOs on the blackhole
2635 // queue are not automatically alive, so the link field is a
2636 // "weak" pointer in that case.
2637 if (tso->why_blocked != BlockedOnBlackHole) {
2638 tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
2641 // scavange current transaction record
2642 tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2644 // scavenge this thread's stack
2645 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2648 /* -----------------------------------------------------------------------------
2649 Blocks of function args occur on the stack (at the top) and
2651 -------------------------------------------------------------------------- */
2653 STATIC_INLINE StgPtr
2654 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2661 switch (fun_info->f.fun_type) {
2663 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2664 size = BITMAP_SIZE(fun_info->f.b.bitmap);
2667 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2668 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2672 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2673 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2676 if ((bitmap & 1) == 0) {
2677 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2680 bitmap = bitmap >> 1;
2688 STATIC_INLINE StgPtr
2689 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2693 StgFunInfoTable *fun_info;
2695 fun_info = get_fun_itbl(fun);
2696 ASSERT(fun_info->i.type != PAP);
2697 p = (StgPtr)payload;
2699 switch (fun_info->f.fun_type) {
2701 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2704 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2708 scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2712 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2715 if ((bitmap & 1) == 0) {
2716 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2719 bitmap = bitmap >> 1;
2727 STATIC_INLINE StgPtr
2728 scavenge_PAP (StgPAP *pap)
2730 pap->fun = evacuate(pap->fun);
2731 return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2734 STATIC_INLINE StgPtr
2735 scavenge_AP (StgAP *ap)
2737 ap->fun = evacuate(ap->fun);
2738 return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2741 /* -----------------------------------------------------------------------------
2742 Scavenge a given step until there are no more objects in this step
2745 evac_gen is set by the caller to be either zero (for a step in a
2746 generation < N) or G where G is the generation of the step being
2749 We sometimes temporarily change evac_gen back to zero if we're
2750 scavenging a mutable object where early promotion isn't such a good
2752 -------------------------------------------------------------------------- */
2760 nat saved_evac_gen = evac_gen;
2765 failed_to_evac = rtsFalse;
2767 /* scavenge phase - standard breadth-first scavenging of the
2771 while (bd != stp->hp_bd || p < stp->hp) {
2773 // If we're at the end of this block, move on to the next block
2774 if (bd != stp->hp_bd && p == bd->free) {
2780 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2781 info = get_itbl((StgClosure *)p);
2783 ASSERT(thunk_selector_depth == 0);
2786 switch (info->type) {
2790 StgMVar *mvar = ((StgMVar *)p);
2792 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2793 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2794 mvar->value = evacuate((StgClosure *)mvar->value);
2795 evac_gen = saved_evac_gen;
2796 failed_to_evac = rtsTrue; // mutable.
2797 p += sizeofW(StgMVar);
2802 scavenge_fun_srt(info);
2803 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2804 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2805 p += sizeofW(StgHeader) + 2;
2809 scavenge_thunk_srt(info);
2810 ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2811 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2812 p += sizeofW(StgThunk) + 2;
2816 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2817 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2818 p += sizeofW(StgHeader) + 2;
2822 scavenge_thunk_srt(info);
2823 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2824 p += sizeofW(StgThunk) + 1;
2828 scavenge_fun_srt(info);
2830 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2831 p += sizeofW(StgHeader) + 1;
2835 scavenge_thunk_srt(info);
2836 p += sizeofW(StgThunk) + 1;
2840 scavenge_fun_srt(info);
2842 p += sizeofW(StgHeader) + 1;
2846 scavenge_thunk_srt(info);
2847 p += sizeofW(StgThunk) + 2;
2851 scavenge_fun_srt(info);
2853 p += sizeofW(StgHeader) + 2;
2857 scavenge_thunk_srt(info);
2858 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2859 p += sizeofW(StgThunk) + 2;
2863 scavenge_fun_srt(info);
2865 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2866 p += sizeofW(StgHeader) + 2;
2870 scavenge_fun_srt(info);
2877 scavenge_thunk_srt(info);
2878 end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2879 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2880 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2882 p += info->layout.payload.nptrs;
2893 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2894 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2895 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2897 p += info->layout.payload.nptrs;
2902 StgBCO *bco = (StgBCO *)p;
2903 bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2904 bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2905 bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2906 bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2907 p += bco_sizeW(bco);
2912 if (stp->gen->no != 0) {
2915 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2916 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2917 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2920 // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2922 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2924 // We pretend that p has just been created.
2925 LDV_RECORD_CREATE((StgClosure *)p);
2928 case IND_OLDGEN_PERM:
2929 ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2930 p += sizeofW(StgInd);
2934 case MUT_VAR_DIRTY: {
2935 rtsBool saved_eager_promotion = eager_promotion;
2937 eager_promotion = rtsFalse;
2938 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2939 eager_promotion = saved_eager_promotion;
2941 if (failed_to_evac) {
2942 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
2944 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
2946 p += sizeofW(StgMutVar);
2951 case SE_CAF_BLACKHOLE:
2954 p += BLACKHOLE_sizeW();
2957 case THUNK_SELECTOR:
2959 StgSelector *s = (StgSelector *)p;
2960 s->selectee = evacuate(s->selectee);
2961 p += THUNK_SELECTOR_sizeW();
2965 // A chunk of stack saved in a heap object
2968 StgAP_STACK *ap = (StgAP_STACK *)p;
2970 ap->fun = evacuate(ap->fun);
2971 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2972 p = (StgPtr)ap->payload + ap->size;
2977 p = scavenge_PAP((StgPAP *)p);
2981 p = scavenge_AP((StgAP *)p);
2985 // nothing to follow
2986 p += arr_words_sizeW((StgArrWords *)p);
2989 case MUT_ARR_PTRS_CLEAN:
2990 case MUT_ARR_PTRS_DIRTY:
2991 // follow everything
2994 rtsBool saved_eager;
2996 // We don't eagerly promote objects pointed to by a mutable
2997 // array, but if we find the array only points to objects in
2998 // the same or an older generation, we mark it "clean" and
2999 // avoid traversing it during minor GCs.
3000 saved_eager = eager_promotion;
3001 eager_promotion = rtsFalse;
3002 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3003 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3004 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3006 eager_promotion = saved_eager;
3008 if (failed_to_evac) {
3009 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3011 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3014 failed_to_evac = rtsTrue; // always put it on the mutable list.
3018 case MUT_ARR_PTRS_FROZEN:
3019 case MUT_ARR_PTRS_FROZEN0:
3020 // follow everything
3024 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3025 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3026 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3029 // If we're going to put this object on the mutable list, then
3030 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3031 if (failed_to_evac) {
3032 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3034 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3041 StgTSO *tso = (StgTSO *)p;
3042 rtsBool saved_eager = eager_promotion;
3044 eager_promotion = rtsFalse;
3046 eager_promotion = saved_eager;
3048 if (failed_to_evac) {
3049 tso->flags |= TSO_DIRTY;
3051 tso->flags &= ~TSO_DIRTY;
3054 failed_to_evac = rtsTrue; // always on the mutable list
3055 p += tso_sizeW(tso);
3063 nat size, ptrs, nonptrs, vhs;
3065 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3067 StgRBH *rbh = (StgRBH *)p;
3068 (StgClosure *)rbh->blocking_queue =
3069 evacuate((StgClosure *)rbh->blocking_queue);
3070 failed_to_evac = rtsTrue; // mutable anyhow.
3072 debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3073 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3074 // ToDo: use size of reverted closure here!
3075 p += BLACKHOLE_sizeW();
3081 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3082 // follow the pointer to the node which is being demanded
3083 (StgClosure *)bf->node =
3084 evacuate((StgClosure *)bf->node);
3085 // follow the link to the rest of the blocking queue
3086 (StgClosure *)bf->link =
3087 evacuate((StgClosure *)bf->link);
3089 debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3090 bf, info_type((StgClosure *)bf),
3091 bf->node, info_type(bf->node)));
3092 p += sizeofW(StgBlockedFetch);
3100 p += sizeofW(StgFetchMe);
3101 break; // nothing to do in this case
3105 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3106 (StgClosure *)fmbq->blocking_queue =
3107 evacuate((StgClosure *)fmbq->blocking_queue);
3109 debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3110 p, info_type((StgClosure *)p)));
3111 p += sizeofW(StgFetchMeBlockingQueue);
3116 case TVAR_WAIT_QUEUE:
3118 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3120 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3121 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3122 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3123 evac_gen = saved_evac_gen;
3124 failed_to_evac = rtsTrue; // mutable
3125 p += sizeofW(StgTVarWaitQueue);
3131 StgTVar *tvar = ((StgTVar *) p);
3133 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3134 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3135 evac_gen = saved_evac_gen;
3136 failed_to_evac = rtsTrue; // mutable
3137 p += sizeofW(StgTVar);
3143 StgTRecHeader *trec = ((StgTRecHeader *) p);
3145 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3146 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3147 evac_gen = saved_evac_gen;
3148 failed_to_evac = rtsTrue; // mutable
3149 p += sizeofW(StgTRecHeader);
3156 StgTRecChunk *tc = ((StgTRecChunk *) p);
3157 TRecEntry *e = &(tc -> entries[0]);
3159 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3160 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3161 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3162 e->expected_value = evacuate((StgClosure*)e->expected_value);
3163 e->new_value = evacuate((StgClosure*)e->new_value);
3165 evac_gen = saved_evac_gen;
3166 failed_to_evac = rtsTrue; // mutable
3167 p += sizeofW(StgTRecChunk);
3172 barf("scavenge: unimplemented/strange closure type %d @ %p",
3177 * We need to record the current object on the mutable list if
3178 * (a) It is actually mutable, or
3179 * (b) It contains pointers to a younger generation.
3180 * Case (b) arises if we didn't manage to promote everything that
3181 * the current object points to into the current generation.
3183 if (failed_to_evac) {
3184 failed_to_evac = rtsFalse;
3185 if (stp->gen_no > 0) {
3186 recordMutableGen((StgClosure *)q, stp->gen);
3195 /* -----------------------------------------------------------------------------
3196 Scavenge everything on the mark stack.
3198 This is slightly different from scavenge():
3199 - we don't walk linearly through the objects, so the scavenger
3200 doesn't need to advance the pointer on to the next object.
3201 -------------------------------------------------------------------------- */
3204 scavenge_mark_stack(void)
3210 evac_gen = oldest_gen->no;
3211 saved_evac_gen = evac_gen;
3214 while (!mark_stack_empty()) {
3215 p = pop_mark_stack();
3217 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3218 info = get_itbl((StgClosure *)p);
3221 switch (info->type) {
3225 StgMVar *mvar = ((StgMVar *)p);
3227 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3228 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3229 mvar->value = evacuate((StgClosure *)mvar->value);
3230 evac_gen = saved_evac_gen;
3231 failed_to_evac = rtsTrue; // mutable.
3236 scavenge_fun_srt(info);
3237 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3238 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3242 scavenge_thunk_srt(info);
3243 ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
3244 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3248 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3249 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3254 scavenge_fun_srt(info);
3255 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3260 scavenge_thunk_srt(info);
3261 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3266 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3271 scavenge_fun_srt(info);
3276 scavenge_thunk_srt(info);
3284 scavenge_fun_srt(info);
3291 scavenge_thunk_srt(info);
3292 end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3293 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3294 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3306 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3307 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3308 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3314 StgBCO *bco = (StgBCO *)p;
3315 bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3316 bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3317 bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3318 bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3323 // don't need to do anything here: the only possible case
3324 // is that we're in a 1-space compacting collector, with
3325 // no "old" generation.
3329 case IND_OLDGEN_PERM:
3330 ((StgInd *)p)->indirectee =
3331 evacuate(((StgInd *)p)->indirectee);
3335 case MUT_VAR_DIRTY: {
3336 rtsBool saved_eager_promotion = eager_promotion;
3338 eager_promotion = rtsFalse;
3339 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3340 eager_promotion = saved_eager_promotion;
3342 if (failed_to_evac) {
3343 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3345 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3351 case SE_CAF_BLACKHOLE:
3357 case THUNK_SELECTOR:
3359 StgSelector *s = (StgSelector *)p;
3360 s->selectee = evacuate(s->selectee);
3364 // A chunk of stack saved in a heap object
3367 StgAP_STACK *ap = (StgAP_STACK *)p;
3369 ap->fun = evacuate(ap->fun);
3370 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3375 scavenge_PAP((StgPAP *)p);
3379 scavenge_AP((StgAP *)p);
3382 case MUT_ARR_PTRS_CLEAN:
3383 case MUT_ARR_PTRS_DIRTY:
3384 // follow everything
3387 rtsBool saved_eager;
3389 // We don't eagerly promote objects pointed to by a mutable
3390 // array, but if we find the array only points to objects in
3391 // the same or an older generation, we mark it "clean" and
3392 // avoid traversing it during minor GCs.
3393 saved_eager = eager_promotion;
3394 eager_promotion = rtsFalse;
3395 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3396 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3397 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3399 eager_promotion = saved_eager;
3401 if (failed_to_evac) {
3402 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3404 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3407 failed_to_evac = rtsTrue; // mutable anyhow.
3411 case MUT_ARR_PTRS_FROZEN:
3412 case MUT_ARR_PTRS_FROZEN0:
3413 // follow everything
3417 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3418 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3419 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3422 // If we're going to put this object on the mutable list, then
3423 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3424 if (failed_to_evac) {
3425 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3427 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3434 StgTSO *tso = (StgTSO *)p;
3435 rtsBool saved_eager = eager_promotion;
3437 eager_promotion = rtsFalse;
3439 eager_promotion = saved_eager;
3441 if (failed_to_evac) {
3442 tso->flags |= TSO_DIRTY;
3444 tso->flags &= ~TSO_DIRTY;
3447 failed_to_evac = rtsTrue; // always on the mutable list
3455 nat size, ptrs, nonptrs, vhs;
3457 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3459 StgRBH *rbh = (StgRBH *)p;
3460 bh->blocking_queue =
3461 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3462 failed_to_evac = rtsTrue; // mutable anyhow.
3464 debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3465 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3471 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3472 // follow the pointer to the node which is being demanded
3473 (StgClosure *)bf->node =
3474 evacuate((StgClosure *)bf->node);
3475 // follow the link to the rest of the blocking queue
3476 (StgClosure *)bf->link =
3477 evacuate((StgClosure *)bf->link);
3479 debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3480 bf, info_type((StgClosure *)bf),
3481 bf->node, info_type(bf->node)));
3489 break; // nothing to do in this case
3493 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3494 (StgClosure *)fmbq->blocking_queue =
3495 evacuate((StgClosure *)fmbq->blocking_queue);
3497 debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3498 p, info_type((StgClosure *)p)));
3503 case TVAR_WAIT_QUEUE:
3505 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3507 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3508 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3509 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3510 evac_gen = saved_evac_gen;
3511 failed_to_evac = rtsTrue; // mutable
3517 StgTVar *tvar = ((StgTVar *) p);
3519 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3520 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3521 evac_gen = saved_evac_gen;
3522 failed_to_evac = rtsTrue; // mutable
3529 StgTRecChunk *tc = ((StgTRecChunk *) p);
3530 TRecEntry *e = &(tc -> entries[0]);
3532 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3533 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3534 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3535 e->expected_value = evacuate((StgClosure*)e->expected_value);
3536 e->new_value = evacuate((StgClosure*)e->new_value);
3538 evac_gen = saved_evac_gen;
3539 failed_to_evac = rtsTrue; // mutable
3545 StgTRecHeader *trec = ((StgTRecHeader *) p);
3547 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3548 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3549 evac_gen = saved_evac_gen;
3550 failed_to_evac = rtsTrue; // mutable
3555 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3559 if (failed_to_evac) {
3560 failed_to_evac = rtsFalse;
3562 recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3566 // mark the next bit to indicate "scavenged"
3567 mark(q+1, Bdescr(q));
3569 } // while (!mark_stack_empty())
3571 // start a new linear scan if the mark stack overflowed at some point
3572 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3573 IF_DEBUG(gc, debugBelch("scavenge_mark_stack: starting linear scan"));
3574 mark_stack_overflowed = rtsFalse;
3575 oldgen_scan_bd = oldest_gen->steps[0].old_blocks;
3576 oldgen_scan = oldgen_scan_bd->start;
3579 if (oldgen_scan_bd) {
3580 // push a new thing on the mark stack
3582 // find a closure that is marked but not scavenged, and start
3584 while (oldgen_scan < oldgen_scan_bd->free
3585 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3589 if (oldgen_scan < oldgen_scan_bd->free) {
3591 // already scavenged?
3592 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3593 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3596 push_mark_stack(oldgen_scan);
3597 // ToDo: bump the linear scan by the actual size of the object
3598 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3602 oldgen_scan_bd = oldgen_scan_bd->link;
3603 if (oldgen_scan_bd != NULL) {
3604 oldgen_scan = oldgen_scan_bd->start;
3610 /* -----------------------------------------------------------------------------
3611 Scavenge one object.
3613 This is used for objects that are temporarily marked as mutable
3614 because they contain old-to-new generation pointers. Only certain
3615 objects can have this property.
3616 -------------------------------------------------------------------------- */
3619 scavenge_one(StgPtr p)
3621 const StgInfoTable *info;
3622 nat saved_evac_gen = evac_gen;
3625 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3626 info = get_itbl((StgClosure *)p);
3628 switch (info->type) {
3632 StgMVar *mvar = ((StgMVar *)p);
3634 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3635 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3636 mvar->value = evacuate((StgClosure *)mvar->value);
3637 evac_gen = saved_evac_gen;
3638 failed_to_evac = rtsTrue; // mutable.
3651 end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3652 for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3653 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3659 case FUN_1_0: // hardly worth specialising these guys
3675 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3676 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3677 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3683 case MUT_VAR_DIRTY: {
3685 rtsBool saved_eager_promotion = eager_promotion;
3687 eager_promotion = rtsFalse;
3688 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3689 eager_promotion = saved_eager_promotion;
3691 if (failed_to_evac) {
3692 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3694 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3700 case SE_CAF_BLACKHOLE:
3705 case THUNK_SELECTOR:
3707 StgSelector *s = (StgSelector *)p;
3708 s->selectee = evacuate(s->selectee);
3714 StgAP_STACK *ap = (StgAP_STACK *)p;
3716 ap->fun = evacuate(ap->fun);
3717 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3718 p = (StgPtr)ap->payload + ap->size;
3723 p = scavenge_PAP((StgPAP *)p);
3727 p = scavenge_AP((StgAP *)p);
3731 // nothing to follow
3734 case MUT_ARR_PTRS_CLEAN:
3735 case MUT_ARR_PTRS_DIRTY:
3738 rtsBool saved_eager;
3740 // We don't eagerly promote objects pointed to by a mutable
3741 // array, but if we find the array only points to objects in
3742 // the same or an older generation, we mark it "clean" and
3743 // avoid traversing it during minor GCs.
3744 saved_eager = eager_promotion;
3745 eager_promotion = rtsFalse;
3747 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3748 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3749 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3751 eager_promotion = saved_eager;
3753 if (failed_to_evac) {
3754 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3756 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3759 failed_to_evac = rtsTrue;
3763 case MUT_ARR_PTRS_FROZEN:
3764 case MUT_ARR_PTRS_FROZEN0:
3766 // follow everything
3769 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3770 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3771 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3774 // If we're going to put this object on the mutable list, then
3775 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3776 if (failed_to_evac) {
3777 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3779 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3786 StgTSO *tso = (StgTSO *)p;
3787 rtsBool saved_eager = eager_promotion;
3789 eager_promotion = rtsFalse;
3791 eager_promotion = saved_eager;
3793 if (failed_to_evac) {
3794 tso->flags |= TSO_DIRTY;
3796 tso->flags &= ~TSO_DIRTY;
3799 failed_to_evac = rtsTrue; // always on the mutable list
3807 nat size, ptrs, nonptrs, vhs;
3809 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3811 StgRBH *rbh = (StgRBH *)p;
3812 (StgClosure *)rbh->blocking_queue =
3813 evacuate((StgClosure *)rbh->blocking_queue);
3814 failed_to_evac = rtsTrue; // mutable anyhow.
3816 debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3817 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3818 // ToDo: use size of reverted closure here!
3824 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3825 // follow the pointer to the node which is being demanded
3826 (StgClosure *)bf->node =
3827 evacuate((StgClosure *)bf->node);
3828 // follow the link to the rest of the blocking queue
3829 (StgClosure *)bf->link =
3830 evacuate((StgClosure *)bf->link);
3832 debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3833 bf, info_type((StgClosure *)bf),
3834 bf->node, info_type(bf->node)));
3842 break; // nothing to do in this case
3846 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3847 (StgClosure *)fmbq->blocking_queue =
3848 evacuate((StgClosure *)fmbq->blocking_queue);
3850 debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3851 p, info_type((StgClosure *)p)));
3856 case TVAR_WAIT_QUEUE:
3858 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3860 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3861 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3862 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3863 evac_gen = saved_evac_gen;
3864 failed_to_evac = rtsTrue; // mutable
3870 StgTVar *tvar = ((StgTVar *) p);
3872 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3873 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3874 evac_gen = saved_evac_gen;
3875 failed_to_evac = rtsTrue; // mutable
3881 StgTRecHeader *trec = ((StgTRecHeader *) p);
3883 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3884 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3885 evac_gen = saved_evac_gen;
3886 failed_to_evac = rtsTrue; // mutable
3893 StgTRecChunk *tc = ((StgTRecChunk *) p);
3894 TRecEntry *e = &(tc -> entries[0]);
3896 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3897 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3898 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3899 e->expected_value = evacuate((StgClosure*)e->expected_value);
3900 e->new_value = evacuate((StgClosure*)e->new_value);
3902 evac_gen = saved_evac_gen;
3903 failed_to_evac = rtsTrue; // mutable
3908 case IND_OLDGEN_PERM:
3911 /* Careful here: a THUNK can be on the mutable list because
3912 * it contains pointers to young gen objects. If such a thunk
3913 * is updated, the IND_OLDGEN will be added to the mutable
3914 * list again, and we'll scavenge it twice. evacuate()
3915 * doesn't check whether the object has already been
3916 * evacuated, so we perform that check here.
3918 StgClosure *q = ((StgInd *)p)->indirectee;
3919 if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
3922 ((StgInd *)p)->indirectee = evacuate(q);
3925 #if 0 && defined(DEBUG)
3926 if (RtsFlags.DebugFlags.gc)
3927 /* Debugging code to print out the size of the thing we just
3931 StgPtr start = gen->steps[0].scan;
3932 bdescr *start_bd = gen->steps[0].scan_bd;
3934 scavenge(&gen->steps[0]);
3935 if (start_bd != gen->steps[0].scan_bd) {
3936 size += (P_)BLOCK_ROUND_UP(start) - start;
3937 start_bd = start_bd->link;
3938 while (start_bd != gen->steps[0].scan_bd) {
3939 size += BLOCK_SIZE_W;
3940 start_bd = start_bd->link;
3942 size += gen->steps[0].scan -
3943 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3945 size = gen->steps[0].scan - start;
3947 debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3953 barf("scavenge_one: strange object %d", (int)(info->type));
3956 no_luck = failed_to_evac;
3957 failed_to_evac = rtsFalse;
3961 /* -----------------------------------------------------------------------------
3962 Scavenging mutable lists.
3964 We treat the mutable list of each generation > N (i.e. all the
3965 generations older than the one being collected) as roots. We also
3966 remove non-mutable objects from the mutable list at this point.
3967 -------------------------------------------------------------------------- */
3970 scavenge_mutable_list(generation *gen)
3975 bd = gen->saved_mut_list;
3978 for (; bd != NULL; bd = bd->link) {
3979 for (q = bd->start; q < bd->free; q++) {
3981 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3984 switch (get_itbl((StgClosure *)p)->type) {
3986 barf("MUT_VAR_CLEAN on mutable list");
3988 mutlist_MUTVARS++; break;
3989 case MUT_ARR_PTRS_CLEAN:
3990 case MUT_ARR_PTRS_DIRTY:
3991 case MUT_ARR_PTRS_FROZEN:
3992 case MUT_ARR_PTRS_FROZEN0:
3993 mutlist_MUTARRS++; break;
3995 mutlist_OTHERS++; break;
3999 // Check whether this object is "clean", that is it
4000 // definitely doesn't point into a young generation.
4001 // Clean objects don't need to be scavenged. Some clean
4002 // objects (MUT_VAR_CLEAN) are not kept on the mutable
4003 // list at all; others, such as MUT_ARR_PTRS_CLEAN and
4004 // TSO, are always on the mutable list.
4006 switch (get_itbl((StgClosure *)p)->type) {
4007 case MUT_ARR_PTRS_CLEAN:
4008 recordMutableGen((StgClosure *)p,gen);
4011 StgTSO *tso = (StgTSO *)p;
4012 if ((tso->flags & TSO_DIRTY) == 0) {
4013 // A clean TSO: we don't have to traverse its
4014 // stack. However, we *do* follow the link field:
4015 // we don't want to have to mark a TSO dirty just
4016 // because we put it on a different queue.
4017 if (tso->why_blocked != BlockedOnBlackHole) {
4018 tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
4020 recordMutableGen((StgClosure *)p,gen);
4028 if (scavenge_one(p)) {
4029 // didn't manage to promote everything, so put the
4030 // object back on the list.
4031 recordMutableGen((StgClosure *)p,gen);
4036 // free the old mut_list
4037 freeChain(gen->saved_mut_list);
4038 gen->saved_mut_list = NULL;
4043 scavenge_static(void)
4045 StgClosure* p = static_objects;
4046 const StgInfoTable *info;
4048 /* Always evacuate straight to the oldest generation for static
4050 evac_gen = oldest_gen->no;
4052 /* keep going until we've scavenged all the objects on the linked
4054 while (p != END_OF_STATIC_LIST) {
4056 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
4059 if (info->type==RBH)
4060 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
4062 // make sure the info pointer is into text space
4064 /* Take this object *off* the static_objects list,
4065 * and put it on the scavenged_static_objects list.
4067 static_objects = *STATIC_LINK(info,p);
4068 *STATIC_LINK(info,p) = scavenged_static_objects;
4069 scavenged_static_objects = p;
4071 switch (info -> type) {
4075 StgInd *ind = (StgInd *)p;
4076 ind->indirectee = evacuate(ind->indirectee);
4078 /* might fail to evacuate it, in which case we have to pop it
4079 * back on the mutable list of the oldest generation. We
4080 * leave it *on* the scavenged_static_objects list, though,
4081 * in case we visit this object again.
4083 if (failed_to_evac) {
4084 failed_to_evac = rtsFalse;
4085 recordMutableGen((StgClosure *)p,oldest_gen);
4091 scavenge_thunk_srt(info);
4095 scavenge_fun_srt(info);
4102 next = (P_)p->payload + info->layout.payload.ptrs;
4103 // evacuate the pointers
4104 for (q = (P_)p->payload; q < next; q++) {
4105 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
4111 barf("scavenge_static: strange closure %d", (int)(info->type));
4114 ASSERT(failed_to_evac == rtsFalse);
4116 /* get the next static object from the list. Remember, there might
4117 * be more stuff on this list now that we've done some evacuating!
4118 * (static_objects is a global)
4124 /* -----------------------------------------------------------------------------
4125 scavenge a chunk of memory described by a bitmap
4126 -------------------------------------------------------------------------- */
4129 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
4135 bitmap = large_bitmap->bitmap[b];
4136 for (i = 0; i < size; ) {
4137 if ((bitmap & 1) == 0) {
4138 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4142 if (i % BITS_IN(W_) == 0) {
4144 bitmap = large_bitmap->bitmap[b];
4146 bitmap = bitmap >> 1;
4151 STATIC_INLINE StgPtr
4152 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
4155 if ((bitmap & 1) == 0) {
4156 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4159 bitmap = bitmap >> 1;
4165 /* -----------------------------------------------------------------------------
4166 scavenge_stack walks over a section of stack and evacuates all the
4167 objects pointed to by it. We can use the same code for walking
4168 AP_STACK_UPDs, since these are just sections of copied stack.
4169 -------------------------------------------------------------------------- */
4173 scavenge_stack(StgPtr p, StgPtr stack_end)
4175 const StgRetInfoTable* info;
4179 //IF_DEBUG(sanity, debugBelch(" scavenging stack between %p and %p", p, stack_end));
4182 * Each time around this loop, we are looking at a chunk of stack
4183 * that starts with an activation record.
4186 while (p < stack_end) {
4187 info = get_ret_itbl((StgClosure *)p);
4189 switch (info->i.type) {
4192 // In SMP, we can get update frames that point to indirections
4193 // when two threads evaluate the same thunk. We do attempt to
4194 // discover this situation in threadPaused(), but it's
4195 // possible that the following sequence occurs:
4204 // Now T is an indirection, and the update frame is already
4205 // marked on A's stack, so we won't traverse it again in
4206 // threadPaused(). We could traverse the whole stack again
4207 // before GC, but that seems like overkill.
4209 // Scavenging this update frame as normal would be disastrous;
4210 // the updatee would end up pointing to the value. So we turn
4211 // the indirection into an IND_PERM, so that evacuate will
4212 // copy the indirection into the old generation instead of
4214 if (get_itbl(((StgUpdateFrame *)p)->updatee)->type == IND) {
4215 ((StgUpdateFrame *)p)->updatee->header.info =
4216 (StgInfoTable *)&stg_IND_PERM_info;
4218 ((StgUpdateFrame *)p)->updatee
4219 = evacuate(((StgUpdateFrame *)p)->updatee);
4220 p += sizeofW(StgUpdateFrame);
4223 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
4224 case CATCH_STM_FRAME:
4225 case CATCH_RETRY_FRAME:
4226 case ATOMICALLY_FRAME:
4231 bitmap = BITMAP_BITS(info->i.layout.bitmap);
4232 size = BITMAP_SIZE(info->i.layout.bitmap);
4233 // NOTE: the payload starts immediately after the info-ptr, we
4234 // don't have an StgHeader in the same sense as a heap closure.
4236 p = scavenge_small_bitmap(p, size, bitmap);
4240 scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
4248 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4251 size = BCO_BITMAP_SIZE(bco);
4252 scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
4257 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
4263 size = GET_LARGE_BITMAP(&info->i)->size;
4265 scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
4267 // and don't forget to follow the SRT
4271 // Dynamic bitmap: the mask is stored on the stack, and
4272 // there are a number of non-pointers followed by a number
4273 // of pointers above the bitmapped area. (see StgMacros.h,
4278 dyn = ((StgRetDyn *)p)->liveness;
4280 // traverse the bitmap first
4281 bitmap = RET_DYN_LIVENESS(dyn);
4282 p = (P_)&((StgRetDyn *)p)->payload[0];
4283 size = RET_DYN_BITMAP_SIZE;
4284 p = scavenge_small_bitmap(p, size, bitmap);
4286 // skip over the non-ptr words
4287 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
4289 // follow the ptr words
4290 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
4291 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4299 StgRetFun *ret_fun = (StgRetFun *)p;
4300 StgFunInfoTable *fun_info;
4302 ret_fun->fun = evacuate(ret_fun->fun);
4303 fun_info = get_fun_itbl(ret_fun->fun);
4304 p = scavenge_arg_block(fun_info, ret_fun->payload);
4309 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
4314 /*-----------------------------------------------------------------------------
4315 scavenge the large object list.
4317 evac_gen set by caller; similar games played with evac_gen as with
4318 scavenge() - see comment at the top of scavenge(). Most large
4319 objects are (repeatedly) mutable, so most of the time evac_gen will
4321 --------------------------------------------------------------------------- */
4324 scavenge_large(step *stp)
4329 bd = stp->new_large_objects;
4331 for (; bd != NULL; bd = stp->new_large_objects) {
4333 /* take this object *off* the large objects list and put it on
4334 * the scavenged large objects list. This is so that we can
4335 * treat new_large_objects as a stack and push new objects on
4336 * the front when evacuating.
4338 stp->new_large_objects = bd->link;
4339 dbl_link_onto(bd, &stp->scavenged_large_objects);
4341 // update the block count in this step.
4342 stp->n_scavenged_large_blocks += bd->blocks;
4345 if (scavenge_one(p)) {
4346 if (stp->gen_no > 0) {
4347 recordMutableGen((StgClosure *)p, stp->gen);
4353 /* -----------------------------------------------------------------------------
4354 Initialising the static object & mutable lists
4355 -------------------------------------------------------------------------- */
4358 zero_static_object_list(StgClosure* first_static)
4362 const StgInfoTable *info;
4364 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
4366 link = *STATIC_LINK(info, p);
4367 *STATIC_LINK(info,p) = NULL;
4371 /* -----------------------------------------------------------------------------
4373 -------------------------------------------------------------------------- */
4380 for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4381 c = (StgIndStatic *)c->static_link)
4383 SET_INFO(c, c->saved_info);
4384 c->saved_info = NULL;
4385 // could, but not necessary: c->static_link = NULL;
4387 revertible_caf_list = NULL;
4391 markCAFs( evac_fn evac )
4395 for (c = (StgIndStatic *)caf_list; c != NULL;
4396 c = (StgIndStatic *)c->static_link)
4398 evac(&c->indirectee);
4400 for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4401 c = (StgIndStatic *)c->static_link)
4403 evac(&c->indirectee);
4407 /* -----------------------------------------------------------------------------
4408 Sanity code for CAF garbage collection.
4410 With DEBUG turned on, we manage a CAF list in addition to the SRT
4411 mechanism. After GC, we run down the CAF list and blackhole any
4412 CAFs which have been garbage collected. This means we get an error
4413 whenever the program tries to enter a garbage collected CAF.
4415 Any garbage collected CAFs are taken off the CAF list at the same
4417 -------------------------------------------------------------------------- */
4419 #if 0 && defined(DEBUG)
4426 const StgInfoTable *info;
4437 ASSERT(info->type == IND_STATIC);
4439 if (STATIC_LINK(info,p) == NULL) {
4440 IF_DEBUG(gccafs, debugBelch("CAF gc'd at 0x%04lx", (long)p));
4442 SET_INFO(p,&stg_BLACKHOLE_info);
4443 p = STATIC_LINK2(info,p);
4447 pp = &STATIC_LINK2(info,p);
4454 // debugBelch("%d CAFs live", i);
4459 /* -----------------------------------------------------------------------------
4462 * Code largely pinched from old RTS, then hacked to bits. We also do
4463 * lazy black holing here.
4465 * -------------------------------------------------------------------------- */
4467 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4470 stackSqueeze(StgTSO *tso, StgPtr bottom)
4473 rtsBool prev_was_update_frame;
4474 StgClosure *updatee = NULL;
4475 StgRetInfoTable *info;
4476 StgWord current_gap_size;
4477 struct stack_gap *gap;
4480 // Traverse the stack upwards, replacing adjacent update frames
4481 // with a single update frame and a "stack gap". A stack gap
4482 // contains two values: the size of the gap, and the distance
4483 // to the next gap (or the stack top).
4487 ASSERT(frame < bottom);
4489 prev_was_update_frame = rtsFalse;
4490 current_gap_size = 0;
4491 gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4493 while (frame < bottom) {
4495 info = get_ret_itbl((StgClosure *)frame);
4496 switch (info->i.type) {
4500 StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4502 if (prev_was_update_frame) {
4504 TICK_UPD_SQUEEZED();
4505 /* wasn't there something about update squeezing and ticky to be
4506 * sorted out? oh yes: we aren't counting each enter properly
4507 * in this case. See the log somewhere. KSW 1999-04-21
4509 * Check two things: that the two update frames don't point to
4510 * the same object, and that the updatee_bypass isn't already an
4511 * indirection. Both of these cases only happen when we're in a
4512 * block hole-style loop (and there are multiple update frames
4513 * on the stack pointing to the same closure), but they can both
4514 * screw us up if we don't check.
4516 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4517 UPD_IND_NOLOCK(upd->updatee, updatee);
4520 // now mark this update frame as a stack gap. The gap
4521 // marker resides in the bottom-most update frame of
4522 // the series of adjacent frames, and covers all the
4523 // frames in this series.
4524 current_gap_size += sizeofW(StgUpdateFrame);
4525 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4526 ((struct stack_gap *)frame)->next_gap = gap;
4528 frame += sizeofW(StgUpdateFrame);
4532 // single update frame, or the topmost update frame in a series
4534 prev_was_update_frame = rtsTrue;
4535 updatee = upd->updatee;
4536 frame += sizeofW(StgUpdateFrame);
4542 prev_was_update_frame = rtsFalse;
4544 // we're not in a gap... check whether this is the end of a gap
4545 // (an update frame can't be the end of a gap).
4546 if (current_gap_size != 0) {
4547 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4549 current_gap_size = 0;
4551 frame += stack_frame_sizeW((StgClosure *)frame);
4556 if (current_gap_size != 0) {
4557 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4560 // Now we have a stack with gaps in it, and we have to walk down
4561 // shoving the stack up to fill in the gaps. A diagram might
4565 // | ********* | <- sp
4569 // | stack_gap | <- gap | chunk_size
4571 // | ......... | <- gap_end v
4577 // 'sp' points the the current top-of-stack
4578 // 'gap' points to the stack_gap structure inside the gap
4579 // ***** indicates real stack data
4580 // ..... indicates gap
4581 // <empty> indicates unused
4585 void *gap_start, *next_gap_start, *gap_end;
4588 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4589 sp = next_gap_start;
4591 while ((StgPtr)gap > tso->sp) {
4593 // we're working in *bytes* now...
4594 gap_start = next_gap_start;
4595 gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4597 gap = gap->next_gap;
4598 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4600 chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4602 memmove(sp, next_gap_start, chunk_size);
4605 tso->sp = (StgPtr)sp;
4609 /* -----------------------------------------------------------------------------
4612 * We have to prepare for GC - this means doing lazy black holing
4613 * here. We also take the opportunity to do stack squeezing if it's
4615 * -------------------------------------------------------------------------- */
4617 threadPaused(Capability *cap, StgTSO *tso)
4620 StgRetInfoTable *info;
4623 nat words_to_squeeze = 0;
4625 nat weight_pending = 0;
4626 rtsBool prev_was_update_frame;
4628 stack_end = &tso->stack[tso->stack_size];
4630 frame = (StgClosure *)tso->sp;
4633 // If we've already marked this frame, then stop here.
4634 if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) {
4638 info = get_ret_itbl(frame);
4640 switch (info->i.type) {
4644 SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info);
4646 bh = ((StgUpdateFrame *)frame)->updatee;
4648 if (closure_IND(bh) || bh->header.info == &stg_BLACKHOLE_info) {
4649 IF_DEBUG(squeeze, debugBelch("suspending duplicate work: %ld words of stack\n", (StgPtr)frame - tso->sp));
4651 // If this closure is already an indirection, then
4652 // suspend the computation up to this point:
4653 suspendComputation(cap,tso,(StgPtr)frame);
4655 // Now drop the update frame, and arrange to return
4656 // the value to the frame underneath:
4657 tso->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2;
4658 tso->sp[1] = (StgWord)bh;
4659 tso->sp[0] = (W_)&stg_enter_info;
4661 // And continue with threadPaused; there might be
4662 // yet more computation to suspend.
4663 threadPaused(cap,tso);
4667 if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
4668 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4669 debugBelch("Unexpected lazy BHing required at 0x%04lx\n",(long)bh);
4671 // zero out the slop so that the sanity checker can tell
4672 // where the next closure is.
4673 DEBUG_FILL_SLOP(bh);
4676 // We pretend that bh is now dead.
4677 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4679 SET_INFO(bh,&stg_BLACKHOLE_info);
4681 // We pretend that bh has just been created.
4682 LDV_RECORD_CREATE(bh);
4685 frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4686 if (prev_was_update_frame) {
4687 words_to_squeeze += sizeofW(StgUpdateFrame);
4688 weight += weight_pending;
4691 prev_was_update_frame = rtsTrue;
4697 // normal stack frames; do nothing except advance the pointer
4700 nat frame_size = stack_frame_sizeW(frame);
4701 weight_pending += frame_size;
4702 frame = (StgClosure *)((StgPtr)frame + frame_size);
4703 prev_was_update_frame = rtsFalse;
4710 debugBelch("words_to_squeeze: %d, weight: %d, squeeze: %s\n",
4711 words_to_squeeze, weight,
4712 weight < words_to_squeeze ? "YES" : "NO"));
4714 // Should we squeeze or not? Arbitrary heuristic: we squeeze if
4715 // the number of words we have to shift down is less than the
4716 // number of stack words we squeeze away by doing so.
4717 if (RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue &&
4718 weight < words_to_squeeze) {
4719 stackSqueeze(tso, (StgPtr)frame);
4723 /* -----------------------------------------------------------------------------
4725 * -------------------------------------------------------------------------- */
4729 printMutableList(generation *gen)
4734 debugBelch("@@ Mutable list %p: ", gen->mut_list);
4736 for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
4737 for (p = bd->start; p < bd->free; p++) {
4738 debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));