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"
47 #include "RaiseAsync.h"
51 // Turn off inlining when debugging - it obfuscates things
54 # define STATIC_INLINE static
57 /* STATIC OBJECT LIST.
60 * We maintain a linked list of static objects that are still live.
61 * The requirements for this list are:
63 * - we need to scan the list while adding to it, in order to
64 * scavenge all the static objects (in the same way that
65 * breadth-first scavenging works for dynamic objects).
67 * - we need to be able to tell whether an object is already on
68 * the list, to break loops.
70 * Each static object has a "static link field", which we use for
71 * linking objects on to the list. We use a stack-type list, consing
72 * objects on the front as they are added (this means that the
73 * scavenge phase is depth-first, not breadth-first, but that
76 * A separate list is kept for objects that have been scavenged
77 * already - this is so that we can zero all the marks afterwards.
79 * An object is on the list if its static link field is non-zero; this
80 * means that we have to mark the end of the list with '1', not NULL.
82 * Extra notes for generational GC:
84 * Each generation has a static object list associated with it. When
85 * collecting generations up to N, we treat the static object lists
86 * from generations > N as roots.
88 * We build up a static object list while collecting generations 0..N,
89 * which is then appended to the static object list of generation N+1.
91 static StgClosure* static_objects; // live static objects
92 StgClosure* scavenged_static_objects; // static objects scavenged so far
94 /* N is the oldest generation being collected, where the generations
95 * are numbered starting at 0. A major GC (indicated by the major_gc
96 * flag) is when we're collecting all generations. We only attempt to
97 * deal with static objects and GC CAFs when doing a major GC.
100 static rtsBool major_gc;
102 /* Youngest generation that objects should be evacuated to in
103 * evacuate(). (Logically an argument to evacuate, but it's static
104 * a lot of the time so we optimise it into a global variable).
108 /* Whether to do eager promotion or not.
110 static rtsBool eager_promotion;
114 StgWeak *old_weak_ptr_list; // also pending finaliser list
116 /* Which stage of processing various kinds of weak pointer are we at?
117 * (see traverse_weak_ptr_list() below for discussion).
119 typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage;
120 static WeakStage weak_stage;
122 /* List of all threads during GC
124 static StgTSO *old_all_threads;
125 StgTSO *resurrected_threads;
127 /* Flag indicating failure to evacuate an object to the desired
130 static rtsBool failed_to_evac;
132 /* Saved nursery (used for 2-space collector only)
134 static bdescr *saved_nursery;
135 static nat saved_n_blocks;
137 /* Data used for allocation area sizing.
139 static lnat new_blocks; // blocks allocated during this GC
140 static lnat new_scavd_blocks; // ditto, but depth-first blocks
141 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC
143 /* Used to avoid long recursion due to selector thunks
145 static lnat thunk_selector_depth = 0;
146 #define MAX_THUNK_SELECTOR_DEPTH 8
156 /* -----------------------------------------------------------------------------
157 Static function declarations
158 -------------------------------------------------------------------------- */
160 static bdescr * gc_alloc_block ( step *stp );
161 static void mark_root ( StgClosure **root );
163 // Use a register argument for evacuate, if available.
165 #define REGPARM1 __attribute__((regparm(1)))
170 REGPARM1 static StgClosure * evacuate (StgClosure *q);
172 static void zero_static_object_list ( StgClosure* first_static );
174 static rtsBool traverse_weak_ptr_list ( void );
175 static void mark_weak_ptr_list ( StgWeak **list );
176 static rtsBool traverse_blackhole_queue ( void );
178 static StgClosure * eval_thunk_selector ( nat field, StgSelector * p );
181 static void scavenge ( step * );
182 static void scavenge_mark_stack ( void );
183 static void scavenge_stack ( StgPtr p, StgPtr stack_end );
184 static rtsBool scavenge_one ( StgPtr p );
185 static void scavenge_large ( step * );
186 static void scavenge_static ( void );
187 static void scavenge_mutable_list ( generation *g );
189 static void scavenge_large_bitmap ( StgPtr p,
190 StgLargeBitmap *large_bitmap,
193 #if 0 && defined(DEBUG)
194 static void gcCAFs ( void );
197 /* -----------------------------------------------------------------------------
198 inline functions etc. for dealing with the mark bitmap & stack.
199 -------------------------------------------------------------------------- */
201 #define MARK_STACK_BLOCKS 4
203 static bdescr *mark_stack_bdescr;
204 static StgPtr *mark_stack;
205 static StgPtr *mark_sp;
206 static StgPtr *mark_splim;
208 // Flag and pointers used for falling back to a linear scan when the
209 // mark stack overflows.
210 static rtsBool mark_stack_overflowed;
211 static bdescr *oldgen_scan_bd;
212 static StgPtr oldgen_scan;
214 STATIC_INLINE rtsBool
215 mark_stack_empty(void)
217 return mark_sp == mark_stack;
220 STATIC_INLINE rtsBool
221 mark_stack_full(void)
223 return mark_sp >= mark_splim;
227 reset_mark_stack(void)
229 mark_sp = mark_stack;
233 push_mark_stack(StgPtr p)
244 /* -----------------------------------------------------------------------------
245 Allocate a new to-space block in the given step.
246 -------------------------------------------------------------------------- */
249 gc_alloc_block(step *stp)
251 bdescr *bd = allocBlock();
252 bd->gen_no = stp->gen_no;
256 // blocks in to-space in generations up to and including N
257 // get the BF_EVACUATED flag.
258 if (stp->gen_no <= N) {
259 bd->flags = BF_EVACUATED;
264 // Start a new to-space block, chain it on after the previous one.
265 if (stp->hp_bd != NULL) {
266 stp->hp_bd->free = stp->hp;
267 stp->hp_bd->link = bd;
272 stp->hpLim = stp->hp + BLOCK_SIZE_W;
281 gc_alloc_scavd_block(step *stp)
283 bdescr *bd = allocBlock();
284 bd->gen_no = stp->gen_no;
287 // blocks in to-space in generations up to and including N
288 // get the BF_EVACUATED flag.
289 if (stp->gen_no <= N) {
290 bd->flags = BF_EVACUATED;
295 bd->link = stp->blocks;
298 if (stp->scavd_hp != NULL) {
299 Bdescr(stp->scavd_hp)->free = stp->scavd_hp;
301 stp->scavd_hp = bd->start;
302 stp->scavd_hpLim = stp->scavd_hp + BLOCK_SIZE_W;
310 /* -----------------------------------------------------------------------------
313 Rough outline of the algorithm: for garbage collecting generation N
314 (and all younger generations):
316 - follow all pointers in the root set. the root set includes all
317 mutable objects in all generations (mutable_list).
319 - for each pointer, evacuate the object it points to into either
321 + to-space of the step given by step->to, which is the next
322 highest step in this generation or the first step in the next
323 generation if this is the last step.
325 + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
326 When we evacuate an object we attempt to evacuate
327 everything it points to into the same generation - this is
328 achieved by setting evac_gen to the desired generation. If
329 we can't do this, then an entry in the mut list has to
330 be made for the cross-generation pointer.
332 + if the object is already in a generation > N, then leave
335 - repeatedly scavenge to-space from each step in each generation
336 being collected until no more objects can be evacuated.
338 - free from-space in each step, and set from-space = to-space.
340 Locks held: all capabilities are held throughout GarbageCollect().
342 -------------------------------------------------------------------------- */
345 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
349 lnat live, allocated, copied = 0, scavd_copied = 0;
350 lnat oldgen_saved_blocks = 0;
356 CostCentreStack *prev_CCS;
359 debugTrace(DEBUG_gc, "starting GC");
361 #if defined(RTS_USER_SIGNALS)
366 // tell the STM to discard any cached closures its hoping to re-use
369 // tell the stats department that we've started a GC
373 // check for memory leaks if DEBUG is on
383 // Init stats and print par specific (timing) info
384 PAR_TICKY_PAR_START();
386 // attribute any costs to CCS_GC
392 /* Approximate how much we allocated.
393 * Todo: only when generating stats?
395 allocated = calcAllocated();
397 /* Figure out which generation to collect
399 if (force_major_gc) {
400 N = RtsFlags.GcFlags.generations - 1;
404 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
405 if (generations[g].steps[0].n_blocks +
406 generations[g].steps[0].n_large_blocks
407 >= generations[g].max_blocks) {
411 major_gc = (N == RtsFlags.GcFlags.generations-1);
414 #ifdef RTS_GTK_FRONTPANEL
415 if (RtsFlags.GcFlags.frontpanel) {
416 updateFrontPanelBeforeGC(N);
420 // check stack sanity *before* GC (ToDo: check all threads)
422 // ToDo!: check sanity IF_DEBUG(sanity, checkTSOsSanity());
424 IF_DEBUG(sanity, checkFreeListSanity());
426 /* Initialise the static object lists
428 static_objects = END_OF_STATIC_LIST;
429 scavenged_static_objects = END_OF_STATIC_LIST;
431 /* Save the nursery if we're doing a two-space collection.
432 * g0s0->blocks will be used for to-space, so we need to get the
433 * nursery out of the way.
435 if (RtsFlags.GcFlags.generations == 1) {
436 saved_nursery = g0s0->blocks;
437 saved_n_blocks = g0s0->n_blocks;
442 /* Keep a count of how many new blocks we allocated during this GC
443 * (used for resizing the allocation area, later).
446 new_scavd_blocks = 0;
448 // Initialise to-space in all the generations/steps that we're
451 for (g = 0; g <= N; g++) {
453 // throw away the mutable list. Invariant: the mutable list
454 // always has at least one block; this means we can avoid a check for
455 // NULL in recordMutable().
457 freeChain(generations[g].mut_list);
458 generations[g].mut_list = allocBlock();
459 for (i = 0; i < n_capabilities; i++) {
460 freeChain(capabilities[i].mut_lists[g]);
461 capabilities[i].mut_lists[g] = allocBlock();
465 for (s = 0; s < generations[g].n_steps; s++) {
467 // generation 0, step 0 doesn't need to-space
468 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
472 stp = &generations[g].steps[s];
473 ASSERT(stp->gen_no == g);
475 // start a new to-space for this step.
476 stp->old_blocks = stp->blocks;
477 stp->n_old_blocks = stp->n_blocks;
479 // allocate the first to-space block; extra blocks will be
480 // chained on as necessary.
482 bd = gc_alloc_block(stp);
485 stp->scan = bd->start;
488 // allocate a block for "already scavenged" objects. This goes
489 // on the front of the stp->blocks list, so it won't be
490 // traversed by the scavenging sweep.
491 gc_alloc_scavd_block(stp);
493 // initialise the large object queues.
494 stp->new_large_objects = NULL;
495 stp->scavenged_large_objects = NULL;
496 stp->n_scavenged_large_blocks = 0;
498 // mark the large objects as not evacuated yet
499 for (bd = stp->large_objects; bd; bd = bd->link) {
500 bd->flags &= ~BF_EVACUATED;
503 // for a compacted step, we need to allocate the bitmap
504 if (stp->is_compacted) {
505 nat bitmap_size; // in bytes
506 bdescr *bitmap_bdescr;
509 bitmap_size = stp->n_old_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
511 if (bitmap_size > 0) {
512 bitmap_bdescr = allocGroup((lnat)BLOCK_ROUND_UP(bitmap_size)
514 stp->bitmap = bitmap_bdescr;
515 bitmap = bitmap_bdescr->start;
517 debugTrace(DEBUG_gc, "bitmap_size: %d, bitmap: %p",
518 bitmap_size, bitmap);
520 // don't forget to fill it with zeros!
521 memset(bitmap, 0, bitmap_size);
523 // For each block in this step, point to its bitmap from the
525 for (bd=stp->old_blocks; bd != NULL; bd = bd->link) {
526 bd->u.bitmap = bitmap;
527 bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
529 // Also at this point we set the BF_COMPACTED flag
530 // for this block. The invariant is that
531 // BF_COMPACTED is always unset, except during GC
532 // when it is set on those blocks which will be
534 bd->flags |= BF_COMPACTED;
541 /* make sure the older generations have at least one block to
542 * allocate into (this makes things easier for copy(), see below).
544 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
545 for (s = 0; s < generations[g].n_steps; s++) {
546 stp = &generations[g].steps[s];
547 if (stp->hp_bd == NULL) {
548 ASSERT(stp->blocks == NULL);
549 bd = gc_alloc_block(stp);
553 if (stp->scavd_hp == NULL) {
554 gc_alloc_scavd_block(stp);
557 /* Set the scan pointer for older generations: remember we
558 * still have to scavenge objects that have been promoted. */
560 stp->scan_bd = stp->hp_bd;
561 stp->new_large_objects = NULL;
562 stp->scavenged_large_objects = NULL;
563 stp->n_scavenged_large_blocks = 0;
566 /* Move the private mutable lists from each capability onto the
567 * main mutable list for the generation.
569 for (i = 0; i < n_capabilities; i++) {
570 for (bd = capabilities[i].mut_lists[g];
571 bd->link != NULL; bd = bd->link) {
574 bd->link = generations[g].mut_list;
575 generations[g].mut_list = capabilities[i].mut_lists[g];
576 capabilities[i].mut_lists[g] = allocBlock();
580 /* Allocate a mark stack if we're doing a major collection.
583 mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
584 mark_stack = (StgPtr *)mark_stack_bdescr->start;
585 mark_sp = mark_stack;
586 mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
588 mark_stack_bdescr = NULL;
591 eager_promotion = rtsTrue; // for now
593 /* -----------------------------------------------------------------------
594 * follow all the roots that we know about:
595 * - mutable lists from each generation > N
596 * we want to *scavenge* these roots, not evacuate them: they're not
597 * going to move in this GC.
598 * Also: do them in reverse generation order. This is because we
599 * often want to promote objects that are pointed to by older
600 * generations early, so we don't have to repeatedly copy them.
601 * Doing the generations in reverse order ensures that we don't end
602 * up in the situation where we want to evac an object to gen 3 and
603 * it has already been evaced to gen 2.
607 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
608 generations[g].saved_mut_list = generations[g].mut_list;
609 generations[g].mut_list = allocBlock();
610 // mut_list always has at least one block.
613 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
614 IF_PAR_DEBUG(verbose, printMutableList(&generations[g]));
615 scavenge_mutable_list(&generations[g]);
617 for (st = generations[g].n_steps-1; st >= 0; st--) {
618 scavenge(&generations[g].steps[st]);
623 /* follow roots from the CAF list (used by GHCi)
628 /* follow all the roots that the application knows about.
631 get_roots(mark_root);
634 /* And don't forget to mark the TSO if we got here direct from
636 /* Not needed in a seq version?
638 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
642 // Mark the entries in the GALA table of the parallel system
643 markLocalGAs(major_gc);
644 // Mark all entries on the list of pending fetches
645 markPendingFetches(major_gc);
648 /* Mark the weak pointer list, and prepare to detect dead weak
651 mark_weak_ptr_list(&weak_ptr_list);
652 old_weak_ptr_list = weak_ptr_list;
653 weak_ptr_list = NULL;
654 weak_stage = WeakPtrs;
656 /* The all_threads list is like the weak_ptr_list.
657 * See traverse_weak_ptr_list() for the details.
659 old_all_threads = all_threads;
660 all_threads = END_TSO_QUEUE;
661 resurrected_threads = END_TSO_QUEUE;
663 /* Mark the stable pointer table.
665 markStablePtrTable(mark_root);
667 /* Mark the root pointer table.
669 markRootPtrTable(mark_root);
671 /* -------------------------------------------------------------------------
672 * Repeatedly scavenge all the areas we know about until there's no
673 * more scavenging to be done.
680 // scavenge static objects
681 if (major_gc && static_objects != END_OF_STATIC_LIST) {
682 IF_DEBUG(sanity, checkStaticObjects(static_objects));
686 /* When scavenging the older generations: Objects may have been
687 * evacuated from generations <= N into older generations, and we
688 * need to scavenge these objects. We're going to try to ensure that
689 * any evacuations that occur move the objects into at least the
690 * same generation as the object being scavenged, otherwise we
691 * have to create new entries on the mutable list for the older
695 // scavenge each step in generations 0..maxgen
701 // scavenge objects in compacted generation
702 if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
703 (mark_stack_bdescr != NULL && !mark_stack_empty())) {
704 scavenge_mark_stack();
708 for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
709 for (st = generations[gen].n_steps; --st >= 0; ) {
710 if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
713 stp = &generations[gen].steps[st];
715 if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
720 if (stp->new_large_objects != NULL) {
729 // if any blackholes are alive, make the threads that wait on
731 if (traverse_blackhole_queue())
734 if (flag) { goto loop; }
736 // must be last... invariant is that everything is fully
737 // scavenged at this point.
738 if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something
743 /* Update the pointers from the task list - these are
744 * treated as weak pointers because we want to allow a main thread
745 * to get a BlockedOnDeadMVar exception in the same way as any other
746 * thread. Note that the threads should all have been retained by
747 * GC by virtue of being on the all_threads list, we're just
748 * updating pointers here.
753 for (task = all_tasks; task != NULL; task = task->all_link) {
754 if (!task->stopped && task->tso) {
755 ASSERT(task->tso->bound == task);
756 tso = (StgTSO *) isAlive((StgClosure *)task->tso);
758 barf("task %p: main thread %d has been GC'd",
772 // Reconstruct the Global Address tables used in GUM
773 rebuildGAtables(major_gc);
774 IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
777 // Now see which stable names are still alive.
780 // Tidy the end of the to-space chains
781 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
782 for (s = 0; s < generations[g].n_steps; s++) {
783 stp = &generations[g].steps[s];
784 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
785 ASSERT(Bdescr(stp->hp) == stp->hp_bd);
786 stp->hp_bd->free = stp->hp;
787 Bdescr(stp->scavd_hp)->free = stp->scavd_hp;
793 // We call processHeapClosureForDead() on every closure destroyed during
794 // the current garbage collection, so we invoke LdvCensusForDead().
795 if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
796 || RtsFlags.ProfFlags.bioSelector != NULL)
800 // NO MORE EVACUATION AFTER THIS POINT!
801 // Finally: compaction of the oldest generation.
802 if (major_gc && oldest_gen->steps[0].is_compacted) {
803 // save number of blocks for stats
804 oldgen_saved_blocks = oldest_gen->steps[0].n_old_blocks;
808 IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
810 /* run through all the generations/steps and tidy up
812 copied = new_blocks * BLOCK_SIZE_W;
813 scavd_copied = new_scavd_blocks * BLOCK_SIZE_W;
814 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
817 generations[g].collections++; // for stats
820 // Count the mutable list as bytes "copied" for the purposes of
821 // stats. Every mutable list is copied during every GC.
823 nat mut_list_size = 0;
824 for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
825 mut_list_size += bd->free - bd->start;
827 copied += mut_list_size;
830 "mut_list_size: %lu (%d vars, %d arrays, %d others)",
831 (unsigned long)(mut_list_size * sizeof(W_)),
832 mutlist_MUTVARS, mutlist_MUTARRS, mutlist_OTHERS);
835 for (s = 0; s < generations[g].n_steps; s++) {
837 stp = &generations[g].steps[s];
839 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
840 // stats information: how much we copied
842 copied -= stp->hp_bd->start + BLOCK_SIZE_W -
844 scavd_copied -= (P_)(BLOCK_ROUND_UP(stp->scavd_hp)) - stp->scavd_hp;
848 // for generations we collected...
851 /* free old memory and shift to-space into from-space for all
852 * the collected steps (except the allocation area). These
853 * freed blocks will probaby be quickly recycled.
855 if (!(g == 0 && s == 0)) {
856 if (stp->is_compacted) {
857 // for a compacted step, just shift the new to-space
858 // onto the front of the now-compacted existing blocks.
859 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
860 bd->flags &= ~BF_EVACUATED; // now from-space
862 // tack the new blocks on the end of the existing blocks
863 if (stp->old_blocks != NULL) {
864 for (bd = stp->old_blocks; bd != NULL; bd = next) {
865 // NB. this step might not be compacted next
866 // time, so reset the BF_COMPACTED flags.
867 // They are set before GC if we're going to
868 // compact. (search for BF_COMPACTED above).
869 bd->flags &= ~BF_COMPACTED;
872 bd->link = stp->blocks;
875 stp->blocks = stp->old_blocks;
877 // add the new blocks to the block tally
878 stp->n_blocks += stp->n_old_blocks;
879 ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
881 freeChain(stp->old_blocks);
882 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
883 bd->flags &= ~BF_EVACUATED; // now from-space
886 stp->old_blocks = NULL;
887 stp->n_old_blocks = 0;
890 /* LARGE OBJECTS. The current live large objects are chained on
891 * scavenged_large, having been moved during garbage
892 * collection from large_objects. Any objects left on
893 * large_objects list are therefore dead, so we free them here.
895 for (bd = stp->large_objects; bd != NULL; bd = next) {
901 // update the count of blocks used by large objects
902 for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
903 bd->flags &= ~BF_EVACUATED;
905 stp->large_objects = stp->scavenged_large_objects;
906 stp->n_large_blocks = stp->n_scavenged_large_blocks;
909 // for older generations...
911 /* For older generations, we need to append the
912 * scavenged_large_object list (i.e. large objects that have been
913 * promoted during this GC) to the large_object list for that step.
915 for (bd = stp->scavenged_large_objects; bd; bd = next) {
917 bd->flags &= ~BF_EVACUATED;
918 dbl_link_onto(bd, &stp->large_objects);
921 // add the new blocks we promoted during this GC
922 stp->n_large_blocks += stp->n_scavenged_large_blocks;
927 /* Reset the sizes of the older generations when we do a major
930 * CURRENT STRATEGY: make all generations except zero the same size.
931 * We have to stay within the maximum heap size, and leave a certain
932 * percentage of the maximum heap size available to allocate into.
934 if (major_gc && RtsFlags.GcFlags.generations > 1) {
935 nat live, size, min_alloc;
936 nat max = RtsFlags.GcFlags.maxHeapSize;
937 nat gens = RtsFlags.GcFlags.generations;
939 // live in the oldest generations
940 live = oldest_gen->steps[0].n_blocks +
941 oldest_gen->steps[0].n_large_blocks;
943 // default max size for all generations except zero
944 size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
945 RtsFlags.GcFlags.minOldGenSize);
947 // minimum size for generation zero
948 min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
949 RtsFlags.GcFlags.minAllocAreaSize);
951 // Auto-enable compaction when the residency reaches a
952 // certain percentage of the maximum heap size (default: 30%).
953 if (RtsFlags.GcFlags.generations > 1 &&
954 (RtsFlags.GcFlags.compact ||
956 oldest_gen->steps[0].n_blocks >
957 (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
958 oldest_gen->steps[0].is_compacted = 1;
959 // debugBelch("compaction: on\n", live);
961 oldest_gen->steps[0].is_compacted = 0;
962 // debugBelch("compaction: off\n", live);
965 // if we're going to go over the maximum heap size, reduce the
966 // size of the generations accordingly. The calculation is
967 // different if compaction is turned on, because we don't need
968 // to double the space required to collect the old generation.
971 // this test is necessary to ensure that the calculations
972 // below don't have any negative results - we're working
973 // with unsigned values here.
974 if (max < min_alloc) {
978 if (oldest_gen->steps[0].is_compacted) {
979 if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
980 size = (max - min_alloc) / ((gens - 1) * 2 - 1);
983 if ( (size * (gens - 1) * 2) + min_alloc > max ) {
984 size = (max - min_alloc) / ((gens - 1) * 2);
994 debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live,
995 min_alloc, size, max);
998 for (g = 0; g < gens; g++) {
999 generations[g].max_blocks = size;
1003 // Guess the amount of live data for stats.
1006 /* Free the small objects allocated via allocate(), since this will
1007 * all have been copied into G0S1 now.
1009 if (small_alloc_list != NULL) {
1010 freeChain(small_alloc_list);
1012 small_alloc_list = NULL;
1016 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
1018 // Start a new pinned_object_block
1019 pinned_object_block = NULL;
1021 /* Free the mark stack.
1023 if (mark_stack_bdescr != NULL) {
1024 freeGroup(mark_stack_bdescr);
1027 /* Free any bitmaps.
1029 for (g = 0; g <= N; g++) {
1030 for (s = 0; s < generations[g].n_steps; s++) {
1031 stp = &generations[g].steps[s];
1032 if (stp->bitmap != NULL) {
1033 freeGroup(stp->bitmap);
1039 /* Two-space collector:
1040 * Free the old to-space, and estimate the amount of live data.
1042 if (RtsFlags.GcFlags.generations == 1) {
1045 if (g0s0->old_blocks != NULL) {
1046 freeChain(g0s0->old_blocks);
1048 for (bd = g0s0->blocks; bd != NULL; bd = bd->link) {
1049 bd->flags = 0; // now from-space
1051 g0s0->old_blocks = g0s0->blocks;
1052 g0s0->n_old_blocks = g0s0->n_blocks;
1053 g0s0->blocks = saved_nursery;
1054 g0s0->n_blocks = saved_n_blocks;
1056 /* For a two-space collector, we need to resize the nursery. */
1058 /* set up a new nursery. Allocate a nursery size based on a
1059 * function of the amount of live data (by default a factor of 2)
1060 * Use the blocks from the old nursery if possible, freeing up any
1063 * If we get near the maximum heap size, then adjust our nursery
1064 * size accordingly. If the nursery is the same size as the live
1065 * data (L), then we need 3L bytes. We can reduce the size of the
1066 * nursery to bring the required memory down near 2L bytes.
1068 * A normal 2-space collector would need 4L bytes to give the same
1069 * performance we get from 3L bytes, reducing to the same
1070 * performance at 2L bytes.
1072 blocks = g0s0->n_old_blocks;
1074 if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
1075 blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
1076 RtsFlags.GcFlags.maxHeapSize ) {
1077 long adjusted_blocks; // signed on purpose
1080 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
1082 debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld",
1083 RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks);
1085 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
1086 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
1089 blocks = adjusted_blocks;
1092 blocks *= RtsFlags.GcFlags.oldGenFactor;
1093 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
1094 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1097 resizeNurseries(blocks);
1100 /* Generational collector:
1101 * If the user has given us a suggested heap size, adjust our
1102 * allocation area to make best use of the memory available.
1105 if (RtsFlags.GcFlags.heapSizeSuggestion) {
1107 nat needed = calcNeeded(); // approx blocks needed at next GC
1109 /* Guess how much will be live in generation 0 step 0 next time.
1110 * A good approximation is obtained by finding the
1111 * percentage of g0s0 that was live at the last minor GC.
1114 g0s0_pcnt_kept = (new_blocks * 100) / countNurseryBlocks();
1117 /* Estimate a size for the allocation area based on the
1118 * information available. We might end up going slightly under
1119 * or over the suggested heap size, but we should be pretty
1122 * Formula: suggested - needed
1123 * ----------------------------
1124 * 1 + g0s0_pcnt_kept/100
1126 * where 'needed' is the amount of memory needed at the next
1127 * collection for collecting all steps except g0s0.
1130 (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
1131 (100 + (long)g0s0_pcnt_kept);
1133 if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
1134 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1137 resizeNurseries((nat)blocks);
1140 // we might have added extra large blocks to the nursery, so
1141 // resize back to minAllocAreaSize again.
1142 resizeNurseriesFixed(RtsFlags.GcFlags.minAllocAreaSize);
1146 // mark the garbage collected CAFs as dead
1147 #if 0 && defined(DEBUG) // doesn't work at the moment
1148 if (major_gc) { gcCAFs(); }
1152 // resetStaticObjectForRetainerProfiling() must be called before
1154 resetStaticObjectForRetainerProfiling();
1157 // zero the scavenged static object list
1159 zero_static_object_list(scavenged_static_objects);
1162 // Reset the nursery
1165 // start any pending finalizers
1167 scheduleFinalizers(last_free_capability, old_weak_ptr_list);
1170 // send exceptions to any threads which were about to die
1172 resurrectThreads(resurrected_threads);
1175 // Update the stable pointer hash table.
1176 updateStablePtrTable(major_gc);
1178 // check sanity after GC
1179 IF_DEBUG(sanity, checkSanity());
1181 // extra GC trace info
1182 IF_DEBUG(gc, statDescribeGens());
1185 // symbol-table based profiling
1186 /* heapCensus(to_blocks); */ /* ToDo */
1189 // restore enclosing cost centre
1195 // check for memory leaks if DEBUG is on
1199 #ifdef RTS_GTK_FRONTPANEL
1200 if (RtsFlags.GcFlags.frontpanel) {
1201 updateFrontPanelAfterGC( N, live );
1205 // ok, GC over: tell the stats department what happened.
1206 stat_endGC(allocated, live, copied, scavd_copied, N);
1208 #if defined(RTS_USER_SIGNALS)
1209 // unblock signals again
1210 unblockUserSignals();
1219 /* -----------------------------------------------------------------------------
1222 traverse_weak_ptr_list is called possibly many times during garbage
1223 collection. It returns a flag indicating whether it did any work
1224 (i.e. called evacuate on any live pointers).
1226 Invariant: traverse_weak_ptr_list is called when the heap is in an
1227 idempotent state. That means that there are no pending
1228 evacuate/scavenge operations. This invariant helps the weak
1229 pointer code decide which weak pointers are dead - if there are no
1230 new live weak pointers, then all the currently unreachable ones are
1233 For generational GC: we just don't try to finalize weak pointers in
1234 older generations than the one we're collecting. This could
1235 probably be optimised by keeping per-generation lists of weak
1236 pointers, but for a few weak pointers this scheme will work.
1238 There are three distinct stages to processing weak pointers:
1240 - weak_stage == WeakPtrs
1242 We process all the weak pointers whos keys are alive (evacuate
1243 their values and finalizers), and repeat until we can find no new
1244 live keys. If no live keys are found in this pass, then we
1245 evacuate the finalizers of all the dead weak pointers in order to
1248 - weak_stage == WeakThreads
1250 Now, we discover which *threads* are still alive. Pointers to
1251 threads from the all_threads and main thread lists are the
1252 weakest of all: a pointers from the finalizer of a dead weak
1253 pointer can keep a thread alive. Any threads found to be unreachable
1254 are evacuated and placed on the resurrected_threads list so we
1255 can send them a signal later.
1257 - weak_stage == WeakDone
1259 No more evacuation is done.
1261 -------------------------------------------------------------------------- */
1264 traverse_weak_ptr_list(void)
1266 StgWeak *w, **last_w, *next_w;
1268 rtsBool flag = rtsFalse;
1270 switch (weak_stage) {
1276 /* doesn't matter where we evacuate values/finalizers to, since
1277 * these pointers are treated as roots (iff the keys are alive).
1281 last_w = &old_weak_ptr_list;
1282 for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1284 /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1285 * called on a live weak pointer object. Just remove it.
1287 if (w->header.info == &stg_DEAD_WEAK_info) {
1288 next_w = ((StgDeadWeak *)w)->link;
1293 switch (get_itbl(w)->type) {
1296 next_w = (StgWeak *)((StgEvacuated *)w)->evacuee;
1301 /* Now, check whether the key is reachable.
1303 new = isAlive(w->key);
1306 // evacuate the value and finalizer
1307 w->value = evacuate(w->value);
1308 w->finalizer = evacuate(w->finalizer);
1309 // remove this weak ptr from the old_weak_ptr list
1311 // and put it on the new weak ptr list
1313 w->link = weak_ptr_list;
1317 debugTrace(DEBUG_weak,
1318 "weak pointer still alive at %p -> %p",
1323 last_w = &(w->link);
1329 barf("traverse_weak_ptr_list: not WEAK");
1333 /* If we didn't make any changes, then we can go round and kill all
1334 * the dead weak pointers. The old_weak_ptr list is used as a list
1335 * of pending finalizers later on.
1337 if (flag == rtsFalse) {
1338 for (w = old_weak_ptr_list; w; w = w->link) {
1339 w->finalizer = evacuate(w->finalizer);
1342 // Next, move to the WeakThreads stage after fully
1343 // scavenging the finalizers we've just evacuated.
1344 weak_stage = WeakThreads;
1350 /* Now deal with the all_threads list, which behaves somewhat like
1351 * the weak ptr list. If we discover any threads that are about to
1352 * become garbage, we wake them up and administer an exception.
1355 StgTSO *t, *tmp, *next, **prev;
1357 prev = &old_all_threads;
1358 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1360 tmp = (StgTSO *)isAlive((StgClosure *)t);
1366 ASSERT(get_itbl(t)->type == TSO);
1367 switch (t->what_next) {
1368 case ThreadRelocated:
1373 case ThreadComplete:
1374 // finshed or died. The thread might still be alive, but we
1375 // don't keep it on the all_threads list. Don't forget to
1376 // stub out its global_link field.
1377 next = t->global_link;
1378 t->global_link = END_TSO_QUEUE;
1386 // not alive (yet): leave this thread on the
1387 // old_all_threads list.
1388 prev = &(t->global_link);
1389 next = t->global_link;
1392 // alive: move this thread onto the all_threads list.
1393 next = t->global_link;
1394 t->global_link = all_threads;
1401 /* If we evacuated any threads, we need to go back to the scavenger.
1403 if (flag) return rtsTrue;
1405 /* And resurrect any threads which were about to become garbage.
1408 StgTSO *t, *tmp, *next;
1409 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1410 next = t->global_link;
1411 tmp = (StgTSO *)evacuate((StgClosure *)t);
1412 tmp->global_link = resurrected_threads;
1413 resurrected_threads = tmp;
1417 /* Finally, we can update the blackhole_queue. This queue
1418 * simply strings together TSOs blocked on black holes, it is
1419 * not intended to keep anything alive. Hence, we do not follow
1420 * pointers on the blackhole_queue until now, when we have
1421 * determined which TSOs are otherwise reachable. We know at
1422 * this point that all TSOs have been evacuated, however.
1426 for (pt = &blackhole_queue; *pt != END_TSO_QUEUE; pt = &((*pt)->link)) {
1427 *pt = (StgTSO *)isAlive((StgClosure *)*pt);
1428 ASSERT(*pt != NULL);
1432 weak_stage = WeakDone; // *now* we're done,
1433 return rtsTrue; // but one more round of scavenging, please
1436 barf("traverse_weak_ptr_list");
1442 /* -----------------------------------------------------------------------------
1445 Threads on this list behave like weak pointers during the normal
1446 phase of garbage collection: if the blackhole is reachable, then
1447 the thread is reachable too.
1448 -------------------------------------------------------------------------- */
1450 traverse_blackhole_queue (void)
1452 StgTSO *prev, *t, *tmp;
1458 for (t = blackhole_queue; t != END_TSO_QUEUE; prev=t, t = t->link) {
1459 if (! (tmp = (StgTSO *)isAlive((StgClosure*)t))) {
1460 if (isAlive(t->block_info.closure)) {
1461 t = (StgTSO *)evacuate((StgClosure *)t);
1462 if (prev) prev->link = t;
1470 /* -----------------------------------------------------------------------------
1471 After GC, the live weak pointer list may have forwarding pointers
1472 on it, because a weak pointer object was evacuated after being
1473 moved to the live weak pointer list. We remove those forwarding
1476 Also, we don't consider weak pointer objects to be reachable, but
1477 we must nevertheless consider them to be "live" and retain them.
1478 Therefore any weak pointer objects which haven't as yet been
1479 evacuated need to be evacuated now.
1480 -------------------------------------------------------------------------- */
1484 mark_weak_ptr_list ( StgWeak **list )
1486 StgWeak *w, **last_w;
1489 for (w = *list; w; w = w->link) {
1490 // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
1491 ASSERT(w->header.info == &stg_DEAD_WEAK_info
1492 || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
1493 w = (StgWeak *)evacuate((StgClosure *)w);
1495 last_w = &(w->link);
1499 /* -----------------------------------------------------------------------------
1500 isAlive determines whether the given closure is still alive (after
1501 a garbage collection) or not. It returns the new address of the
1502 closure if it is alive, or NULL otherwise.
1504 NOTE: Use it before compaction only!
1505 -------------------------------------------------------------------------- */
1509 isAlive(StgClosure *p)
1511 const StgInfoTable *info;
1516 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1519 // ignore static closures
1521 // ToDo: for static closures, check the static link field.
1522 // Problem here is that we sometimes don't set the link field, eg.
1523 // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1525 if (!HEAP_ALLOCED(p)) {
1529 // ignore closures in generations that we're not collecting.
1531 if (bd->gen_no > N) {
1535 // if it's a pointer into to-space, then we're done
1536 if (bd->flags & BF_EVACUATED) {
1540 // large objects use the evacuated flag
1541 if (bd->flags & BF_LARGE) {
1545 // check the mark bit for compacted steps
1546 if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1550 switch (info->type) {
1555 case IND_OLDGEN: // rely on compatible layout with StgInd
1556 case IND_OLDGEN_PERM:
1557 // follow indirections
1558 p = ((StgInd *)p)->indirectee;
1563 return ((StgEvacuated *)p)->evacuee;
1566 if (((StgTSO *)p)->what_next == ThreadRelocated) {
1567 p = (StgClosure *)((StgTSO *)p)->link;
1580 mark_root(StgClosure **root)
1582 *root = evacuate(*root);
1586 upd_evacuee(StgClosure *p, StgClosure *dest)
1588 // not true: (ToDo: perhaps it should be)
1589 // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
1590 SET_INFO(p, &stg_EVACUATED_info);
1591 ((StgEvacuated *)p)->evacuee = dest;
1595 STATIC_INLINE StgClosure *
1596 copy(StgClosure *src, nat size, step *stp)
1602 nat size_org = size;
1605 TICK_GC_WORDS_COPIED(size);
1606 /* Find out where we're going, using the handy "to" pointer in
1607 * the step of the source object. If it turns out we need to
1608 * evacuate to an older generation, adjust it here (see comment
1611 if (stp->gen_no < evac_gen) {
1612 if (eager_promotion) {
1613 stp = &generations[evac_gen].steps[0];
1615 failed_to_evac = rtsTrue;
1619 /* chain a new block onto the to-space for the destination step if
1622 if (stp->hp + size >= stp->hpLim) {
1623 gc_alloc_block(stp);
1628 stp->hp = to + size;
1629 for (i = 0; i < size; i++) { // unroll for small i
1632 upd_evacuee((StgClosure *)from,(StgClosure *)to);
1635 // We store the size of the just evacuated object in the LDV word so that
1636 // the profiler can guess the position of the next object later.
1637 SET_EVACUAEE_FOR_LDV(from, size_org);
1639 return (StgClosure *)to;
1642 // Same as copy() above, except the object will be allocated in memory
1643 // that will not be scavenged. Used for object that have no pointer
1645 STATIC_INLINE StgClosure *
1646 copy_noscav(StgClosure *src, nat size, step *stp)
1652 nat size_org = size;
1655 TICK_GC_WORDS_COPIED(size);
1656 /* Find out where we're going, using the handy "to" pointer in
1657 * the step of the source object. If it turns out we need to
1658 * evacuate to an older generation, adjust it here (see comment
1661 if (stp->gen_no < evac_gen) {
1662 if (eager_promotion) {
1663 stp = &generations[evac_gen].steps[0];
1665 failed_to_evac = rtsTrue;
1669 /* chain a new block onto the to-space for the destination step if
1672 if (stp->scavd_hp + size >= stp->scavd_hpLim) {
1673 gc_alloc_scavd_block(stp);
1678 stp->scavd_hp = to + size;
1679 for (i = 0; i < size; i++) { // unroll for small i
1682 upd_evacuee((StgClosure *)from,(StgClosure *)to);
1685 // We store the size of the just evacuated object in the LDV word so that
1686 // the profiler can guess the position of the next object later.
1687 SET_EVACUAEE_FOR_LDV(from, size_org);
1689 return (StgClosure *)to;
1692 /* Special version of copy() for when we only want to copy the info
1693 * pointer of an object, but reserve some padding after it. This is
1694 * used to optimise evacuation of BLACKHOLEs.
1699 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1704 nat size_to_copy_org = size_to_copy;
1707 TICK_GC_WORDS_COPIED(size_to_copy);
1708 if (stp->gen_no < evac_gen) {
1709 if (eager_promotion) {
1710 stp = &generations[evac_gen].steps[0];
1712 failed_to_evac = rtsTrue;
1716 if (stp->hp + size_to_reserve >= stp->hpLim) {
1717 gc_alloc_block(stp);
1720 for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1725 stp->hp += size_to_reserve;
1726 upd_evacuee(src,(StgClosure *)dest);
1728 // We store the size of the just evacuated object in the LDV word so that
1729 // the profiler can guess the position of the next object later.
1730 // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1732 SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1734 if (size_to_reserve - size_to_copy_org > 0)
1735 LDV_FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1737 return (StgClosure *)dest;
1741 /* -----------------------------------------------------------------------------
1742 Evacuate a large object
1744 This just consists of removing the object from the (doubly-linked)
1745 step->large_objects list, and linking it on to the (singly-linked)
1746 step->new_large_objects list, from where it will be scavenged later.
1748 Convention: bd->flags has BF_EVACUATED set for a large object
1749 that has been evacuated, or unset otherwise.
1750 -------------------------------------------------------------------------- */
1754 evacuate_large(StgPtr p)
1756 bdescr *bd = Bdescr(p);
1759 // object must be at the beginning of the block (or be a ByteArray)
1760 ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1761 (((W_)p & BLOCK_MASK) == 0));
1763 // already evacuated?
1764 if (bd->flags & BF_EVACUATED) {
1765 /* Don't forget to set the failed_to_evac flag if we didn't get
1766 * the desired destination (see comments in evacuate()).
1768 if (bd->gen_no < evac_gen) {
1769 failed_to_evac = rtsTrue;
1770 TICK_GC_FAILED_PROMOTION();
1776 // remove from large_object list
1778 bd->u.back->link = bd->link;
1779 } else { // first object in the list
1780 stp->large_objects = bd->link;
1783 bd->link->u.back = bd->u.back;
1786 /* link it on to the evacuated large object list of the destination step
1789 if (stp->gen_no < evac_gen) {
1790 if (eager_promotion) {
1791 stp = &generations[evac_gen].steps[0];
1793 failed_to_evac = rtsTrue;
1798 bd->gen_no = stp->gen_no;
1799 bd->link = stp->new_large_objects;
1800 stp->new_large_objects = bd;
1801 bd->flags |= BF_EVACUATED;
1804 /* -----------------------------------------------------------------------------
1807 This is called (eventually) for every live object in the system.
1809 The caller to evacuate specifies a desired generation in the
1810 evac_gen global variable. The following conditions apply to
1811 evacuating an object which resides in generation M when we're
1812 collecting up to generation N
1816 else evac to step->to
1818 if M < evac_gen evac to evac_gen, step 0
1820 if the object is already evacuated, then we check which generation
1823 if M >= evac_gen do nothing
1824 if M < evac_gen set failed_to_evac flag to indicate that we
1825 didn't manage to evacuate this object into evac_gen.
1830 evacuate() is the single most important function performance-wise
1831 in the GC. Various things have been tried to speed it up, but as
1832 far as I can tell the code generated by gcc 3.2 with -O2 is about
1833 as good as it's going to get. We pass the argument to evacuate()
1834 in a register using the 'regparm' attribute (see the prototype for
1835 evacuate() near the top of this file).
1837 Changing evacuate() to take an (StgClosure **) rather than
1838 returning the new pointer seems attractive, because we can avoid
1839 writing back the pointer when it hasn't changed (eg. for a static
1840 object, or an object in a generation > N). However, I tried it and
1841 it doesn't help. One reason is that the (StgClosure **) pointer
1842 gets spilled to the stack inside evacuate(), resulting in far more
1843 extra reads/writes than we save.
1844 -------------------------------------------------------------------------- */
1846 REGPARM1 static StgClosure *
1847 evacuate(StgClosure *q)
1854 const StgInfoTable *info;
1857 ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
1859 if (!HEAP_ALLOCED(q)) {
1861 if (!major_gc) return q;
1864 switch (info->type) {
1867 if (info->srt_bitmap != 0 &&
1868 *THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1869 *THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1870 static_objects = (StgClosure *)q;
1875 if (info->srt_bitmap != 0 &&
1876 *FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1877 *FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1878 static_objects = (StgClosure *)q;
1883 /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1884 * on the CAF list, so don't do anything with it here (we'll
1885 * scavenge it later).
1887 if (((StgIndStatic *)q)->saved_info == NULL
1888 && *IND_STATIC_LINK((StgClosure *)q) == NULL) {
1889 *IND_STATIC_LINK((StgClosure *)q) = static_objects;
1890 static_objects = (StgClosure *)q;
1895 if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
1896 *STATIC_LINK(info,(StgClosure *)q) = static_objects;
1897 static_objects = (StgClosure *)q;
1901 case CONSTR_NOCAF_STATIC:
1902 /* no need to put these on the static linked list, they don't need
1908 barf("evacuate(static): strange closure type %d", (int)(info->type));
1914 if (bd->gen_no > N) {
1915 /* Can't evacuate this object, because it's in a generation
1916 * older than the ones we're collecting. Let's hope that it's
1917 * in evac_gen or older, or we will have to arrange to track
1918 * this pointer using the mutable list.
1920 if (bd->gen_no < evac_gen) {
1922 failed_to_evac = rtsTrue;
1923 TICK_GC_FAILED_PROMOTION();
1928 if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
1930 /* pointer into to-space: just return it. This normally
1931 * shouldn't happen, but alllowing it makes certain things
1932 * slightly easier (eg. the mutable list can contain the same
1933 * object twice, for example).
1935 if (bd->flags & BF_EVACUATED) {
1936 if (bd->gen_no < evac_gen) {
1937 failed_to_evac = rtsTrue;
1938 TICK_GC_FAILED_PROMOTION();
1943 /* evacuate large objects by re-linking them onto a different list.
1945 if (bd->flags & BF_LARGE) {
1947 if (info->type == TSO &&
1948 ((StgTSO *)q)->what_next == ThreadRelocated) {
1949 q = (StgClosure *)((StgTSO *)q)->link;
1952 evacuate_large((P_)q);
1956 /* If the object is in a step that we're compacting, then we
1957 * need to use an alternative evacuate procedure.
1959 if (bd->flags & BF_COMPACTED) {
1960 if (!is_marked((P_)q,bd)) {
1962 if (mark_stack_full()) {
1963 mark_stack_overflowed = rtsTrue;
1966 push_mark_stack((P_)q);
1976 switch (info->type) {
1981 return copy(q,sizeW_fromITBL(info),stp);
1985 StgWord w = (StgWord)q->payload[0];
1986 if (q->header.info == Czh_con_info &&
1987 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
1988 (StgChar)w <= MAX_CHARLIKE) {
1989 return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1991 if (q->header.info == Izh_con_info &&
1992 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1993 return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1996 return copy_noscav(q,sizeofW(StgHeader)+1,stp);
2002 return copy(q,sizeofW(StgHeader)+1,stp);
2006 return copy(q,sizeofW(StgThunk)+1,stp);
2011 #ifdef NO_PROMOTE_THUNKS
2012 if (bd->gen_no == 0 &&
2013 bd->step->no != 0 &&
2014 bd->step->no == generations[bd->gen_no].n_steps-1) {
2018 return copy(q,sizeofW(StgThunk)+2,stp);
2025 return copy(q,sizeofW(StgHeader)+2,stp);
2028 return copy_noscav(q,sizeofW(StgHeader)+2,stp);
2031 return copy(q,thunk_sizeW_fromITBL(info),stp);
2036 case IND_OLDGEN_PERM:
2039 return copy(q,sizeW_fromITBL(info),stp);
2042 return copy(q,bco_sizeW((StgBCO *)q),stp);
2045 case SE_CAF_BLACKHOLE:
2048 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
2050 case THUNK_SELECTOR:
2053 const StgInfoTable *info_ptr;
2055 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2056 return copy(q,THUNK_SELECTOR_sizeW(),stp);
2059 // stashed away for LDV profiling, see below
2060 info_ptr = q->header.info;
2062 p = eval_thunk_selector(info->layout.selector_offset,
2066 return copy(q,THUNK_SELECTOR_sizeW(),stp);
2069 // q is still BLACKHOLE'd.
2070 thunk_selector_depth++;
2072 thunk_selector_depth--;
2075 // For the purposes of LDV profiling, we have destroyed
2076 // the original selector thunk.
2077 SET_INFO(q, info_ptr);
2078 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(q);
2081 // Update the THUNK_SELECTOR with an indirection to the
2082 // EVACUATED closure now at p. Why do this rather than
2083 // upd_evacuee(q,p)? Because we have an invariant that an
2084 // EVACUATED closure always points to an object in the
2085 // same or an older generation (required by the short-cut
2086 // test in the EVACUATED case, below).
2087 SET_INFO(q, &stg_IND_info);
2088 ((StgInd *)q)->indirectee = p;
2090 // For the purposes of LDV profiling, we have created an
2092 LDV_RECORD_CREATE(q);
2100 // follow chains of indirections, don't evacuate them
2101 q = ((StgInd*)q)->indirectee;
2113 case CATCH_STM_FRAME:
2114 case CATCH_RETRY_FRAME:
2115 case ATOMICALLY_FRAME:
2116 // shouldn't see these
2117 barf("evacuate: stack frame at %p\n", q);
2120 return copy(q,pap_sizeW((StgPAP*)q),stp);
2123 return copy(q,ap_sizeW((StgAP*)q),stp);
2126 return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
2129 /* Already evacuated, just return the forwarding address.
2130 * HOWEVER: if the requested destination generation (evac_gen) is
2131 * older than the actual generation (because the object was
2132 * already evacuated to a younger generation) then we have to
2133 * set the failed_to_evac flag to indicate that we couldn't
2134 * manage to promote the object to the desired generation.
2137 * Optimisation: the check is fairly expensive, but we can often
2138 * shortcut it if either the required generation is 0, or the
2139 * current object (the EVACUATED) is in a high enough generation.
2140 * We know that an EVACUATED always points to an object in the
2141 * same or an older generation. stp is the lowest step that the
2142 * current object would be evacuated to, so we only do the full
2143 * check if stp is too low.
2145 if (evac_gen > 0 && stp->gen_no < evac_gen) { // optimisation
2146 StgClosure *p = ((StgEvacuated*)q)->evacuee;
2147 if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
2148 failed_to_evac = rtsTrue;
2149 TICK_GC_FAILED_PROMOTION();
2152 return ((StgEvacuated*)q)->evacuee;
2155 // just copy the block
2156 return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp);
2158 case MUT_ARR_PTRS_CLEAN:
2159 case MUT_ARR_PTRS_DIRTY:
2160 case MUT_ARR_PTRS_FROZEN:
2161 case MUT_ARR_PTRS_FROZEN0:
2162 // just copy the block
2163 return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
2167 StgTSO *tso = (StgTSO *)q;
2169 /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
2171 if (tso->what_next == ThreadRelocated) {
2172 q = (StgClosure *)tso->link;
2176 /* To evacuate a small TSO, we need to relocate the update frame
2183 new_tso = (StgTSO *)copyPart((StgClosure *)tso,
2185 sizeofW(StgTSO), stp);
2186 move_TSO(tso, new_tso);
2187 for (p = tso->sp, q = new_tso->sp;
2188 p < tso->stack+tso->stack_size;) {
2192 return (StgClosure *)new_tso;
2199 //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
2200 to = copy(q,BLACKHOLE_sizeW(),stp);
2201 //ToDo: derive size etc from reverted IP
2202 //to = copy(q,size,stp);
2203 debugTrace(DEBUG_gc, "evacuate: RBH %p (%s) to %p (%s)",
2204 q, info_type(q), to, info_type(to));
2209 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE);
2210 to = copy(q,sizeofW(StgBlockedFetch),stp);
2211 debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2212 q, info_type(q), to, info_type(to));
2219 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2220 to = copy(q,sizeofW(StgFetchMe),stp);
2221 debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2222 q, info_type(q), to, info_type(to)));
2226 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2227 to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2228 debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2229 q, info_type(q), to, info_type(to)));
2234 return copy(q,sizeofW(StgTRecHeader),stp);
2236 case TVAR_WATCH_QUEUE:
2237 return copy(q,sizeofW(StgTVarWatchQueue),stp);
2240 return copy(q,sizeofW(StgTVar),stp);
2243 return copy(q,sizeofW(StgTRecChunk),stp);
2245 case ATOMIC_INVARIANT:
2246 return copy(q,sizeofW(StgAtomicInvariant),stp);
2248 case INVARIANT_CHECK_QUEUE:
2249 return copy(q,sizeofW(StgInvariantCheckQueue),stp);
2252 barf("evacuate: strange closure type %d", (int)(info->type));
2258 /* -----------------------------------------------------------------------------
2259 Evaluate a THUNK_SELECTOR if possible.
2261 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2262 a closure pointer if we evaluated it and this is the result. Note
2263 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2264 reducing it to HNF, just that we have eliminated the selection.
2265 The result might be another thunk, or even another THUNK_SELECTOR.
2267 If the return value is non-NULL, the original selector thunk has
2268 been BLACKHOLE'd, and should be updated with an indirection or a
2269 forwarding pointer. If the return value is NULL, then the selector
2273 ToDo: the treatment of THUNK_SELECTORS could be improved in the
2274 following way (from a suggestion by Ian Lynagh):
2276 We can have a chain like this:
2280 |-----> sel_0 --> (a,b)
2282 |-----> sel_0 --> ...
2284 and the depth limit means we don't go all the way to the end of the
2285 chain, which results in a space leak. This affects the recursive
2286 call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2287 the recursive call to eval_thunk_selector() in
2288 eval_thunk_selector().
2290 We could eliminate the depth bound in this case, in the following
2293 - traverse the chain once to discover the *value* of the
2294 THUNK_SELECTOR. Mark all THUNK_SELECTORS that we
2295 visit on the way as having been visited already (somehow).
2297 - in a second pass, traverse the chain again updating all
2298 THUNK_SEELCTORS that we find on the way with indirections to
2301 - if we encounter a "marked" THUNK_SELECTOR in a normal
2302 evacuate(), we konw it can't be updated so just evac it.
2304 Program that illustrates the problem:
2307 foo (x:xs) = let (ys, zs) = foo xs
2308 in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2310 main = bar [1..(100000000::Int)]
2311 bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2313 -------------------------------------------------------------------------- */
2315 static inline rtsBool
2316 is_to_space ( StgClosure *p )
2320 bd = Bdescr((StgPtr)p);
2321 if (HEAP_ALLOCED(p) &&
2322 ((bd->flags & BF_EVACUATED)
2323 || ((bd->flags & BF_COMPACTED) &&
2324 is_marked((P_)p,bd)))) {
2332 eval_thunk_selector( nat field, StgSelector * p )
2335 const StgInfoTable *info_ptr;
2336 StgClosure *selectee;
2338 selectee = p->selectee;
2340 // Save the real info pointer (NOTE: not the same as get_itbl()).
2341 info_ptr = p->header.info;
2343 // If the THUNK_SELECTOR is in a generation that we are not
2344 // collecting, then bail out early. We won't be able to save any
2345 // space in any case, and updating with an indirection is trickier
2347 if (Bdescr((StgPtr)p)->gen_no > N) {
2351 // BLACKHOLE the selector thunk, since it is now under evaluation.
2352 // This is important to stop us going into an infinite loop if
2353 // this selector thunk eventually refers to itself.
2354 SET_INFO(p,&stg_BLACKHOLE_info);
2358 // We don't want to end up in to-space, because this causes
2359 // problems when the GC later tries to evacuate the result of
2360 // eval_thunk_selector(). There are various ways this could
2363 // 1. following an IND_STATIC
2365 // 2. when the old generation is compacted, the mark phase updates
2366 // from-space pointers to be to-space pointers, and we can't
2367 // reliably tell which we're following (eg. from an IND_STATIC).
2369 // 3. compacting GC again: if we're looking at a constructor in
2370 // the compacted generation, it might point directly to objects
2371 // in to-space. We must bale out here, otherwise doing the selection
2372 // will result in a to-space pointer being returned.
2374 // (1) is dealt with using a BF_EVACUATED test on the
2375 // selectee. (2) and (3): we can tell if we're looking at an
2376 // object in the compacted generation that might point to
2377 // to-space objects by testing that (a) it is BF_COMPACTED, (b)
2378 // the compacted generation is being collected, and (c) the
2379 // object is marked. Only a marked object may have pointers that
2380 // point to to-space objects, because that happens when
2383 // The to-space test is now embodied in the in_to_space() inline
2384 // function, as it is re-used below.
2386 if (is_to_space(selectee)) {
2390 info = get_itbl(selectee);
2391 switch (info->type) {
2399 case CONSTR_NOCAF_STATIC:
2400 // check that the size is in range
2401 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
2402 info->layout.payload.nptrs));
2404 // Select the right field from the constructor, and check
2405 // that the result isn't in to-space. It might be in
2406 // to-space if, for example, this constructor contains
2407 // pointers to younger-gen objects (and is on the mut-once
2412 q = selectee->payload[field];
2413 if (is_to_space(q)) {
2423 case IND_OLDGEN_PERM:
2425 selectee = ((StgInd *)selectee)->indirectee;
2429 // We don't follow pointers into to-space; the constructor
2430 // has already been evacuated, so we won't save any space
2431 // leaks by evaluating this selector thunk anyhow.
2434 case THUNK_SELECTOR:
2438 // check that we don't recurse too much, re-using the
2439 // depth bound also used in evacuate().
2440 if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2443 thunk_selector_depth++;
2445 val = eval_thunk_selector(info->layout.selector_offset,
2446 (StgSelector *)selectee);
2448 thunk_selector_depth--;
2453 // We evaluated this selector thunk, so update it with
2454 // an indirection. NOTE: we don't use UPD_IND here,
2455 // because we are guaranteed that p is in a generation
2456 // that we are collecting, and we never want to put the
2457 // indirection on a mutable list.
2459 // For the purposes of LDV profiling, we have destroyed
2460 // the original selector thunk.
2461 SET_INFO(p, info_ptr);
2462 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2464 ((StgInd *)selectee)->indirectee = val;
2465 SET_INFO(selectee,&stg_IND_info);
2467 // For the purposes of LDV profiling, we have created an
2469 LDV_RECORD_CREATE(selectee);
2486 case SE_CAF_BLACKHOLE:
2498 // not evaluated yet
2502 barf("eval_thunk_selector: strange selectee %d",
2507 // We didn't manage to evaluate this thunk; restore the old info pointer
2508 SET_INFO(p, info_ptr);
2512 /* -----------------------------------------------------------------------------
2513 move_TSO is called to update the TSO structure after it has been
2514 moved from one place to another.
2515 -------------------------------------------------------------------------- */
2518 move_TSO (StgTSO *src, StgTSO *dest)
2522 // relocate the stack pointer...
2523 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2524 dest->sp = (StgPtr)dest->sp + diff;
2527 /* Similar to scavenge_large_bitmap(), but we don't write back the
2528 * pointers we get back from evacuate().
2531 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2538 bitmap = large_srt->l.bitmap[b];
2539 size = (nat)large_srt->l.size;
2540 p = (StgClosure **)large_srt->srt;
2541 for (i = 0; i < size; ) {
2542 if ((bitmap & 1) != 0) {
2547 if (i % BITS_IN(W_) == 0) {
2549 bitmap = large_srt->l.bitmap[b];
2551 bitmap = bitmap >> 1;
2556 /* evacuate the SRT. If srt_bitmap is zero, then there isn't an
2557 * srt field in the info table. That's ok, because we'll
2558 * never dereference it.
2561 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2566 bitmap = srt_bitmap;
2569 if (bitmap == (StgHalfWord)(-1)) {
2570 scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2574 while (bitmap != 0) {
2575 if ((bitmap & 1) != 0) {
2576 #ifdef ENABLE_WIN32_DLL_SUPPORT
2577 // Special-case to handle references to closures hiding out in DLLs, since
2578 // double indirections required to get at those. The code generator knows
2579 // which is which when generating the SRT, so it stores the (indirect)
2580 // reference to the DLL closure in the table by first adding one to it.
2581 // We check for this here, and undo the addition before evacuating it.
2583 // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2584 // closure that's fixed at link-time, and no extra magic is required.
2585 if ( (unsigned long)(*srt) & 0x1 ) {
2586 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2595 bitmap = bitmap >> 1;
2601 scavenge_thunk_srt(const StgInfoTable *info)
2603 StgThunkInfoTable *thunk_info;
2605 if (!major_gc) return;
2607 thunk_info = itbl_to_thunk_itbl(info);
2608 scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2612 scavenge_fun_srt(const StgInfoTable *info)
2614 StgFunInfoTable *fun_info;
2616 if (!major_gc) return;
2618 fun_info = itbl_to_fun_itbl(info);
2619 scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2622 /* -----------------------------------------------------------------------------
2624 -------------------------------------------------------------------------- */
2627 scavengeTSO (StgTSO *tso)
2629 if ( tso->why_blocked == BlockedOnMVar
2630 || tso->why_blocked == BlockedOnBlackHole
2631 || tso->why_blocked == BlockedOnException
2633 || tso->why_blocked == BlockedOnGA
2634 || tso->why_blocked == BlockedOnGA_NoSend
2637 tso->block_info.closure = evacuate(tso->block_info.closure);
2639 tso->blocked_exceptions =
2640 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2642 // We don't always chase the link field: TSOs on the blackhole
2643 // queue are not automatically alive, so the link field is a
2644 // "weak" pointer in that case.
2645 if (tso->why_blocked != BlockedOnBlackHole) {
2646 tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
2649 // scavange current transaction record
2650 tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2652 // scavenge this thread's stack
2653 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2656 /* -----------------------------------------------------------------------------
2657 Blocks of function args occur on the stack (at the top) and
2659 -------------------------------------------------------------------------- */
2661 STATIC_INLINE StgPtr
2662 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2669 switch (fun_info->f.fun_type) {
2671 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2672 size = BITMAP_SIZE(fun_info->f.b.bitmap);
2675 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2676 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2680 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2681 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2684 if ((bitmap & 1) == 0) {
2685 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2688 bitmap = bitmap >> 1;
2696 STATIC_INLINE StgPtr
2697 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2701 StgFunInfoTable *fun_info;
2703 fun_info = get_fun_itbl(fun);
2704 ASSERT(fun_info->i.type != PAP);
2705 p = (StgPtr)payload;
2707 switch (fun_info->f.fun_type) {
2709 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2712 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2716 scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2720 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2723 if ((bitmap & 1) == 0) {
2724 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2727 bitmap = bitmap >> 1;
2735 STATIC_INLINE StgPtr
2736 scavenge_PAP (StgPAP *pap)
2738 pap->fun = evacuate(pap->fun);
2739 return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2742 STATIC_INLINE StgPtr
2743 scavenge_AP (StgAP *ap)
2745 ap->fun = evacuate(ap->fun);
2746 return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2749 /* -----------------------------------------------------------------------------
2750 Scavenge a given step until there are no more objects in this step
2753 evac_gen is set by the caller to be either zero (for a step in a
2754 generation < N) or G where G is the generation of the step being
2757 We sometimes temporarily change evac_gen back to zero if we're
2758 scavenging a mutable object where early promotion isn't such a good
2760 -------------------------------------------------------------------------- */
2768 nat saved_evac_gen = evac_gen;
2773 failed_to_evac = rtsFalse;
2775 /* scavenge phase - standard breadth-first scavenging of the
2779 while (bd != stp->hp_bd || p < stp->hp) {
2781 // If we're at the end of this block, move on to the next block
2782 if (bd != stp->hp_bd && p == bd->free) {
2788 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2789 info = get_itbl((StgClosure *)p);
2791 ASSERT(thunk_selector_depth == 0);
2794 switch (info->type) {
2798 StgMVar *mvar = ((StgMVar *)p);
2800 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2801 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2802 mvar->value = evacuate((StgClosure *)mvar->value);
2803 evac_gen = saved_evac_gen;
2804 failed_to_evac = rtsTrue; // mutable.
2805 p += sizeofW(StgMVar);
2810 scavenge_fun_srt(info);
2811 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2812 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2813 p += sizeofW(StgHeader) + 2;
2817 scavenge_thunk_srt(info);
2818 ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2819 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2820 p += sizeofW(StgThunk) + 2;
2824 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2825 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2826 p += sizeofW(StgHeader) + 2;
2830 scavenge_thunk_srt(info);
2831 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2832 p += sizeofW(StgThunk) + 1;
2836 scavenge_fun_srt(info);
2838 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2839 p += sizeofW(StgHeader) + 1;
2843 scavenge_thunk_srt(info);
2844 p += sizeofW(StgThunk) + 1;
2848 scavenge_fun_srt(info);
2850 p += sizeofW(StgHeader) + 1;
2854 scavenge_thunk_srt(info);
2855 p += sizeofW(StgThunk) + 2;
2859 scavenge_fun_srt(info);
2861 p += sizeofW(StgHeader) + 2;
2865 scavenge_thunk_srt(info);
2866 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2867 p += sizeofW(StgThunk) + 2;
2871 scavenge_fun_srt(info);
2873 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2874 p += sizeofW(StgHeader) + 2;
2878 scavenge_fun_srt(info);
2885 scavenge_thunk_srt(info);
2886 end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2887 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2888 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2890 p += info->layout.payload.nptrs;
2901 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2902 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2903 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2905 p += info->layout.payload.nptrs;
2910 StgBCO *bco = (StgBCO *)p;
2911 bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2912 bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2913 bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2914 bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2915 p += bco_sizeW(bco);
2920 if (stp->gen->no != 0) {
2923 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2924 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2925 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2928 // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2930 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2932 // We pretend that p has just been created.
2933 LDV_RECORD_CREATE((StgClosure *)p);
2936 case IND_OLDGEN_PERM:
2937 ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2938 p += sizeofW(StgInd);
2942 case MUT_VAR_DIRTY: {
2943 rtsBool saved_eager_promotion = eager_promotion;
2945 eager_promotion = rtsFalse;
2946 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2947 eager_promotion = saved_eager_promotion;
2949 if (failed_to_evac) {
2950 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
2952 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
2954 p += sizeofW(StgMutVar);
2959 case SE_CAF_BLACKHOLE:
2962 p += BLACKHOLE_sizeW();
2965 case THUNK_SELECTOR:
2967 StgSelector *s = (StgSelector *)p;
2968 s->selectee = evacuate(s->selectee);
2969 p += THUNK_SELECTOR_sizeW();
2973 // A chunk of stack saved in a heap object
2976 StgAP_STACK *ap = (StgAP_STACK *)p;
2978 ap->fun = evacuate(ap->fun);
2979 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2980 p = (StgPtr)ap->payload + ap->size;
2985 p = scavenge_PAP((StgPAP *)p);
2989 p = scavenge_AP((StgAP *)p);
2993 // nothing to follow
2994 p += arr_words_sizeW((StgArrWords *)p);
2997 case MUT_ARR_PTRS_CLEAN:
2998 case MUT_ARR_PTRS_DIRTY:
2999 // follow everything
3002 rtsBool saved_eager;
3004 // We don't eagerly promote objects pointed to by a mutable
3005 // array, but if we find the array only points to objects in
3006 // the same or an older generation, we mark it "clean" and
3007 // avoid traversing it during minor GCs.
3008 saved_eager = eager_promotion;
3009 eager_promotion = rtsFalse;
3010 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3011 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3012 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3014 eager_promotion = saved_eager;
3016 if (failed_to_evac) {
3017 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3019 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3022 failed_to_evac = rtsTrue; // always put it on the mutable list.
3026 case MUT_ARR_PTRS_FROZEN:
3027 case MUT_ARR_PTRS_FROZEN0:
3028 // follow everything
3032 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3033 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3034 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3037 // If we're going to put this object on the mutable list, then
3038 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3039 if (failed_to_evac) {
3040 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3042 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3049 StgTSO *tso = (StgTSO *)p;
3050 rtsBool saved_eager = eager_promotion;
3052 eager_promotion = rtsFalse;
3054 eager_promotion = saved_eager;
3056 if (failed_to_evac) {
3057 tso->flags |= TSO_DIRTY;
3059 tso->flags &= ~TSO_DIRTY;
3062 failed_to_evac = rtsTrue; // always on the mutable list
3063 p += tso_sizeW(tso);
3071 nat size, ptrs, nonptrs, vhs;
3073 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3075 StgRBH *rbh = (StgRBH *)p;
3076 (StgClosure *)rbh->blocking_queue =
3077 evacuate((StgClosure *)rbh->blocking_queue);
3078 failed_to_evac = rtsTrue; // mutable anyhow.
3079 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3080 p, info_type(p), (StgClosure *)rbh->blocking_queue);
3081 // ToDo: use size of reverted closure here!
3082 p += BLACKHOLE_sizeW();
3088 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3089 // follow the pointer to the node which is being demanded
3090 (StgClosure *)bf->node =
3091 evacuate((StgClosure *)bf->node);
3092 // follow the link to the rest of the blocking queue
3093 (StgClosure *)bf->link =
3094 evacuate((StgClosure *)bf->link);
3095 debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3096 bf, info_type((StgClosure *)bf),
3097 bf->node, info_type(bf->node)));
3098 p += sizeofW(StgBlockedFetch);
3106 p += sizeofW(StgFetchMe);
3107 break; // nothing to do in this case
3111 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3112 (StgClosure *)fmbq->blocking_queue =
3113 evacuate((StgClosure *)fmbq->blocking_queue);
3114 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3115 p, info_type((StgClosure *)p)));
3116 p += sizeofW(StgFetchMeBlockingQueue);
3121 case TVAR_WATCH_QUEUE:
3123 StgTVarWatchQueue *wq = ((StgTVarWatchQueue *) p);
3125 wq->closure = (StgClosure*)evacuate((StgClosure*)wq->closure);
3126 wq->next_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3127 wq->prev_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3128 evac_gen = saved_evac_gen;
3129 failed_to_evac = rtsTrue; // mutable
3130 p += sizeofW(StgTVarWatchQueue);
3136 StgTVar *tvar = ((StgTVar *) p);
3138 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3139 tvar->first_watch_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)tvar->first_watch_queue_entry);
3140 evac_gen = saved_evac_gen;
3141 failed_to_evac = rtsTrue; // mutable
3142 p += sizeofW(StgTVar);
3148 StgTRecHeader *trec = ((StgTRecHeader *) p);
3150 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3151 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3152 trec->invariants_to_check = (StgInvariantCheckQueue *)evacuate((StgClosure*)trec->invariants_to_check);
3153 evac_gen = saved_evac_gen;
3154 failed_to_evac = rtsTrue; // mutable
3155 p += sizeofW(StgTRecHeader);
3162 StgTRecChunk *tc = ((StgTRecChunk *) p);
3163 TRecEntry *e = &(tc -> entries[0]);
3165 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3166 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3167 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3168 e->expected_value = evacuate((StgClosure*)e->expected_value);
3169 e->new_value = evacuate((StgClosure*)e->new_value);
3171 evac_gen = saved_evac_gen;
3172 failed_to_evac = rtsTrue; // mutable
3173 p += sizeofW(StgTRecChunk);
3177 case ATOMIC_INVARIANT:
3179 StgAtomicInvariant *invariant = ((StgAtomicInvariant *) p);
3181 invariant->code = (StgClosure *)evacuate(invariant->code);
3182 invariant->last_execution = (StgTRecHeader *)evacuate((StgClosure*)invariant->last_execution);
3183 evac_gen = saved_evac_gen;
3184 failed_to_evac = rtsTrue; // mutable
3185 p += sizeofW(StgAtomicInvariant);
3189 case INVARIANT_CHECK_QUEUE:
3191 StgInvariantCheckQueue *queue = ((StgInvariantCheckQueue *) p);
3193 queue->invariant = (StgAtomicInvariant *)evacuate((StgClosure*)queue->invariant);
3194 queue->my_execution = (StgTRecHeader *)evacuate((StgClosure*)queue->my_execution);
3195 queue->next_queue_entry = (StgInvariantCheckQueue *)evacuate((StgClosure*)queue->next_queue_entry);
3196 evac_gen = saved_evac_gen;
3197 failed_to_evac = rtsTrue; // mutable
3198 p += sizeofW(StgInvariantCheckQueue);
3203 barf("scavenge: unimplemented/strange closure type %d @ %p",
3208 * We need to record the current object on the mutable list if
3209 * (a) It is actually mutable, or
3210 * (b) It contains pointers to a younger generation.
3211 * Case (b) arises if we didn't manage to promote everything that
3212 * the current object points to into the current generation.
3214 if (failed_to_evac) {
3215 failed_to_evac = rtsFalse;
3216 if (stp->gen_no > 0) {
3217 recordMutableGen((StgClosure *)q, stp->gen);
3226 /* -----------------------------------------------------------------------------
3227 Scavenge everything on the mark stack.
3229 This is slightly different from scavenge():
3230 - we don't walk linearly through the objects, so the scavenger
3231 doesn't need to advance the pointer on to the next object.
3232 -------------------------------------------------------------------------- */
3235 scavenge_mark_stack(void)
3241 evac_gen = oldest_gen->no;
3242 saved_evac_gen = evac_gen;
3245 while (!mark_stack_empty()) {
3246 p = pop_mark_stack();
3248 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3249 info = get_itbl((StgClosure *)p);
3252 switch (info->type) {
3256 StgMVar *mvar = ((StgMVar *)p);
3258 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3259 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3260 mvar->value = evacuate((StgClosure *)mvar->value);
3261 evac_gen = saved_evac_gen;
3262 failed_to_evac = rtsTrue; // mutable.
3267 scavenge_fun_srt(info);
3268 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3269 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3273 scavenge_thunk_srt(info);
3274 ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
3275 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3279 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3280 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3285 scavenge_fun_srt(info);
3286 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3291 scavenge_thunk_srt(info);
3292 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3297 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3302 scavenge_fun_srt(info);
3307 scavenge_thunk_srt(info);
3315 scavenge_fun_srt(info);
3322 scavenge_thunk_srt(info);
3323 end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3324 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3325 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3337 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3338 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3339 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3345 StgBCO *bco = (StgBCO *)p;
3346 bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3347 bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3348 bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3349 bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3354 // don't need to do anything here: the only possible case
3355 // is that we're in a 1-space compacting collector, with
3356 // no "old" generation.
3360 case IND_OLDGEN_PERM:
3361 ((StgInd *)p)->indirectee =
3362 evacuate(((StgInd *)p)->indirectee);
3366 case MUT_VAR_DIRTY: {
3367 rtsBool saved_eager_promotion = eager_promotion;
3369 eager_promotion = rtsFalse;
3370 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3371 eager_promotion = saved_eager_promotion;
3373 if (failed_to_evac) {
3374 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3376 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3382 case SE_CAF_BLACKHOLE:
3388 case THUNK_SELECTOR:
3390 StgSelector *s = (StgSelector *)p;
3391 s->selectee = evacuate(s->selectee);
3395 // A chunk of stack saved in a heap object
3398 StgAP_STACK *ap = (StgAP_STACK *)p;
3400 ap->fun = evacuate(ap->fun);
3401 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3406 scavenge_PAP((StgPAP *)p);
3410 scavenge_AP((StgAP *)p);
3413 case MUT_ARR_PTRS_CLEAN:
3414 case MUT_ARR_PTRS_DIRTY:
3415 // follow everything
3418 rtsBool saved_eager;
3420 // We don't eagerly promote objects pointed to by a mutable
3421 // array, but if we find the array only points to objects in
3422 // the same or an older generation, we mark it "clean" and
3423 // avoid traversing it during minor GCs.
3424 saved_eager = eager_promotion;
3425 eager_promotion = rtsFalse;
3426 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3427 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3428 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3430 eager_promotion = saved_eager;
3432 if (failed_to_evac) {
3433 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3435 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3438 failed_to_evac = rtsTrue; // mutable anyhow.
3442 case MUT_ARR_PTRS_FROZEN:
3443 case MUT_ARR_PTRS_FROZEN0:
3444 // follow everything
3448 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3449 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3450 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3453 // If we're going to put this object on the mutable list, then
3454 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3455 if (failed_to_evac) {
3456 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3458 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3465 StgTSO *tso = (StgTSO *)p;
3466 rtsBool saved_eager = eager_promotion;
3468 eager_promotion = rtsFalse;
3470 eager_promotion = saved_eager;
3472 if (failed_to_evac) {
3473 tso->flags |= TSO_DIRTY;
3475 tso->flags &= ~TSO_DIRTY;
3478 failed_to_evac = rtsTrue; // always on the mutable list
3486 nat size, ptrs, nonptrs, vhs;
3488 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3490 StgRBH *rbh = (StgRBH *)p;
3491 bh->blocking_queue =
3492 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3493 failed_to_evac = rtsTrue; // mutable anyhow.
3494 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3495 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3501 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3502 // follow the pointer to the node which is being demanded
3503 (StgClosure *)bf->node =
3504 evacuate((StgClosure *)bf->node);
3505 // follow the link to the rest of the blocking queue
3506 (StgClosure *)bf->link =
3507 evacuate((StgClosure *)bf->link);
3508 debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3509 bf, info_type((StgClosure *)bf),
3510 bf->node, info_type(bf->node)));
3518 break; // nothing to do in this case
3522 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3523 (StgClosure *)fmbq->blocking_queue =
3524 evacuate((StgClosure *)fmbq->blocking_queue);
3525 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3526 p, info_type((StgClosure *)p)));
3531 case TVAR_WATCH_QUEUE:
3533 StgTVarWatchQueue *wq = ((StgTVarWatchQueue *) p);
3535 wq->closure = (StgClosure*)evacuate((StgClosure*)wq->closure);
3536 wq->next_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3537 wq->prev_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3538 evac_gen = saved_evac_gen;
3539 failed_to_evac = rtsTrue; // mutable
3545 StgTVar *tvar = ((StgTVar *) p);
3547 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3548 tvar->first_watch_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)tvar->first_watch_queue_entry);
3549 evac_gen = saved_evac_gen;
3550 failed_to_evac = rtsTrue; // mutable
3557 StgTRecChunk *tc = ((StgTRecChunk *) p);
3558 TRecEntry *e = &(tc -> entries[0]);
3560 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3561 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3562 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3563 e->expected_value = evacuate((StgClosure*)e->expected_value);
3564 e->new_value = evacuate((StgClosure*)e->new_value);
3566 evac_gen = saved_evac_gen;
3567 failed_to_evac = rtsTrue; // mutable
3573 StgTRecHeader *trec = ((StgTRecHeader *) p);
3575 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3576 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3577 trec->invariants_to_check = (StgInvariantCheckQueue *)evacuate((StgClosure*)trec->invariants_to_check);
3578 evac_gen = saved_evac_gen;
3579 failed_to_evac = rtsTrue; // mutable
3583 case ATOMIC_INVARIANT:
3585 StgAtomicInvariant *invariant = ((StgAtomicInvariant *) p);
3587 invariant->code = (StgClosure *)evacuate(invariant->code);
3588 invariant->last_execution = (StgTRecHeader *)evacuate((StgClosure*)invariant->last_execution);
3589 evac_gen = saved_evac_gen;
3590 failed_to_evac = rtsTrue; // mutable
3594 case INVARIANT_CHECK_QUEUE:
3596 StgInvariantCheckQueue *queue = ((StgInvariantCheckQueue *) p);
3598 queue->invariant = (StgAtomicInvariant *)evacuate((StgClosure*)queue->invariant);
3599 queue->my_execution = (StgTRecHeader *)evacuate((StgClosure*)queue->my_execution);
3600 queue->next_queue_entry = (StgInvariantCheckQueue *)evacuate((StgClosure*)queue->next_queue_entry);
3601 evac_gen = saved_evac_gen;
3602 failed_to_evac = rtsTrue; // mutable
3607 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3611 if (failed_to_evac) {
3612 failed_to_evac = rtsFalse;
3614 recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3618 // mark the next bit to indicate "scavenged"
3619 mark(q+1, Bdescr(q));
3621 } // while (!mark_stack_empty())
3623 // start a new linear scan if the mark stack overflowed at some point
3624 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3625 debugTrace(DEBUG_gc, "scavenge_mark_stack: starting linear scan");
3626 mark_stack_overflowed = rtsFalse;
3627 oldgen_scan_bd = oldest_gen->steps[0].old_blocks;
3628 oldgen_scan = oldgen_scan_bd->start;
3631 if (oldgen_scan_bd) {
3632 // push a new thing on the mark stack
3634 // find a closure that is marked but not scavenged, and start
3636 while (oldgen_scan < oldgen_scan_bd->free
3637 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3641 if (oldgen_scan < oldgen_scan_bd->free) {
3643 // already scavenged?
3644 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3645 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3648 push_mark_stack(oldgen_scan);
3649 // ToDo: bump the linear scan by the actual size of the object
3650 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3654 oldgen_scan_bd = oldgen_scan_bd->link;
3655 if (oldgen_scan_bd != NULL) {
3656 oldgen_scan = oldgen_scan_bd->start;
3662 /* -----------------------------------------------------------------------------
3663 Scavenge one object.
3665 This is used for objects that are temporarily marked as mutable
3666 because they contain old-to-new generation pointers. Only certain
3667 objects can have this property.
3668 -------------------------------------------------------------------------- */
3671 scavenge_one(StgPtr p)
3673 const StgInfoTable *info;
3674 nat saved_evac_gen = evac_gen;
3677 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3678 info = get_itbl((StgClosure *)p);
3680 switch (info->type) {
3684 StgMVar *mvar = ((StgMVar *)p);
3686 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3687 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3688 mvar->value = evacuate((StgClosure *)mvar->value);
3689 evac_gen = saved_evac_gen;
3690 failed_to_evac = rtsTrue; // mutable.
3703 end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3704 for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3705 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3711 case FUN_1_0: // hardly worth specialising these guys
3727 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3728 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3729 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3735 case MUT_VAR_DIRTY: {
3737 rtsBool saved_eager_promotion = eager_promotion;
3739 eager_promotion = rtsFalse;
3740 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3741 eager_promotion = saved_eager_promotion;
3743 if (failed_to_evac) {
3744 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3746 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3752 case SE_CAF_BLACKHOLE:
3757 case THUNK_SELECTOR:
3759 StgSelector *s = (StgSelector *)p;
3760 s->selectee = evacuate(s->selectee);
3766 StgAP_STACK *ap = (StgAP_STACK *)p;
3768 ap->fun = evacuate(ap->fun);
3769 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3770 p = (StgPtr)ap->payload + ap->size;
3775 p = scavenge_PAP((StgPAP *)p);
3779 p = scavenge_AP((StgAP *)p);
3783 // nothing to follow
3786 case MUT_ARR_PTRS_CLEAN:
3787 case MUT_ARR_PTRS_DIRTY:
3790 rtsBool saved_eager;
3792 // We don't eagerly promote objects pointed to by a mutable
3793 // array, but if we find the array only points to objects in
3794 // the same or an older generation, we mark it "clean" and
3795 // avoid traversing it during minor GCs.
3796 saved_eager = eager_promotion;
3797 eager_promotion = rtsFalse;
3799 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3800 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3801 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3803 eager_promotion = saved_eager;
3805 if (failed_to_evac) {
3806 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3808 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3811 failed_to_evac = rtsTrue;
3815 case MUT_ARR_PTRS_FROZEN:
3816 case MUT_ARR_PTRS_FROZEN0:
3818 // follow everything
3821 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3822 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3823 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3826 // If we're going to put this object on the mutable list, then
3827 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3828 if (failed_to_evac) {
3829 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3831 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3838 StgTSO *tso = (StgTSO *)p;
3839 rtsBool saved_eager = eager_promotion;
3841 eager_promotion = rtsFalse;
3843 eager_promotion = saved_eager;
3845 if (failed_to_evac) {
3846 tso->flags |= TSO_DIRTY;
3848 tso->flags &= ~TSO_DIRTY;
3851 failed_to_evac = rtsTrue; // always on the mutable list
3859 nat size, ptrs, nonptrs, vhs;
3861 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3863 StgRBH *rbh = (StgRBH *)p;
3864 (StgClosure *)rbh->blocking_queue =
3865 evacuate((StgClosure *)rbh->blocking_queue);
3866 failed_to_evac = rtsTrue; // mutable anyhow.
3867 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3868 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3869 // ToDo: use size of reverted closure here!
3875 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3876 // follow the pointer to the node which is being demanded
3877 (StgClosure *)bf->node =
3878 evacuate((StgClosure *)bf->node);
3879 // follow the link to the rest of the blocking queue
3880 (StgClosure *)bf->link =
3881 evacuate((StgClosure *)bf->link);
3882 debugTrace(DEBUG_gc,
3883 "scavenge: %p (%s); node is now %p; exciting, isn't it",
3884 bf, info_type((StgClosure *)bf),
3885 bf->node, info_type(bf->node)));
3893 break; // nothing to do in this case
3897 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3898 (StgClosure *)fmbq->blocking_queue =
3899 evacuate((StgClosure *)fmbq->blocking_queue);
3900 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3901 p, info_type((StgClosure *)p)));
3906 case TVAR_WATCH_QUEUE:
3908 StgTVarWatchQueue *wq = ((StgTVarWatchQueue *) p);
3910 wq->closure = (StgClosure*)evacuate((StgClosure*)wq->closure);
3911 wq->next_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3912 wq->prev_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3913 evac_gen = saved_evac_gen;
3914 failed_to_evac = rtsTrue; // mutable
3920 StgTVar *tvar = ((StgTVar *) p);
3922 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3923 tvar->first_watch_queue_entry = (StgTVarWatchQueue *)evacuate((StgClosure*)tvar->first_watch_queue_entry);
3924 evac_gen = saved_evac_gen;
3925 failed_to_evac = rtsTrue; // mutable
3931 StgTRecHeader *trec = ((StgTRecHeader *) p);
3933 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3934 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3935 trec->invariants_to_check = (StgInvariantCheckQueue *)evacuate((StgClosure*)trec->invariants_to_check);
3936 evac_gen = saved_evac_gen;
3937 failed_to_evac = rtsTrue; // mutable
3944 StgTRecChunk *tc = ((StgTRecChunk *) p);
3945 TRecEntry *e = &(tc -> entries[0]);
3947 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3948 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3949 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3950 e->expected_value = evacuate((StgClosure*)e->expected_value);
3951 e->new_value = evacuate((StgClosure*)e->new_value);
3953 evac_gen = saved_evac_gen;
3954 failed_to_evac = rtsTrue; // mutable
3958 case ATOMIC_INVARIANT:
3960 StgAtomicInvariant *invariant = ((StgAtomicInvariant *) p);
3962 invariant->code = (StgClosure *)evacuate(invariant->code);
3963 invariant->last_execution = (StgTRecHeader *)evacuate((StgClosure*)invariant->last_execution);
3964 evac_gen = saved_evac_gen;
3965 failed_to_evac = rtsTrue; // mutable
3969 case INVARIANT_CHECK_QUEUE:
3971 StgInvariantCheckQueue *queue = ((StgInvariantCheckQueue *) p);
3973 queue->invariant = (StgAtomicInvariant *)evacuate((StgClosure*)queue->invariant);
3974 queue->my_execution = (StgTRecHeader *)evacuate((StgClosure*)queue->my_execution);
3975 queue->next_queue_entry = (StgInvariantCheckQueue *)evacuate((StgClosure*)queue->next_queue_entry);
3976 evac_gen = saved_evac_gen;
3977 failed_to_evac = rtsTrue; // mutable
3982 case IND_OLDGEN_PERM:
3985 /* Careful here: a THUNK can be on the mutable list because
3986 * it contains pointers to young gen objects. If such a thunk
3987 * is updated, the IND_OLDGEN will be added to the mutable
3988 * list again, and we'll scavenge it twice. evacuate()
3989 * doesn't check whether the object has already been
3990 * evacuated, so we perform that check here.
3992 StgClosure *q = ((StgInd *)p)->indirectee;
3993 if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
3996 ((StgInd *)p)->indirectee = evacuate(q);
3999 #if 0 && defined(DEBUG)
4000 if (RtsFlags.DebugFlags.gc)
4001 /* Debugging code to print out the size of the thing we just
4005 StgPtr start = gen->steps[0].scan;
4006 bdescr *start_bd = gen->steps[0].scan_bd;
4008 scavenge(&gen->steps[0]);
4009 if (start_bd != gen->steps[0].scan_bd) {
4010 size += (P_)BLOCK_ROUND_UP(start) - start;
4011 start_bd = start_bd->link;
4012 while (start_bd != gen->steps[0].scan_bd) {
4013 size += BLOCK_SIZE_W;
4014 start_bd = start_bd->link;
4016 size += gen->steps[0].scan -
4017 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
4019 size = gen->steps[0].scan - start;
4021 debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
4027 barf("scavenge_one: strange object %d", (int)(info->type));
4030 no_luck = failed_to_evac;
4031 failed_to_evac = rtsFalse;
4035 /* -----------------------------------------------------------------------------
4036 Scavenging mutable lists.
4038 We treat the mutable list of each generation > N (i.e. all the
4039 generations older than the one being collected) as roots. We also
4040 remove non-mutable objects from the mutable list at this point.
4041 -------------------------------------------------------------------------- */
4044 scavenge_mutable_list(generation *gen)
4049 bd = gen->saved_mut_list;
4052 for (; bd != NULL; bd = bd->link) {
4053 for (q = bd->start; q < bd->free; q++) {
4055 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
4058 switch (get_itbl((StgClosure *)p)->type) {
4060 barf("MUT_VAR_CLEAN on mutable list");
4062 mutlist_MUTVARS++; break;
4063 case MUT_ARR_PTRS_CLEAN:
4064 case MUT_ARR_PTRS_DIRTY:
4065 case MUT_ARR_PTRS_FROZEN:
4066 case MUT_ARR_PTRS_FROZEN0:
4067 mutlist_MUTARRS++; break;
4069 mutlist_OTHERS++; break;
4073 // Check whether this object is "clean", that is it
4074 // definitely doesn't point into a young generation.
4075 // Clean objects don't need to be scavenged. Some clean
4076 // objects (MUT_VAR_CLEAN) are not kept on the mutable
4077 // list at all; others, such as MUT_ARR_PTRS_CLEAN and
4078 // TSO, are always on the mutable list.
4080 switch (get_itbl((StgClosure *)p)->type) {
4081 case MUT_ARR_PTRS_CLEAN:
4082 recordMutableGen((StgClosure *)p,gen);
4085 StgTSO *tso = (StgTSO *)p;
4086 if ((tso->flags & TSO_DIRTY) == 0) {
4087 // A clean TSO: we don't have to traverse its
4088 // stack. However, we *do* follow the link field:
4089 // we don't want to have to mark a TSO dirty just
4090 // because we put it on a different queue.
4091 if (tso->why_blocked != BlockedOnBlackHole) {
4092 tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
4094 recordMutableGen((StgClosure *)p,gen);
4102 if (scavenge_one(p)) {
4103 // didn't manage to promote everything, so put the
4104 // object back on the list.
4105 recordMutableGen((StgClosure *)p,gen);
4110 // free the old mut_list
4111 freeChain(gen->saved_mut_list);
4112 gen->saved_mut_list = NULL;
4117 scavenge_static(void)
4119 StgClosure* p = static_objects;
4120 const StgInfoTable *info;
4122 /* Always evacuate straight to the oldest generation for static
4124 evac_gen = oldest_gen->no;
4126 /* keep going until we've scavenged all the objects on the linked
4128 while (p != END_OF_STATIC_LIST) {
4130 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
4133 if (info->type==RBH)
4134 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
4136 // make sure the info pointer is into text space
4138 /* Take this object *off* the static_objects list,
4139 * and put it on the scavenged_static_objects list.
4141 static_objects = *STATIC_LINK(info,p);
4142 *STATIC_LINK(info,p) = scavenged_static_objects;
4143 scavenged_static_objects = p;
4145 switch (info -> type) {
4149 StgInd *ind = (StgInd *)p;
4150 ind->indirectee = evacuate(ind->indirectee);
4152 /* might fail to evacuate it, in which case we have to pop it
4153 * back on the mutable list of the oldest generation. We
4154 * leave it *on* the scavenged_static_objects list, though,
4155 * in case we visit this object again.
4157 if (failed_to_evac) {
4158 failed_to_evac = rtsFalse;
4159 recordMutableGen((StgClosure *)p,oldest_gen);
4165 scavenge_thunk_srt(info);
4169 scavenge_fun_srt(info);
4176 next = (P_)p->payload + info->layout.payload.ptrs;
4177 // evacuate the pointers
4178 for (q = (P_)p->payload; q < next; q++) {
4179 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
4185 barf("scavenge_static: strange closure %d", (int)(info->type));
4188 ASSERT(failed_to_evac == rtsFalse);
4190 /* get the next static object from the list. Remember, there might
4191 * be more stuff on this list now that we've done some evacuating!
4192 * (static_objects is a global)
4198 /* -----------------------------------------------------------------------------
4199 scavenge a chunk of memory described by a bitmap
4200 -------------------------------------------------------------------------- */
4203 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
4209 bitmap = large_bitmap->bitmap[b];
4210 for (i = 0; i < size; ) {
4211 if ((bitmap & 1) == 0) {
4212 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4216 if (i % BITS_IN(W_) == 0) {
4218 bitmap = large_bitmap->bitmap[b];
4220 bitmap = bitmap >> 1;
4225 STATIC_INLINE StgPtr
4226 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
4229 if ((bitmap & 1) == 0) {
4230 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4233 bitmap = bitmap >> 1;
4239 /* -----------------------------------------------------------------------------
4240 scavenge_stack walks over a section of stack and evacuates all the
4241 objects pointed to by it. We can use the same code for walking
4242 AP_STACK_UPDs, since these are just sections of copied stack.
4243 -------------------------------------------------------------------------- */
4247 scavenge_stack(StgPtr p, StgPtr stack_end)
4249 const StgRetInfoTable* info;
4254 * Each time around this loop, we are looking at a chunk of stack
4255 * that starts with an activation record.
4258 while (p < stack_end) {
4259 info = get_ret_itbl((StgClosure *)p);
4261 switch (info->i.type) {
4264 // In SMP, we can get update frames that point to indirections
4265 // when two threads evaluate the same thunk. We do attempt to
4266 // discover this situation in threadPaused(), but it's
4267 // possible that the following sequence occurs:
4276 // Now T is an indirection, and the update frame is already
4277 // marked on A's stack, so we won't traverse it again in
4278 // threadPaused(). We could traverse the whole stack again
4279 // before GC, but that seems like overkill.
4281 // Scavenging this update frame as normal would be disastrous;
4282 // the updatee would end up pointing to the value. So we turn
4283 // the indirection into an IND_PERM, so that evacuate will
4284 // copy the indirection into the old generation instead of
4286 if (get_itbl(((StgUpdateFrame *)p)->updatee)->type == IND) {
4287 ((StgUpdateFrame *)p)->updatee->header.info =
4288 (StgInfoTable *)&stg_IND_PERM_info;
4290 ((StgUpdateFrame *)p)->updatee
4291 = evacuate(((StgUpdateFrame *)p)->updatee);
4292 p += sizeofW(StgUpdateFrame);
4295 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
4296 case CATCH_STM_FRAME:
4297 case CATCH_RETRY_FRAME:
4298 case ATOMICALLY_FRAME:
4303 bitmap = BITMAP_BITS(info->i.layout.bitmap);
4304 size = BITMAP_SIZE(info->i.layout.bitmap);
4305 // NOTE: the payload starts immediately after the info-ptr, we
4306 // don't have an StgHeader in the same sense as a heap closure.
4308 p = scavenge_small_bitmap(p, size, bitmap);
4312 scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
4320 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4323 size = BCO_BITMAP_SIZE(bco);
4324 scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
4329 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
4335 size = GET_LARGE_BITMAP(&info->i)->size;
4337 scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
4339 // and don't forget to follow the SRT
4343 // Dynamic bitmap: the mask is stored on the stack, and
4344 // there are a number of non-pointers followed by a number
4345 // of pointers above the bitmapped area. (see StgMacros.h,
4350 dyn = ((StgRetDyn *)p)->liveness;
4352 // traverse the bitmap first
4353 bitmap = RET_DYN_LIVENESS(dyn);
4354 p = (P_)&((StgRetDyn *)p)->payload[0];
4355 size = RET_DYN_BITMAP_SIZE;
4356 p = scavenge_small_bitmap(p, size, bitmap);
4358 // skip over the non-ptr words
4359 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
4361 // follow the ptr words
4362 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
4363 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4371 StgRetFun *ret_fun = (StgRetFun *)p;
4372 StgFunInfoTable *fun_info;
4374 ret_fun->fun = evacuate(ret_fun->fun);
4375 fun_info = get_fun_itbl(ret_fun->fun);
4376 p = scavenge_arg_block(fun_info, ret_fun->payload);
4381 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
4386 /*-----------------------------------------------------------------------------
4387 scavenge the large object list.
4389 evac_gen set by caller; similar games played with evac_gen as with
4390 scavenge() - see comment at the top of scavenge(). Most large
4391 objects are (repeatedly) mutable, so most of the time evac_gen will
4393 --------------------------------------------------------------------------- */
4396 scavenge_large(step *stp)
4401 bd = stp->new_large_objects;
4403 for (; bd != NULL; bd = stp->new_large_objects) {
4405 /* take this object *off* the large objects list and put it on
4406 * the scavenged large objects list. This is so that we can
4407 * treat new_large_objects as a stack and push new objects on
4408 * the front when evacuating.
4410 stp->new_large_objects = bd->link;
4411 dbl_link_onto(bd, &stp->scavenged_large_objects);
4413 // update the block count in this step.
4414 stp->n_scavenged_large_blocks += bd->blocks;
4417 if (scavenge_one(p)) {
4418 if (stp->gen_no > 0) {
4419 recordMutableGen((StgClosure *)p, stp->gen);
4425 /* -----------------------------------------------------------------------------
4426 Initialising the static object & mutable lists
4427 -------------------------------------------------------------------------- */
4430 zero_static_object_list(StgClosure* first_static)
4434 const StgInfoTable *info;
4436 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
4438 link = *STATIC_LINK(info, p);
4439 *STATIC_LINK(info,p) = NULL;
4443 /* -----------------------------------------------------------------------------
4445 -------------------------------------------------------------------------- */
4452 for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4453 c = (StgIndStatic *)c->static_link)
4455 SET_INFO(c, c->saved_info);
4456 c->saved_info = NULL;
4457 // could, but not necessary: c->static_link = NULL;
4459 revertible_caf_list = NULL;
4463 markCAFs( evac_fn evac )
4467 for (c = (StgIndStatic *)caf_list; c != NULL;
4468 c = (StgIndStatic *)c->static_link)
4470 evac(&c->indirectee);
4472 for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4473 c = (StgIndStatic *)c->static_link)
4475 evac(&c->indirectee);
4479 /* -----------------------------------------------------------------------------
4480 Sanity code for CAF garbage collection.
4482 With DEBUG turned on, we manage a CAF list in addition to the SRT
4483 mechanism. After GC, we run down the CAF list and blackhole any
4484 CAFs which have been garbage collected. This means we get an error
4485 whenever the program tries to enter a garbage collected CAF.
4487 Any garbage collected CAFs are taken off the CAF list at the same
4489 -------------------------------------------------------------------------- */
4491 #if 0 && defined(DEBUG)
4498 const StgInfoTable *info;
4509 ASSERT(info->type == IND_STATIC);
4511 if (STATIC_LINK(info,p) == NULL) {
4512 debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p);
4514 SET_INFO(p,&stg_BLACKHOLE_info);
4515 p = STATIC_LINK2(info,p);
4519 pp = &STATIC_LINK2(info,p);
4526 debugTrace(DEBUG_gccafs, "%d CAFs live", i);
4531 /* -----------------------------------------------------------------------------
4534 * Code largely pinched from old RTS, then hacked to bits. We also do
4535 * lazy black holing here.
4537 * -------------------------------------------------------------------------- */
4539 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4542 stackSqueeze(StgTSO *tso, StgPtr bottom)
4545 rtsBool prev_was_update_frame;
4546 StgClosure *updatee = NULL;
4547 StgRetInfoTable *info;
4548 StgWord current_gap_size;
4549 struct stack_gap *gap;
4552 // Traverse the stack upwards, replacing adjacent update frames
4553 // with a single update frame and a "stack gap". A stack gap
4554 // contains two values: the size of the gap, and the distance
4555 // to the next gap (or the stack top).
4559 ASSERT(frame < bottom);
4561 prev_was_update_frame = rtsFalse;
4562 current_gap_size = 0;
4563 gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4565 while (frame < bottom) {
4567 info = get_ret_itbl((StgClosure *)frame);
4568 switch (info->i.type) {
4572 StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4574 if (prev_was_update_frame) {
4576 TICK_UPD_SQUEEZED();
4577 /* wasn't there something about update squeezing and ticky to be
4578 * sorted out? oh yes: we aren't counting each enter properly
4579 * in this case. See the log somewhere. KSW 1999-04-21
4581 * Check two things: that the two update frames don't point to
4582 * the same object, and that the updatee_bypass isn't already an
4583 * indirection. Both of these cases only happen when we're in a
4584 * block hole-style loop (and there are multiple update frames
4585 * on the stack pointing to the same closure), but they can both
4586 * screw us up if we don't check.
4588 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4589 UPD_IND_NOLOCK(upd->updatee, updatee);
4592 // now mark this update frame as a stack gap. The gap
4593 // marker resides in the bottom-most update frame of
4594 // the series of adjacent frames, and covers all the
4595 // frames in this series.
4596 current_gap_size += sizeofW(StgUpdateFrame);
4597 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4598 ((struct stack_gap *)frame)->next_gap = gap;
4600 frame += sizeofW(StgUpdateFrame);
4604 // single update frame, or the topmost update frame in a series
4606 prev_was_update_frame = rtsTrue;
4607 updatee = upd->updatee;
4608 frame += sizeofW(StgUpdateFrame);
4614 prev_was_update_frame = rtsFalse;
4616 // we're not in a gap... check whether this is the end of a gap
4617 // (an update frame can't be the end of a gap).
4618 if (current_gap_size != 0) {
4619 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4621 current_gap_size = 0;
4623 frame += stack_frame_sizeW((StgClosure *)frame);
4628 if (current_gap_size != 0) {
4629 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4632 // Now we have a stack with gaps in it, and we have to walk down
4633 // shoving the stack up to fill in the gaps. A diagram might
4637 // | ********* | <- sp
4641 // | stack_gap | <- gap | chunk_size
4643 // | ......... | <- gap_end v
4649 // 'sp' points the the current top-of-stack
4650 // 'gap' points to the stack_gap structure inside the gap
4651 // ***** indicates real stack data
4652 // ..... indicates gap
4653 // <empty> indicates unused
4657 void *gap_start, *next_gap_start, *gap_end;
4660 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4661 sp = next_gap_start;
4663 while ((StgPtr)gap > tso->sp) {
4665 // we're working in *bytes* now...
4666 gap_start = next_gap_start;
4667 gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4669 gap = gap->next_gap;
4670 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4672 chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4674 memmove(sp, next_gap_start, chunk_size);
4677 tso->sp = (StgPtr)sp;
4681 /* -----------------------------------------------------------------------------
4684 * We have to prepare for GC - this means doing lazy black holing
4685 * here. We also take the opportunity to do stack squeezing if it's
4687 * -------------------------------------------------------------------------- */
4689 threadPaused(Capability *cap, StgTSO *tso)
4692 StgRetInfoTable *info;
4695 nat words_to_squeeze = 0;
4697 nat weight_pending = 0;
4698 rtsBool prev_was_update_frame;
4700 // Check to see whether we have threads waiting to raise
4701 // exceptions, and we're not blocking exceptions, or are blocked
4702 // interruptibly. This is important; if a thread is running with
4703 // TSO_BLOCKEX and becomes blocked interruptibly, this is the only
4704 // place we ensure that the blocked_exceptions get a chance.
4705 maybePerformBlockedException (cap, tso);
4706 if (tso->what_next == ThreadKilled) { return; }
4708 stack_end = &tso->stack[tso->stack_size];
4710 frame = (StgClosure *)tso->sp;
4713 // If we've already marked this frame, then stop here.
4714 if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) {
4718 info = get_ret_itbl(frame);
4720 switch (info->i.type) {
4724 SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info);
4726 bh = ((StgUpdateFrame *)frame)->updatee;
4728 if (closure_IND(bh) || bh->header.info == &stg_BLACKHOLE_info) {
4729 debugTrace(DEBUG_squeeze,
4730 "suspending duplicate work: %ld words of stack",
4731 (long)((StgPtr)frame - tso->sp));
4733 // If this closure is already an indirection, then
4734 // suspend the computation up to this point:
4735 suspendComputation(cap,tso,(StgPtr)frame);
4737 // Now drop the update frame, and arrange to return
4738 // the value to the frame underneath:
4739 tso->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2;
4740 tso->sp[1] = (StgWord)bh;
4741 tso->sp[0] = (W_)&stg_enter_info;
4743 // And continue with threadPaused; there might be
4744 // yet more computation to suspend.
4745 threadPaused(cap,tso);
4749 if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
4750 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4751 debugBelch("Unexpected lazy BHing required at 0x%04lx\n",(long)bh);
4753 // zero out the slop so that the sanity checker can tell
4754 // where the next closure is.
4755 DEBUG_FILL_SLOP(bh);
4758 // We pretend that bh is now dead.
4759 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4761 SET_INFO(bh,&stg_BLACKHOLE_info);
4763 // We pretend that bh has just been created.
4764 LDV_RECORD_CREATE(bh);
4767 frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4768 if (prev_was_update_frame) {
4769 words_to_squeeze += sizeofW(StgUpdateFrame);
4770 weight += weight_pending;
4773 prev_was_update_frame = rtsTrue;
4779 // normal stack frames; do nothing except advance the pointer
4782 nat frame_size = stack_frame_sizeW(frame);
4783 weight_pending += frame_size;
4784 frame = (StgClosure *)((StgPtr)frame + frame_size);
4785 prev_was_update_frame = rtsFalse;
4791 debugTrace(DEBUG_squeeze,
4792 "words_to_squeeze: %d, weight: %d, squeeze: %s",
4793 words_to_squeeze, weight,
4794 weight < words_to_squeeze ? "YES" : "NO");
4796 // Should we squeeze or not? Arbitrary heuristic: we squeeze if
4797 // the number of words we have to shift down is less than the
4798 // number of stack words we squeeze away by doing so.
4799 if (RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue &&
4800 weight < words_to_squeeze) {
4801 stackSqueeze(tso, (StgPtr)frame);
4805 /* -----------------------------------------------------------------------------
4807 * -------------------------------------------------------------------------- */
4811 printMutableList(generation *gen)
4816 debugBelch("mutable list %p: ", gen->mut_list);
4818 for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
4819 for (p = bd->start; p < bd->free; p++) {
4820 debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));