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_WAIT_QUEUE:
2237 return copy(q,sizeofW(StgTVarWaitQueue),stp);
2240 return copy(q,sizeofW(StgTVar),stp);
2243 return copy(q,sizeofW(StgTRecChunk),stp);
2246 barf("evacuate: strange closure type %d", (int)(info->type));
2252 /* -----------------------------------------------------------------------------
2253 Evaluate a THUNK_SELECTOR if possible.
2255 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2256 a closure pointer if we evaluated it and this is the result. Note
2257 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2258 reducing it to HNF, just that we have eliminated the selection.
2259 The result might be another thunk, or even another THUNK_SELECTOR.
2261 If the return value is non-NULL, the original selector thunk has
2262 been BLACKHOLE'd, and should be updated with an indirection or a
2263 forwarding pointer. If the return value is NULL, then the selector
2267 ToDo: the treatment of THUNK_SELECTORS could be improved in the
2268 following way (from a suggestion by Ian Lynagh):
2270 We can have a chain like this:
2274 |-----> sel_0 --> (a,b)
2276 |-----> sel_0 --> ...
2278 and the depth limit means we don't go all the way to the end of the
2279 chain, which results in a space leak. This affects the recursive
2280 call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2281 the recursive call to eval_thunk_selector() in
2282 eval_thunk_selector().
2284 We could eliminate the depth bound in this case, in the following
2287 - traverse the chain once to discover the *value* of the
2288 THUNK_SELECTOR. Mark all THUNK_SELECTORS that we
2289 visit on the way as having been visited already (somehow).
2291 - in a second pass, traverse the chain again updating all
2292 THUNK_SEELCTORS that we find on the way with indirections to
2295 - if we encounter a "marked" THUNK_SELECTOR in a normal
2296 evacuate(), we konw it can't be updated so just evac it.
2298 Program that illustrates the problem:
2301 foo (x:xs) = let (ys, zs) = foo xs
2302 in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2304 main = bar [1..(100000000::Int)]
2305 bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2307 -------------------------------------------------------------------------- */
2309 static inline rtsBool
2310 is_to_space ( StgClosure *p )
2314 bd = Bdescr((StgPtr)p);
2315 if (HEAP_ALLOCED(p) &&
2316 ((bd->flags & BF_EVACUATED)
2317 || ((bd->flags & BF_COMPACTED) &&
2318 is_marked((P_)p,bd)))) {
2326 eval_thunk_selector( nat field, StgSelector * p )
2329 const StgInfoTable *info_ptr;
2330 StgClosure *selectee;
2332 selectee = p->selectee;
2334 // Save the real info pointer (NOTE: not the same as get_itbl()).
2335 info_ptr = p->header.info;
2337 // If the THUNK_SELECTOR is in a generation that we are not
2338 // collecting, then bail out early. We won't be able to save any
2339 // space in any case, and updating with an indirection is trickier
2341 if (Bdescr((StgPtr)p)->gen_no > N) {
2345 // BLACKHOLE the selector thunk, since it is now under evaluation.
2346 // This is important to stop us going into an infinite loop if
2347 // this selector thunk eventually refers to itself.
2348 SET_INFO(p,&stg_BLACKHOLE_info);
2352 // We don't want to end up in to-space, because this causes
2353 // problems when the GC later tries to evacuate the result of
2354 // eval_thunk_selector(). There are various ways this could
2357 // 1. following an IND_STATIC
2359 // 2. when the old generation is compacted, the mark phase updates
2360 // from-space pointers to be to-space pointers, and we can't
2361 // reliably tell which we're following (eg. from an IND_STATIC).
2363 // 3. compacting GC again: if we're looking at a constructor in
2364 // the compacted generation, it might point directly to objects
2365 // in to-space. We must bale out here, otherwise doing the selection
2366 // will result in a to-space pointer being returned.
2368 // (1) is dealt with using a BF_EVACUATED test on the
2369 // selectee. (2) and (3): we can tell if we're looking at an
2370 // object in the compacted generation that might point to
2371 // to-space objects by testing that (a) it is BF_COMPACTED, (b)
2372 // the compacted generation is being collected, and (c) the
2373 // object is marked. Only a marked object may have pointers that
2374 // point to to-space objects, because that happens when
2377 // The to-space test is now embodied in the in_to_space() inline
2378 // function, as it is re-used below.
2380 if (is_to_space(selectee)) {
2384 info = get_itbl(selectee);
2385 switch (info->type) {
2393 case CONSTR_NOCAF_STATIC:
2394 // check that the size is in range
2395 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
2396 info->layout.payload.nptrs));
2398 // Select the right field from the constructor, and check
2399 // that the result isn't in to-space. It might be in
2400 // to-space if, for example, this constructor contains
2401 // pointers to younger-gen objects (and is on the mut-once
2406 q = selectee->payload[field];
2407 if (is_to_space(q)) {
2417 case IND_OLDGEN_PERM:
2419 selectee = ((StgInd *)selectee)->indirectee;
2423 // We don't follow pointers into to-space; the constructor
2424 // has already been evacuated, so we won't save any space
2425 // leaks by evaluating this selector thunk anyhow.
2428 case THUNK_SELECTOR:
2432 // check that we don't recurse too much, re-using the
2433 // depth bound also used in evacuate().
2434 if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2437 thunk_selector_depth++;
2439 val = eval_thunk_selector(info->layout.selector_offset,
2440 (StgSelector *)selectee);
2442 thunk_selector_depth--;
2447 // We evaluated this selector thunk, so update it with
2448 // an indirection. NOTE: we don't use UPD_IND here,
2449 // because we are guaranteed that p is in a generation
2450 // that we are collecting, and we never want to put the
2451 // indirection on a mutable list.
2453 // For the purposes of LDV profiling, we have destroyed
2454 // the original selector thunk.
2455 SET_INFO(p, info_ptr);
2456 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2458 ((StgInd *)selectee)->indirectee = val;
2459 SET_INFO(selectee,&stg_IND_info);
2461 // For the purposes of LDV profiling, we have created an
2463 LDV_RECORD_CREATE(selectee);
2480 case SE_CAF_BLACKHOLE:
2492 // not evaluated yet
2496 barf("eval_thunk_selector: strange selectee %d",
2501 // We didn't manage to evaluate this thunk; restore the old info pointer
2502 SET_INFO(p, info_ptr);
2506 /* -----------------------------------------------------------------------------
2507 move_TSO is called to update the TSO structure after it has been
2508 moved from one place to another.
2509 -------------------------------------------------------------------------- */
2512 move_TSO (StgTSO *src, StgTSO *dest)
2516 // relocate the stack pointer...
2517 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2518 dest->sp = (StgPtr)dest->sp + diff;
2521 /* Similar to scavenge_large_bitmap(), but we don't write back the
2522 * pointers we get back from evacuate().
2525 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2532 bitmap = large_srt->l.bitmap[b];
2533 size = (nat)large_srt->l.size;
2534 p = (StgClosure **)large_srt->srt;
2535 for (i = 0; i < size; ) {
2536 if ((bitmap & 1) != 0) {
2541 if (i % BITS_IN(W_) == 0) {
2543 bitmap = large_srt->l.bitmap[b];
2545 bitmap = bitmap >> 1;
2550 /* evacuate the SRT. If srt_bitmap is zero, then there isn't an
2551 * srt field in the info table. That's ok, because we'll
2552 * never dereference it.
2555 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2560 bitmap = srt_bitmap;
2563 if (bitmap == (StgHalfWord)(-1)) {
2564 scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2568 while (bitmap != 0) {
2569 if ((bitmap & 1) != 0) {
2570 #ifdef ENABLE_WIN32_DLL_SUPPORT
2571 // Special-case to handle references to closures hiding out in DLLs, since
2572 // double indirections required to get at those. The code generator knows
2573 // which is which when generating the SRT, so it stores the (indirect)
2574 // reference to the DLL closure in the table by first adding one to it.
2575 // We check for this here, and undo the addition before evacuating it.
2577 // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2578 // closure that's fixed at link-time, and no extra magic is required.
2579 if ( (unsigned long)(*srt) & 0x1 ) {
2580 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2589 bitmap = bitmap >> 1;
2595 scavenge_thunk_srt(const StgInfoTable *info)
2597 StgThunkInfoTable *thunk_info;
2599 if (!major_gc) return;
2601 thunk_info = itbl_to_thunk_itbl(info);
2602 scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2606 scavenge_fun_srt(const StgInfoTable *info)
2608 StgFunInfoTable *fun_info;
2610 if (!major_gc) return;
2612 fun_info = itbl_to_fun_itbl(info);
2613 scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2616 /* -----------------------------------------------------------------------------
2618 -------------------------------------------------------------------------- */
2621 scavengeTSO (StgTSO *tso)
2623 if ( tso->why_blocked == BlockedOnMVar
2624 || tso->why_blocked == BlockedOnBlackHole
2625 || tso->why_blocked == BlockedOnException
2627 || tso->why_blocked == BlockedOnGA
2628 || tso->why_blocked == BlockedOnGA_NoSend
2631 tso->block_info.closure = evacuate(tso->block_info.closure);
2633 tso->blocked_exceptions =
2634 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2636 // We don't always chase the link field: TSOs on the blackhole
2637 // queue are not automatically alive, so the link field is a
2638 // "weak" pointer in that case.
2639 if (tso->why_blocked != BlockedOnBlackHole) {
2640 tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
2643 // scavange current transaction record
2644 tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2646 // scavenge this thread's stack
2647 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2650 /* -----------------------------------------------------------------------------
2651 Blocks of function args occur on the stack (at the top) and
2653 -------------------------------------------------------------------------- */
2655 STATIC_INLINE StgPtr
2656 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2663 switch (fun_info->f.fun_type) {
2665 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2666 size = BITMAP_SIZE(fun_info->f.b.bitmap);
2669 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2670 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2674 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2675 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2678 if ((bitmap & 1) == 0) {
2679 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2682 bitmap = bitmap >> 1;
2690 STATIC_INLINE StgPtr
2691 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2695 StgFunInfoTable *fun_info;
2697 fun_info = get_fun_itbl(fun);
2698 ASSERT(fun_info->i.type != PAP);
2699 p = (StgPtr)payload;
2701 switch (fun_info->f.fun_type) {
2703 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2706 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2710 scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2714 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2717 if ((bitmap & 1) == 0) {
2718 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2721 bitmap = bitmap >> 1;
2729 STATIC_INLINE StgPtr
2730 scavenge_PAP (StgPAP *pap)
2732 pap->fun = evacuate(pap->fun);
2733 return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2736 STATIC_INLINE StgPtr
2737 scavenge_AP (StgAP *ap)
2739 ap->fun = evacuate(ap->fun);
2740 return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2743 /* -----------------------------------------------------------------------------
2744 Scavenge a given step until there are no more objects in this step
2747 evac_gen is set by the caller to be either zero (for a step in a
2748 generation < N) or G where G is the generation of the step being
2751 We sometimes temporarily change evac_gen back to zero if we're
2752 scavenging a mutable object where early promotion isn't such a good
2754 -------------------------------------------------------------------------- */
2762 nat saved_evac_gen = evac_gen;
2767 failed_to_evac = rtsFalse;
2769 /* scavenge phase - standard breadth-first scavenging of the
2773 while (bd != stp->hp_bd || p < stp->hp) {
2775 // If we're at the end of this block, move on to the next block
2776 if (bd != stp->hp_bd && p == bd->free) {
2782 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2783 info = get_itbl((StgClosure *)p);
2785 ASSERT(thunk_selector_depth == 0);
2788 switch (info->type) {
2792 StgMVar *mvar = ((StgMVar *)p);
2794 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2795 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2796 mvar->value = evacuate((StgClosure *)mvar->value);
2797 evac_gen = saved_evac_gen;
2798 failed_to_evac = rtsTrue; // mutable.
2799 p += sizeofW(StgMVar);
2804 scavenge_fun_srt(info);
2805 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2806 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2807 p += sizeofW(StgHeader) + 2;
2811 scavenge_thunk_srt(info);
2812 ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2813 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2814 p += sizeofW(StgThunk) + 2;
2818 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2819 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2820 p += sizeofW(StgHeader) + 2;
2824 scavenge_thunk_srt(info);
2825 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2826 p += sizeofW(StgThunk) + 1;
2830 scavenge_fun_srt(info);
2832 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2833 p += sizeofW(StgHeader) + 1;
2837 scavenge_thunk_srt(info);
2838 p += sizeofW(StgThunk) + 1;
2842 scavenge_fun_srt(info);
2844 p += sizeofW(StgHeader) + 1;
2848 scavenge_thunk_srt(info);
2849 p += sizeofW(StgThunk) + 2;
2853 scavenge_fun_srt(info);
2855 p += sizeofW(StgHeader) + 2;
2859 scavenge_thunk_srt(info);
2860 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2861 p += sizeofW(StgThunk) + 2;
2865 scavenge_fun_srt(info);
2867 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2868 p += sizeofW(StgHeader) + 2;
2872 scavenge_fun_srt(info);
2879 scavenge_thunk_srt(info);
2880 end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2881 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2882 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2884 p += info->layout.payload.nptrs;
2895 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2896 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2897 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2899 p += info->layout.payload.nptrs;
2904 StgBCO *bco = (StgBCO *)p;
2905 bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2906 bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2907 bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2908 bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2909 p += bco_sizeW(bco);
2914 if (stp->gen->no != 0) {
2917 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2918 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2919 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2922 // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2924 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2926 // We pretend that p has just been created.
2927 LDV_RECORD_CREATE((StgClosure *)p);
2930 case IND_OLDGEN_PERM:
2931 ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2932 p += sizeofW(StgInd);
2936 case MUT_VAR_DIRTY: {
2937 rtsBool saved_eager_promotion = eager_promotion;
2939 eager_promotion = rtsFalse;
2940 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2941 eager_promotion = saved_eager_promotion;
2943 if (failed_to_evac) {
2944 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
2946 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
2948 p += sizeofW(StgMutVar);
2953 case SE_CAF_BLACKHOLE:
2956 p += BLACKHOLE_sizeW();
2959 case THUNK_SELECTOR:
2961 StgSelector *s = (StgSelector *)p;
2962 s->selectee = evacuate(s->selectee);
2963 p += THUNK_SELECTOR_sizeW();
2967 // A chunk of stack saved in a heap object
2970 StgAP_STACK *ap = (StgAP_STACK *)p;
2972 ap->fun = evacuate(ap->fun);
2973 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2974 p = (StgPtr)ap->payload + ap->size;
2979 p = scavenge_PAP((StgPAP *)p);
2983 p = scavenge_AP((StgAP *)p);
2987 // nothing to follow
2988 p += arr_words_sizeW((StgArrWords *)p);
2991 case MUT_ARR_PTRS_CLEAN:
2992 case MUT_ARR_PTRS_DIRTY:
2993 // follow everything
2996 rtsBool saved_eager;
2998 // We don't eagerly promote objects pointed to by a mutable
2999 // array, but if we find the array only points to objects in
3000 // the same or an older generation, we mark it "clean" and
3001 // avoid traversing it during minor GCs.
3002 saved_eager = eager_promotion;
3003 eager_promotion = rtsFalse;
3004 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3005 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3006 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3008 eager_promotion = saved_eager;
3010 if (failed_to_evac) {
3011 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3013 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3016 failed_to_evac = rtsTrue; // always put it on the mutable list.
3020 case MUT_ARR_PTRS_FROZEN:
3021 case MUT_ARR_PTRS_FROZEN0:
3022 // follow everything
3026 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3027 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3028 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3031 // If we're going to put this object on the mutable list, then
3032 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3033 if (failed_to_evac) {
3034 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3036 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3043 StgTSO *tso = (StgTSO *)p;
3044 rtsBool saved_eager = eager_promotion;
3046 eager_promotion = rtsFalse;
3048 eager_promotion = saved_eager;
3050 if (failed_to_evac) {
3051 tso->flags |= TSO_DIRTY;
3053 tso->flags &= ~TSO_DIRTY;
3056 failed_to_evac = rtsTrue; // always on the mutable list
3057 p += tso_sizeW(tso);
3065 nat size, ptrs, nonptrs, vhs;
3067 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3069 StgRBH *rbh = (StgRBH *)p;
3070 (StgClosure *)rbh->blocking_queue =
3071 evacuate((StgClosure *)rbh->blocking_queue);
3072 failed_to_evac = rtsTrue; // mutable anyhow.
3073 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3074 p, info_type(p), (StgClosure *)rbh->blocking_queue);
3075 // ToDo: use size of reverted closure here!
3076 p += BLACKHOLE_sizeW();
3082 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3083 // follow the pointer to the node which is being demanded
3084 (StgClosure *)bf->node =
3085 evacuate((StgClosure *)bf->node);
3086 // follow the link to the rest of the blocking queue
3087 (StgClosure *)bf->link =
3088 evacuate((StgClosure *)bf->link);
3089 debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3090 bf, info_type((StgClosure *)bf),
3091 bf->node, info_type(bf->node)));
3092 p += sizeofW(StgBlockedFetch);
3100 p += sizeofW(StgFetchMe);
3101 break; // nothing to do in this case
3105 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3106 (StgClosure *)fmbq->blocking_queue =
3107 evacuate((StgClosure *)fmbq->blocking_queue);
3108 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3109 p, info_type((StgClosure *)p)));
3110 p += sizeofW(StgFetchMeBlockingQueue);
3115 case TVAR_WAIT_QUEUE:
3117 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3119 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3120 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3121 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3122 evac_gen = saved_evac_gen;
3123 failed_to_evac = rtsTrue; // mutable
3124 p += sizeofW(StgTVarWaitQueue);
3130 StgTVar *tvar = ((StgTVar *) p);
3132 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3133 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3134 evac_gen = saved_evac_gen;
3135 failed_to_evac = rtsTrue; // mutable
3136 p += sizeofW(StgTVar);
3142 StgTRecHeader *trec = ((StgTRecHeader *) p);
3144 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3145 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3146 evac_gen = saved_evac_gen;
3147 failed_to_evac = rtsTrue; // mutable
3148 p += sizeofW(StgTRecHeader);
3155 StgTRecChunk *tc = ((StgTRecChunk *) p);
3156 TRecEntry *e = &(tc -> entries[0]);
3158 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3159 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3160 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3161 e->expected_value = evacuate((StgClosure*)e->expected_value);
3162 e->new_value = evacuate((StgClosure*)e->new_value);
3164 evac_gen = saved_evac_gen;
3165 failed_to_evac = rtsTrue; // mutable
3166 p += sizeofW(StgTRecChunk);
3171 barf("scavenge: unimplemented/strange closure type %d @ %p",
3176 * We need to record the current object on the mutable list if
3177 * (a) It is actually mutable, or
3178 * (b) It contains pointers to a younger generation.
3179 * Case (b) arises if we didn't manage to promote everything that
3180 * the current object points to into the current generation.
3182 if (failed_to_evac) {
3183 failed_to_evac = rtsFalse;
3184 if (stp->gen_no > 0) {
3185 recordMutableGen((StgClosure *)q, stp->gen);
3194 /* -----------------------------------------------------------------------------
3195 Scavenge everything on the mark stack.
3197 This is slightly different from scavenge():
3198 - we don't walk linearly through the objects, so the scavenger
3199 doesn't need to advance the pointer on to the next object.
3200 -------------------------------------------------------------------------- */
3203 scavenge_mark_stack(void)
3209 evac_gen = oldest_gen->no;
3210 saved_evac_gen = evac_gen;
3213 while (!mark_stack_empty()) {
3214 p = pop_mark_stack();
3216 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3217 info = get_itbl((StgClosure *)p);
3220 switch (info->type) {
3224 StgMVar *mvar = ((StgMVar *)p);
3226 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3227 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3228 mvar->value = evacuate((StgClosure *)mvar->value);
3229 evac_gen = saved_evac_gen;
3230 failed_to_evac = rtsTrue; // mutable.
3235 scavenge_fun_srt(info);
3236 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3237 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3241 scavenge_thunk_srt(info);
3242 ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
3243 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3247 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3248 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3253 scavenge_fun_srt(info);
3254 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3259 scavenge_thunk_srt(info);
3260 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3265 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3270 scavenge_fun_srt(info);
3275 scavenge_thunk_srt(info);
3283 scavenge_fun_srt(info);
3290 scavenge_thunk_srt(info);
3291 end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3292 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3293 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3305 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3306 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3307 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3313 StgBCO *bco = (StgBCO *)p;
3314 bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3315 bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3316 bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3317 bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3322 // don't need to do anything here: the only possible case
3323 // is that we're in a 1-space compacting collector, with
3324 // no "old" generation.
3328 case IND_OLDGEN_PERM:
3329 ((StgInd *)p)->indirectee =
3330 evacuate(((StgInd *)p)->indirectee);
3334 case MUT_VAR_DIRTY: {
3335 rtsBool saved_eager_promotion = eager_promotion;
3337 eager_promotion = rtsFalse;
3338 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3339 eager_promotion = saved_eager_promotion;
3341 if (failed_to_evac) {
3342 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3344 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3350 case SE_CAF_BLACKHOLE:
3356 case THUNK_SELECTOR:
3358 StgSelector *s = (StgSelector *)p;
3359 s->selectee = evacuate(s->selectee);
3363 // A chunk of stack saved in a heap object
3366 StgAP_STACK *ap = (StgAP_STACK *)p;
3368 ap->fun = evacuate(ap->fun);
3369 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3374 scavenge_PAP((StgPAP *)p);
3378 scavenge_AP((StgAP *)p);
3381 case MUT_ARR_PTRS_CLEAN:
3382 case MUT_ARR_PTRS_DIRTY:
3383 // follow everything
3386 rtsBool saved_eager;
3388 // We don't eagerly promote objects pointed to by a mutable
3389 // array, but if we find the array only points to objects in
3390 // the same or an older generation, we mark it "clean" and
3391 // avoid traversing it during minor GCs.
3392 saved_eager = eager_promotion;
3393 eager_promotion = rtsFalse;
3394 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3395 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3396 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3398 eager_promotion = saved_eager;
3400 if (failed_to_evac) {
3401 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3403 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3406 failed_to_evac = rtsTrue; // mutable anyhow.
3410 case MUT_ARR_PTRS_FROZEN:
3411 case MUT_ARR_PTRS_FROZEN0:
3412 // follow everything
3416 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3417 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3418 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3421 // If we're going to put this object on the mutable list, then
3422 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3423 if (failed_to_evac) {
3424 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3426 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3433 StgTSO *tso = (StgTSO *)p;
3434 rtsBool saved_eager = eager_promotion;
3436 eager_promotion = rtsFalse;
3438 eager_promotion = saved_eager;
3440 if (failed_to_evac) {
3441 tso->flags |= TSO_DIRTY;
3443 tso->flags &= ~TSO_DIRTY;
3446 failed_to_evac = rtsTrue; // always on the mutable list
3454 nat size, ptrs, nonptrs, vhs;
3456 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3458 StgRBH *rbh = (StgRBH *)p;
3459 bh->blocking_queue =
3460 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3461 failed_to_evac = rtsTrue; // mutable anyhow.
3462 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3463 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3469 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3470 // follow the pointer to the node which is being demanded
3471 (StgClosure *)bf->node =
3472 evacuate((StgClosure *)bf->node);
3473 // follow the link to the rest of the blocking queue
3474 (StgClosure *)bf->link =
3475 evacuate((StgClosure *)bf->link);
3476 debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3477 bf, info_type((StgClosure *)bf),
3478 bf->node, info_type(bf->node)));
3486 break; // nothing to do in this case
3490 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3491 (StgClosure *)fmbq->blocking_queue =
3492 evacuate((StgClosure *)fmbq->blocking_queue);
3493 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3494 p, info_type((StgClosure *)p)));
3499 case TVAR_WAIT_QUEUE:
3501 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3503 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3504 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3505 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3506 evac_gen = saved_evac_gen;
3507 failed_to_evac = rtsTrue; // mutable
3513 StgTVar *tvar = ((StgTVar *) p);
3515 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3516 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3517 evac_gen = saved_evac_gen;
3518 failed_to_evac = rtsTrue; // mutable
3525 StgTRecChunk *tc = ((StgTRecChunk *) p);
3526 TRecEntry *e = &(tc -> entries[0]);
3528 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3529 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3530 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3531 e->expected_value = evacuate((StgClosure*)e->expected_value);
3532 e->new_value = evacuate((StgClosure*)e->new_value);
3534 evac_gen = saved_evac_gen;
3535 failed_to_evac = rtsTrue; // mutable
3541 StgTRecHeader *trec = ((StgTRecHeader *) p);
3543 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3544 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3545 evac_gen = saved_evac_gen;
3546 failed_to_evac = rtsTrue; // mutable
3551 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3555 if (failed_to_evac) {
3556 failed_to_evac = rtsFalse;
3558 recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3562 // mark the next bit to indicate "scavenged"
3563 mark(q+1, Bdescr(q));
3565 } // while (!mark_stack_empty())
3567 // start a new linear scan if the mark stack overflowed at some point
3568 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3569 debugTrace(DEBUG_gc, "scavenge_mark_stack: starting linear scan");
3570 mark_stack_overflowed = rtsFalse;
3571 oldgen_scan_bd = oldest_gen->steps[0].old_blocks;
3572 oldgen_scan = oldgen_scan_bd->start;
3575 if (oldgen_scan_bd) {
3576 // push a new thing on the mark stack
3578 // find a closure that is marked but not scavenged, and start
3580 while (oldgen_scan < oldgen_scan_bd->free
3581 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3585 if (oldgen_scan < oldgen_scan_bd->free) {
3587 // already scavenged?
3588 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3589 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3592 push_mark_stack(oldgen_scan);
3593 // ToDo: bump the linear scan by the actual size of the object
3594 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3598 oldgen_scan_bd = oldgen_scan_bd->link;
3599 if (oldgen_scan_bd != NULL) {
3600 oldgen_scan = oldgen_scan_bd->start;
3606 /* -----------------------------------------------------------------------------
3607 Scavenge one object.
3609 This is used for objects that are temporarily marked as mutable
3610 because they contain old-to-new generation pointers. Only certain
3611 objects can have this property.
3612 -------------------------------------------------------------------------- */
3615 scavenge_one(StgPtr p)
3617 const StgInfoTable *info;
3618 nat saved_evac_gen = evac_gen;
3621 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3622 info = get_itbl((StgClosure *)p);
3624 switch (info->type) {
3628 StgMVar *mvar = ((StgMVar *)p);
3630 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3631 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3632 mvar->value = evacuate((StgClosure *)mvar->value);
3633 evac_gen = saved_evac_gen;
3634 failed_to_evac = rtsTrue; // mutable.
3647 end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3648 for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3649 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3655 case FUN_1_0: // hardly worth specialising these guys
3671 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3672 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3673 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3679 case MUT_VAR_DIRTY: {
3681 rtsBool saved_eager_promotion = eager_promotion;
3683 eager_promotion = rtsFalse;
3684 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3685 eager_promotion = saved_eager_promotion;
3687 if (failed_to_evac) {
3688 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3690 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3696 case SE_CAF_BLACKHOLE:
3701 case THUNK_SELECTOR:
3703 StgSelector *s = (StgSelector *)p;
3704 s->selectee = evacuate(s->selectee);
3710 StgAP_STACK *ap = (StgAP_STACK *)p;
3712 ap->fun = evacuate(ap->fun);
3713 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3714 p = (StgPtr)ap->payload + ap->size;
3719 p = scavenge_PAP((StgPAP *)p);
3723 p = scavenge_AP((StgAP *)p);
3727 // nothing to follow
3730 case MUT_ARR_PTRS_CLEAN:
3731 case MUT_ARR_PTRS_DIRTY:
3734 rtsBool saved_eager;
3736 // We don't eagerly promote objects pointed to by a mutable
3737 // array, but if we find the array only points to objects in
3738 // the same or an older generation, we mark it "clean" and
3739 // avoid traversing it during minor GCs.
3740 saved_eager = eager_promotion;
3741 eager_promotion = rtsFalse;
3743 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3744 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3745 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3747 eager_promotion = saved_eager;
3749 if (failed_to_evac) {
3750 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3752 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3755 failed_to_evac = rtsTrue;
3759 case MUT_ARR_PTRS_FROZEN:
3760 case MUT_ARR_PTRS_FROZEN0:
3762 // follow everything
3765 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3766 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3767 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3770 // If we're going to put this object on the mutable list, then
3771 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3772 if (failed_to_evac) {
3773 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3775 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3782 StgTSO *tso = (StgTSO *)p;
3783 rtsBool saved_eager = eager_promotion;
3785 eager_promotion = rtsFalse;
3787 eager_promotion = saved_eager;
3789 if (failed_to_evac) {
3790 tso->flags |= TSO_DIRTY;
3792 tso->flags &= ~TSO_DIRTY;
3795 failed_to_evac = rtsTrue; // always on the mutable list
3803 nat size, ptrs, nonptrs, vhs;
3805 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3807 StgRBH *rbh = (StgRBH *)p;
3808 (StgClosure *)rbh->blocking_queue =
3809 evacuate((StgClosure *)rbh->blocking_queue);
3810 failed_to_evac = rtsTrue; // mutable anyhow.
3811 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3812 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3813 // ToDo: use size of reverted closure here!
3819 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3820 // follow the pointer to the node which is being demanded
3821 (StgClosure *)bf->node =
3822 evacuate((StgClosure *)bf->node);
3823 // follow the link to the rest of the blocking queue
3824 (StgClosure *)bf->link =
3825 evacuate((StgClosure *)bf->link);
3826 debugTrace(DEBUG_gc,
3827 "scavenge: %p (%s); node is now %p; exciting, isn't it",
3828 bf, info_type((StgClosure *)bf),
3829 bf->node, info_type(bf->node)));
3837 break; // nothing to do in this case
3841 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3842 (StgClosure *)fmbq->blocking_queue =
3843 evacuate((StgClosure *)fmbq->blocking_queue);
3844 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3845 p, info_type((StgClosure *)p)));
3850 case TVAR_WAIT_QUEUE:
3852 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3854 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3855 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3856 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3857 evac_gen = saved_evac_gen;
3858 failed_to_evac = rtsTrue; // mutable
3864 StgTVar *tvar = ((StgTVar *) p);
3866 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3867 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3868 evac_gen = saved_evac_gen;
3869 failed_to_evac = rtsTrue; // mutable
3875 StgTRecHeader *trec = ((StgTRecHeader *) p);
3877 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3878 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3879 evac_gen = saved_evac_gen;
3880 failed_to_evac = rtsTrue; // mutable
3887 StgTRecChunk *tc = ((StgTRecChunk *) p);
3888 TRecEntry *e = &(tc -> entries[0]);
3890 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3891 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3892 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3893 e->expected_value = evacuate((StgClosure*)e->expected_value);
3894 e->new_value = evacuate((StgClosure*)e->new_value);
3896 evac_gen = saved_evac_gen;
3897 failed_to_evac = rtsTrue; // mutable
3902 case IND_OLDGEN_PERM:
3905 /* Careful here: a THUNK can be on the mutable list because
3906 * it contains pointers to young gen objects. If such a thunk
3907 * is updated, the IND_OLDGEN will be added to the mutable
3908 * list again, and we'll scavenge it twice. evacuate()
3909 * doesn't check whether the object has already been
3910 * evacuated, so we perform that check here.
3912 StgClosure *q = ((StgInd *)p)->indirectee;
3913 if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
3916 ((StgInd *)p)->indirectee = evacuate(q);
3919 #if 0 && defined(DEBUG)
3920 if (RtsFlags.DebugFlags.gc)
3921 /* Debugging code to print out the size of the thing we just
3925 StgPtr start = gen->steps[0].scan;
3926 bdescr *start_bd = gen->steps[0].scan_bd;
3928 scavenge(&gen->steps[0]);
3929 if (start_bd != gen->steps[0].scan_bd) {
3930 size += (P_)BLOCK_ROUND_UP(start) - start;
3931 start_bd = start_bd->link;
3932 while (start_bd != gen->steps[0].scan_bd) {
3933 size += BLOCK_SIZE_W;
3934 start_bd = start_bd->link;
3936 size += gen->steps[0].scan -
3937 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3939 size = gen->steps[0].scan - start;
3941 debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3947 barf("scavenge_one: strange object %d", (int)(info->type));
3950 no_luck = failed_to_evac;
3951 failed_to_evac = rtsFalse;
3955 /* -----------------------------------------------------------------------------
3956 Scavenging mutable lists.
3958 We treat the mutable list of each generation > N (i.e. all the
3959 generations older than the one being collected) as roots. We also
3960 remove non-mutable objects from the mutable list at this point.
3961 -------------------------------------------------------------------------- */
3964 scavenge_mutable_list(generation *gen)
3969 bd = gen->saved_mut_list;
3972 for (; bd != NULL; bd = bd->link) {
3973 for (q = bd->start; q < bd->free; q++) {
3975 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3978 switch (get_itbl((StgClosure *)p)->type) {
3980 barf("MUT_VAR_CLEAN on mutable list");
3982 mutlist_MUTVARS++; break;
3983 case MUT_ARR_PTRS_CLEAN:
3984 case MUT_ARR_PTRS_DIRTY:
3985 case MUT_ARR_PTRS_FROZEN:
3986 case MUT_ARR_PTRS_FROZEN0:
3987 mutlist_MUTARRS++; break;
3989 mutlist_OTHERS++; break;
3993 // Check whether this object is "clean", that is it
3994 // definitely doesn't point into a young generation.
3995 // Clean objects don't need to be scavenged. Some clean
3996 // objects (MUT_VAR_CLEAN) are not kept on the mutable
3997 // list at all; others, such as MUT_ARR_PTRS_CLEAN and
3998 // TSO, are always on the mutable list.
4000 switch (get_itbl((StgClosure *)p)->type) {
4001 case MUT_ARR_PTRS_CLEAN:
4002 recordMutableGen((StgClosure *)p,gen);
4005 StgTSO *tso = (StgTSO *)p;
4006 if ((tso->flags & TSO_DIRTY) == 0) {
4007 // A clean TSO: we don't have to traverse its
4008 // stack. However, we *do* follow the link field:
4009 // we don't want to have to mark a TSO dirty just
4010 // because we put it on a different queue.
4011 if (tso->why_blocked != BlockedOnBlackHole) {
4012 tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
4014 recordMutableGen((StgClosure *)p,gen);
4022 if (scavenge_one(p)) {
4023 // didn't manage to promote everything, so put the
4024 // object back on the list.
4025 recordMutableGen((StgClosure *)p,gen);
4030 // free the old mut_list
4031 freeChain(gen->saved_mut_list);
4032 gen->saved_mut_list = NULL;
4037 scavenge_static(void)
4039 StgClosure* p = static_objects;
4040 const StgInfoTable *info;
4042 /* Always evacuate straight to the oldest generation for static
4044 evac_gen = oldest_gen->no;
4046 /* keep going until we've scavenged all the objects on the linked
4048 while (p != END_OF_STATIC_LIST) {
4050 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
4053 if (info->type==RBH)
4054 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
4056 // make sure the info pointer is into text space
4058 /* Take this object *off* the static_objects list,
4059 * and put it on the scavenged_static_objects list.
4061 static_objects = *STATIC_LINK(info,p);
4062 *STATIC_LINK(info,p) = scavenged_static_objects;
4063 scavenged_static_objects = p;
4065 switch (info -> type) {
4069 StgInd *ind = (StgInd *)p;
4070 ind->indirectee = evacuate(ind->indirectee);
4072 /* might fail to evacuate it, in which case we have to pop it
4073 * back on the mutable list of the oldest generation. We
4074 * leave it *on* the scavenged_static_objects list, though,
4075 * in case we visit this object again.
4077 if (failed_to_evac) {
4078 failed_to_evac = rtsFalse;
4079 recordMutableGen((StgClosure *)p,oldest_gen);
4085 scavenge_thunk_srt(info);
4089 scavenge_fun_srt(info);
4096 next = (P_)p->payload + info->layout.payload.ptrs;
4097 // evacuate the pointers
4098 for (q = (P_)p->payload; q < next; q++) {
4099 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
4105 barf("scavenge_static: strange closure %d", (int)(info->type));
4108 ASSERT(failed_to_evac == rtsFalse);
4110 /* get the next static object from the list. Remember, there might
4111 * be more stuff on this list now that we've done some evacuating!
4112 * (static_objects is a global)
4118 /* -----------------------------------------------------------------------------
4119 scavenge a chunk of memory described by a bitmap
4120 -------------------------------------------------------------------------- */
4123 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
4129 bitmap = large_bitmap->bitmap[b];
4130 for (i = 0; i < size; ) {
4131 if ((bitmap & 1) == 0) {
4132 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4136 if (i % BITS_IN(W_) == 0) {
4138 bitmap = large_bitmap->bitmap[b];
4140 bitmap = bitmap >> 1;
4145 STATIC_INLINE StgPtr
4146 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
4149 if ((bitmap & 1) == 0) {
4150 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4153 bitmap = bitmap >> 1;
4159 /* -----------------------------------------------------------------------------
4160 scavenge_stack walks over a section of stack and evacuates all the
4161 objects pointed to by it. We can use the same code for walking
4162 AP_STACK_UPDs, since these are just sections of copied stack.
4163 -------------------------------------------------------------------------- */
4167 scavenge_stack(StgPtr p, StgPtr stack_end)
4169 const StgRetInfoTable* info;
4174 * Each time around this loop, we are looking at a chunk of stack
4175 * that starts with an activation record.
4178 while (p < stack_end) {
4179 info = get_ret_itbl((StgClosure *)p);
4181 switch (info->i.type) {
4184 // In SMP, we can get update frames that point to indirections
4185 // when two threads evaluate the same thunk. We do attempt to
4186 // discover this situation in threadPaused(), but it's
4187 // possible that the following sequence occurs:
4196 // Now T is an indirection, and the update frame is already
4197 // marked on A's stack, so we won't traverse it again in
4198 // threadPaused(). We could traverse the whole stack again
4199 // before GC, but that seems like overkill.
4201 // Scavenging this update frame as normal would be disastrous;
4202 // the updatee would end up pointing to the value. So we turn
4203 // the indirection into an IND_PERM, so that evacuate will
4204 // copy the indirection into the old generation instead of
4206 if (get_itbl(((StgUpdateFrame *)p)->updatee)->type == IND) {
4207 ((StgUpdateFrame *)p)->updatee->header.info =
4208 (StgInfoTable *)&stg_IND_PERM_info;
4210 ((StgUpdateFrame *)p)->updatee
4211 = evacuate(((StgUpdateFrame *)p)->updatee);
4212 p += sizeofW(StgUpdateFrame);
4215 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
4216 case CATCH_STM_FRAME:
4217 case CATCH_RETRY_FRAME:
4218 case ATOMICALLY_FRAME:
4223 bitmap = BITMAP_BITS(info->i.layout.bitmap);
4224 size = BITMAP_SIZE(info->i.layout.bitmap);
4225 // NOTE: the payload starts immediately after the info-ptr, we
4226 // don't have an StgHeader in the same sense as a heap closure.
4228 p = scavenge_small_bitmap(p, size, bitmap);
4232 scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
4240 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4243 size = BCO_BITMAP_SIZE(bco);
4244 scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
4249 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
4255 size = GET_LARGE_BITMAP(&info->i)->size;
4257 scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
4259 // and don't forget to follow the SRT
4263 // Dynamic bitmap: the mask is stored on the stack, and
4264 // there are a number of non-pointers followed by a number
4265 // of pointers above the bitmapped area. (see StgMacros.h,
4270 dyn = ((StgRetDyn *)p)->liveness;
4272 // traverse the bitmap first
4273 bitmap = RET_DYN_LIVENESS(dyn);
4274 p = (P_)&((StgRetDyn *)p)->payload[0];
4275 size = RET_DYN_BITMAP_SIZE;
4276 p = scavenge_small_bitmap(p, size, bitmap);
4278 // skip over the non-ptr words
4279 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
4281 // follow the ptr words
4282 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
4283 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4291 StgRetFun *ret_fun = (StgRetFun *)p;
4292 StgFunInfoTable *fun_info;
4294 ret_fun->fun = evacuate(ret_fun->fun);
4295 fun_info = get_fun_itbl(ret_fun->fun);
4296 p = scavenge_arg_block(fun_info, ret_fun->payload);
4301 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
4306 /*-----------------------------------------------------------------------------
4307 scavenge the large object list.
4309 evac_gen set by caller; similar games played with evac_gen as with
4310 scavenge() - see comment at the top of scavenge(). Most large
4311 objects are (repeatedly) mutable, so most of the time evac_gen will
4313 --------------------------------------------------------------------------- */
4316 scavenge_large(step *stp)
4321 bd = stp->new_large_objects;
4323 for (; bd != NULL; bd = stp->new_large_objects) {
4325 /* take this object *off* the large objects list and put it on
4326 * the scavenged large objects list. This is so that we can
4327 * treat new_large_objects as a stack and push new objects on
4328 * the front when evacuating.
4330 stp->new_large_objects = bd->link;
4331 dbl_link_onto(bd, &stp->scavenged_large_objects);
4333 // update the block count in this step.
4334 stp->n_scavenged_large_blocks += bd->blocks;
4337 if (scavenge_one(p)) {
4338 if (stp->gen_no > 0) {
4339 recordMutableGen((StgClosure *)p, stp->gen);
4345 /* -----------------------------------------------------------------------------
4346 Initialising the static object & mutable lists
4347 -------------------------------------------------------------------------- */
4350 zero_static_object_list(StgClosure* first_static)
4354 const StgInfoTable *info;
4356 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
4358 link = *STATIC_LINK(info, p);
4359 *STATIC_LINK(info,p) = NULL;
4363 /* -----------------------------------------------------------------------------
4365 -------------------------------------------------------------------------- */
4372 for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4373 c = (StgIndStatic *)c->static_link)
4375 SET_INFO(c, c->saved_info);
4376 c->saved_info = NULL;
4377 // could, but not necessary: c->static_link = NULL;
4379 revertible_caf_list = NULL;
4383 markCAFs( evac_fn evac )
4387 for (c = (StgIndStatic *)caf_list; c != NULL;
4388 c = (StgIndStatic *)c->static_link)
4390 evac(&c->indirectee);
4392 for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4393 c = (StgIndStatic *)c->static_link)
4395 evac(&c->indirectee);
4399 /* -----------------------------------------------------------------------------
4400 Sanity code for CAF garbage collection.
4402 With DEBUG turned on, we manage a CAF list in addition to the SRT
4403 mechanism. After GC, we run down the CAF list and blackhole any
4404 CAFs which have been garbage collected. This means we get an error
4405 whenever the program tries to enter a garbage collected CAF.
4407 Any garbage collected CAFs are taken off the CAF list at the same
4409 -------------------------------------------------------------------------- */
4411 #if 0 && defined(DEBUG)
4418 const StgInfoTable *info;
4429 ASSERT(info->type == IND_STATIC);
4431 if (STATIC_LINK(info,p) == NULL) {
4432 debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p);
4434 SET_INFO(p,&stg_BLACKHOLE_info);
4435 p = STATIC_LINK2(info,p);
4439 pp = &STATIC_LINK2(info,p);
4446 debugTrace(DEBUG_gccafs, "%d CAFs live", i);
4451 /* -----------------------------------------------------------------------------
4454 * Code largely pinched from old RTS, then hacked to bits. We also do
4455 * lazy black holing here.
4457 * -------------------------------------------------------------------------- */
4459 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4462 stackSqueeze(StgTSO *tso, StgPtr bottom)
4465 rtsBool prev_was_update_frame;
4466 StgClosure *updatee = NULL;
4467 StgRetInfoTable *info;
4468 StgWord current_gap_size;
4469 struct stack_gap *gap;
4472 // Traverse the stack upwards, replacing adjacent update frames
4473 // with a single update frame and a "stack gap". A stack gap
4474 // contains two values: the size of the gap, and the distance
4475 // to the next gap (or the stack top).
4479 ASSERT(frame < bottom);
4481 prev_was_update_frame = rtsFalse;
4482 current_gap_size = 0;
4483 gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4485 while (frame < bottom) {
4487 info = get_ret_itbl((StgClosure *)frame);
4488 switch (info->i.type) {
4492 StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4494 if (prev_was_update_frame) {
4496 TICK_UPD_SQUEEZED();
4497 /* wasn't there something about update squeezing and ticky to be
4498 * sorted out? oh yes: we aren't counting each enter properly
4499 * in this case. See the log somewhere. KSW 1999-04-21
4501 * Check two things: that the two update frames don't point to
4502 * the same object, and that the updatee_bypass isn't already an
4503 * indirection. Both of these cases only happen when we're in a
4504 * block hole-style loop (and there are multiple update frames
4505 * on the stack pointing to the same closure), but they can both
4506 * screw us up if we don't check.
4508 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4509 UPD_IND_NOLOCK(upd->updatee, updatee);
4512 // now mark this update frame as a stack gap. The gap
4513 // marker resides in the bottom-most update frame of
4514 // the series of adjacent frames, and covers all the
4515 // frames in this series.
4516 current_gap_size += sizeofW(StgUpdateFrame);
4517 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4518 ((struct stack_gap *)frame)->next_gap = gap;
4520 frame += sizeofW(StgUpdateFrame);
4524 // single update frame, or the topmost update frame in a series
4526 prev_was_update_frame = rtsTrue;
4527 updatee = upd->updatee;
4528 frame += sizeofW(StgUpdateFrame);
4534 prev_was_update_frame = rtsFalse;
4536 // we're not in a gap... check whether this is the end of a gap
4537 // (an update frame can't be the end of a gap).
4538 if (current_gap_size != 0) {
4539 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4541 current_gap_size = 0;
4543 frame += stack_frame_sizeW((StgClosure *)frame);
4548 if (current_gap_size != 0) {
4549 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4552 // Now we have a stack with gaps in it, and we have to walk down
4553 // shoving the stack up to fill in the gaps. A diagram might
4557 // | ********* | <- sp
4561 // | stack_gap | <- gap | chunk_size
4563 // | ......... | <- gap_end v
4569 // 'sp' points the the current top-of-stack
4570 // 'gap' points to the stack_gap structure inside the gap
4571 // ***** indicates real stack data
4572 // ..... indicates gap
4573 // <empty> indicates unused
4577 void *gap_start, *next_gap_start, *gap_end;
4580 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4581 sp = next_gap_start;
4583 while ((StgPtr)gap > tso->sp) {
4585 // we're working in *bytes* now...
4586 gap_start = next_gap_start;
4587 gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4589 gap = gap->next_gap;
4590 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4592 chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4594 memmove(sp, next_gap_start, chunk_size);
4597 tso->sp = (StgPtr)sp;
4601 /* -----------------------------------------------------------------------------
4604 * We have to prepare for GC - this means doing lazy black holing
4605 * here. We also take the opportunity to do stack squeezing if it's
4607 * -------------------------------------------------------------------------- */
4609 threadPaused(Capability *cap, StgTSO *tso)
4612 StgRetInfoTable *info;
4615 nat words_to_squeeze = 0;
4617 nat weight_pending = 0;
4618 rtsBool prev_was_update_frame;
4620 // Check to see whether we have threads waiting to raise
4621 // exceptions, and we're not blocking exceptions, or are blocked
4622 // interruptibly. This is important; if a thread is running with
4623 // TSO_BLOCKEX and becomes blocked interruptibly, this is the only
4624 // place we ensure that the blocked_exceptions get a chance.
4625 maybePerformBlockedException (cap, tso);
4626 if (tso->what_next == ThreadKilled) { return; }
4628 stack_end = &tso->stack[tso->stack_size];
4630 frame = (StgClosure *)tso->sp;
4633 // If we've already marked this frame, then stop here.
4634 if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) {
4638 info = get_ret_itbl(frame);
4640 switch (info->i.type) {
4644 SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info);
4646 bh = ((StgUpdateFrame *)frame)->updatee;
4648 if (closure_IND(bh) || bh->header.info == &stg_BLACKHOLE_info) {
4649 debugTrace(DEBUG_squeeze,
4650 "suspending duplicate work: %ld words of stack",
4651 (long)((StgPtr)frame - tso->sp));
4653 // If this closure is already an indirection, then
4654 // suspend the computation up to this point:
4655 suspendComputation(cap,tso,(StgPtr)frame);
4657 // Now drop the update frame, and arrange to return
4658 // the value to the frame underneath:
4659 tso->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2;
4660 tso->sp[1] = (StgWord)bh;
4661 tso->sp[0] = (W_)&stg_enter_info;
4663 // And continue with threadPaused; there might be
4664 // yet more computation to suspend.
4665 threadPaused(cap,tso);
4669 if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
4670 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4671 debugBelch("Unexpected lazy BHing required at 0x%04lx\n",(long)bh);
4673 // zero out the slop so that the sanity checker can tell
4674 // where the next closure is.
4675 DEBUG_FILL_SLOP(bh);
4678 // We pretend that bh is now dead.
4679 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4681 SET_INFO(bh,&stg_BLACKHOLE_info);
4683 // We pretend that bh has just been created.
4684 LDV_RECORD_CREATE(bh);
4687 frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4688 if (prev_was_update_frame) {
4689 words_to_squeeze += sizeofW(StgUpdateFrame);
4690 weight += weight_pending;
4693 prev_was_update_frame = rtsTrue;
4699 // normal stack frames; do nothing except advance the pointer
4702 nat frame_size = stack_frame_sizeW(frame);
4703 weight_pending += frame_size;
4704 frame = (StgClosure *)((StgPtr)frame + frame_size);
4705 prev_was_update_frame = rtsFalse;
4711 debugTrace(DEBUG_squeeze,
4712 "words_to_squeeze: %d, weight: %d, squeeze: %s",
4713 words_to_squeeze, weight,
4714 weight < words_to_squeeze ? "YES" : "NO");
4716 // Should we squeeze or not? Arbitrary heuristic: we squeeze if
4717 // the number of words we have to shift down is less than the
4718 // number of stack words we squeeze away by doing so.
4719 if (RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue &&
4720 weight < words_to_squeeze) {
4721 stackSqueeze(tso, (StgPtr)frame);
4725 /* -----------------------------------------------------------------------------
4727 * -------------------------------------------------------------------------- */
4731 printMutableList(generation *gen)
4736 debugBelch("mutable list %p: ", gen->mut_list);
4738 for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
4739 for (p = bd->start; p < bd->free; p++) {
4740 debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));