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_INTLIKE:
1902 case CONSTR_CHARLIKE:
1903 case CONSTR_NOCAF_STATIC:
1904 /* no need to put these on the static linked list, they don't need
1910 barf("evacuate(static): strange closure type %d", (int)(info->type));
1916 if (bd->gen_no > N) {
1917 /* Can't evacuate this object, because it's in a generation
1918 * older than the ones we're collecting. Let's hope that it's
1919 * in evac_gen or older, or we will have to arrange to track
1920 * this pointer using the mutable list.
1922 if (bd->gen_no < evac_gen) {
1924 failed_to_evac = rtsTrue;
1925 TICK_GC_FAILED_PROMOTION();
1930 if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
1932 /* pointer into to-space: just return it. This normally
1933 * shouldn't happen, but alllowing it makes certain things
1934 * slightly easier (eg. the mutable list can contain the same
1935 * object twice, for example).
1937 if (bd->flags & BF_EVACUATED) {
1938 if (bd->gen_no < evac_gen) {
1939 failed_to_evac = rtsTrue;
1940 TICK_GC_FAILED_PROMOTION();
1945 /* evacuate large objects by re-linking them onto a different list.
1947 if (bd->flags & BF_LARGE) {
1949 if (info->type == TSO &&
1950 ((StgTSO *)q)->what_next == ThreadRelocated) {
1951 q = (StgClosure *)((StgTSO *)q)->link;
1954 evacuate_large((P_)q);
1958 /* If the object is in a step that we're compacting, then we
1959 * need to use an alternative evacuate procedure.
1961 if (bd->flags & BF_COMPACTED) {
1962 if (!is_marked((P_)q,bd)) {
1964 if (mark_stack_full()) {
1965 mark_stack_overflowed = rtsTrue;
1968 push_mark_stack((P_)q);
1978 switch (info->type) {
1983 return copy(q,sizeW_fromITBL(info),stp);
1987 StgWord w = (StgWord)q->payload[0];
1988 if (q->header.info == Czh_con_info &&
1989 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
1990 (StgChar)w <= MAX_CHARLIKE) {
1991 return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1993 if (q->header.info == Izh_con_info &&
1994 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1995 return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1998 return copy_noscav(q,sizeofW(StgHeader)+1,stp);
2004 return copy(q,sizeofW(StgHeader)+1,stp);
2008 return copy(q,sizeofW(StgThunk)+1,stp);
2013 #ifdef NO_PROMOTE_THUNKS
2014 if (bd->gen_no == 0 &&
2015 bd->step->no != 0 &&
2016 bd->step->no == generations[bd->gen_no].n_steps-1) {
2020 return copy(q,sizeofW(StgThunk)+2,stp);
2027 return copy(q,sizeofW(StgHeader)+2,stp);
2030 return copy_noscav(q,sizeofW(StgHeader)+2,stp);
2033 return copy(q,thunk_sizeW_fromITBL(info),stp);
2038 case IND_OLDGEN_PERM:
2041 return copy(q,sizeW_fromITBL(info),stp);
2044 return copy(q,bco_sizeW((StgBCO *)q),stp);
2047 case SE_CAF_BLACKHOLE:
2050 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
2052 case THUNK_SELECTOR:
2055 const StgInfoTable *info_ptr;
2057 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2058 return copy(q,THUNK_SELECTOR_sizeW(),stp);
2061 // stashed away for LDV profiling, see below
2062 info_ptr = q->header.info;
2064 p = eval_thunk_selector(info->layout.selector_offset,
2068 return copy(q,THUNK_SELECTOR_sizeW(),stp);
2071 // q is still BLACKHOLE'd.
2072 thunk_selector_depth++;
2074 thunk_selector_depth--;
2077 // For the purposes of LDV profiling, we have destroyed
2078 // the original selector thunk.
2079 SET_INFO(q, info_ptr);
2080 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(q);
2083 // Update the THUNK_SELECTOR with an indirection to the
2084 // EVACUATED closure now at p. Why do this rather than
2085 // upd_evacuee(q,p)? Because we have an invariant that an
2086 // EVACUATED closure always points to an object in the
2087 // same or an older generation (required by the short-cut
2088 // test in the EVACUATED case, below).
2089 SET_INFO(q, &stg_IND_info);
2090 ((StgInd *)q)->indirectee = p;
2092 // For the purposes of LDV profiling, we have created an
2094 LDV_RECORD_CREATE(q);
2102 // follow chains of indirections, don't evacuate them
2103 q = ((StgInd*)q)->indirectee;
2115 case CATCH_STM_FRAME:
2116 case CATCH_RETRY_FRAME:
2117 case ATOMICALLY_FRAME:
2118 // shouldn't see these
2119 barf("evacuate: stack frame at %p\n", q);
2122 return copy(q,pap_sizeW((StgPAP*)q),stp);
2125 return copy(q,ap_sizeW((StgAP*)q),stp);
2128 return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
2131 /* Already evacuated, just return the forwarding address.
2132 * HOWEVER: if the requested destination generation (evac_gen) is
2133 * older than the actual generation (because the object was
2134 * already evacuated to a younger generation) then we have to
2135 * set the failed_to_evac flag to indicate that we couldn't
2136 * manage to promote the object to the desired generation.
2139 * Optimisation: the check is fairly expensive, but we can often
2140 * shortcut it if either the required generation is 0, or the
2141 * current object (the EVACUATED) is in a high enough generation.
2142 * We know that an EVACUATED always points to an object in the
2143 * same or an older generation. stp is the lowest step that the
2144 * current object would be evacuated to, so we only do the full
2145 * check if stp is too low.
2147 if (evac_gen > 0 && stp->gen_no < evac_gen) { // optimisation
2148 StgClosure *p = ((StgEvacuated*)q)->evacuee;
2149 if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
2150 failed_to_evac = rtsTrue;
2151 TICK_GC_FAILED_PROMOTION();
2154 return ((StgEvacuated*)q)->evacuee;
2157 // just copy the block
2158 return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp);
2160 case MUT_ARR_PTRS_CLEAN:
2161 case MUT_ARR_PTRS_DIRTY:
2162 case MUT_ARR_PTRS_FROZEN:
2163 case MUT_ARR_PTRS_FROZEN0:
2164 // just copy the block
2165 return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
2169 StgTSO *tso = (StgTSO *)q;
2171 /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
2173 if (tso->what_next == ThreadRelocated) {
2174 q = (StgClosure *)tso->link;
2178 /* To evacuate a small TSO, we need to relocate the update frame
2185 new_tso = (StgTSO *)copyPart((StgClosure *)tso,
2187 sizeofW(StgTSO), stp);
2188 move_TSO(tso, new_tso);
2189 for (p = tso->sp, q = new_tso->sp;
2190 p < tso->stack+tso->stack_size;) {
2194 return (StgClosure *)new_tso;
2201 //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
2202 to = copy(q,BLACKHOLE_sizeW(),stp);
2203 //ToDo: derive size etc from reverted IP
2204 //to = copy(q,size,stp);
2205 debugTrace(DEBUG_gc, "evacuate: RBH %p (%s) to %p (%s)",
2206 q, info_type(q), to, info_type(to));
2211 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE);
2212 to = copy(q,sizeofW(StgBlockedFetch),stp);
2213 debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2214 q, info_type(q), to, info_type(to));
2221 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2222 to = copy(q,sizeofW(StgFetchMe),stp);
2223 debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2224 q, info_type(q), to, info_type(to)));
2228 ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2229 to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2230 debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2231 q, info_type(q), to, info_type(to)));
2236 return copy(q,sizeofW(StgTRecHeader),stp);
2238 case TVAR_WAIT_QUEUE:
2239 return copy(q,sizeofW(StgTVarWaitQueue),stp);
2242 return copy(q,sizeofW(StgTVar),stp);
2245 return copy(q,sizeofW(StgTRecChunk),stp);
2248 barf("evacuate: strange closure type %d", (int)(info->type));
2254 /* -----------------------------------------------------------------------------
2255 Evaluate a THUNK_SELECTOR if possible.
2257 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2258 a closure pointer if we evaluated it and this is the result. Note
2259 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2260 reducing it to HNF, just that we have eliminated the selection.
2261 The result might be another thunk, or even another THUNK_SELECTOR.
2263 If the return value is non-NULL, the original selector thunk has
2264 been BLACKHOLE'd, and should be updated with an indirection or a
2265 forwarding pointer. If the return value is NULL, then the selector
2269 ToDo: the treatment of THUNK_SELECTORS could be improved in the
2270 following way (from a suggestion by Ian Lynagh):
2272 We can have a chain like this:
2276 |-----> sel_0 --> (a,b)
2278 |-----> sel_0 --> ...
2280 and the depth limit means we don't go all the way to the end of the
2281 chain, which results in a space leak. This affects the recursive
2282 call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2283 the recursive call to eval_thunk_selector() in
2284 eval_thunk_selector().
2286 We could eliminate the depth bound in this case, in the following
2289 - traverse the chain once to discover the *value* of the
2290 THUNK_SELECTOR. Mark all THUNK_SELECTORS that we
2291 visit on the way as having been visited already (somehow).
2293 - in a second pass, traverse the chain again updating all
2294 THUNK_SEELCTORS that we find on the way with indirections to
2297 - if we encounter a "marked" THUNK_SELECTOR in a normal
2298 evacuate(), we konw it can't be updated so just evac it.
2300 Program that illustrates the problem:
2303 foo (x:xs) = let (ys, zs) = foo xs
2304 in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2306 main = bar [1..(100000000::Int)]
2307 bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2309 -------------------------------------------------------------------------- */
2311 static inline rtsBool
2312 is_to_space ( StgClosure *p )
2316 bd = Bdescr((StgPtr)p);
2317 if (HEAP_ALLOCED(p) &&
2318 ((bd->flags & BF_EVACUATED)
2319 || ((bd->flags & BF_COMPACTED) &&
2320 is_marked((P_)p,bd)))) {
2328 eval_thunk_selector( nat field, StgSelector * p )
2331 const StgInfoTable *info_ptr;
2332 StgClosure *selectee;
2334 selectee = p->selectee;
2336 // Save the real info pointer (NOTE: not the same as get_itbl()).
2337 info_ptr = p->header.info;
2339 // If the THUNK_SELECTOR is in a generation that we are not
2340 // collecting, then bail out early. We won't be able to save any
2341 // space in any case, and updating with an indirection is trickier
2343 if (Bdescr((StgPtr)p)->gen_no > N) {
2347 // BLACKHOLE the selector thunk, since it is now under evaluation.
2348 // This is important to stop us going into an infinite loop if
2349 // this selector thunk eventually refers to itself.
2350 SET_INFO(p,&stg_BLACKHOLE_info);
2354 // We don't want to end up in to-space, because this causes
2355 // problems when the GC later tries to evacuate the result of
2356 // eval_thunk_selector(). There are various ways this could
2359 // 1. following an IND_STATIC
2361 // 2. when the old generation is compacted, the mark phase updates
2362 // from-space pointers to be to-space pointers, and we can't
2363 // reliably tell which we're following (eg. from an IND_STATIC).
2365 // 3. compacting GC again: if we're looking at a constructor in
2366 // the compacted generation, it might point directly to objects
2367 // in to-space. We must bale out here, otherwise doing the selection
2368 // will result in a to-space pointer being returned.
2370 // (1) is dealt with using a BF_EVACUATED test on the
2371 // selectee. (2) and (3): we can tell if we're looking at an
2372 // object in the compacted generation that might point to
2373 // to-space objects by testing that (a) it is BF_COMPACTED, (b)
2374 // the compacted generation is being collected, and (c) the
2375 // object is marked. Only a marked object may have pointers that
2376 // point to to-space objects, because that happens when
2379 // The to-space test is now embodied in the in_to_space() inline
2380 // function, as it is re-used below.
2382 if (is_to_space(selectee)) {
2386 info = get_itbl(selectee);
2387 switch (info->type) {
2395 case CONSTR_NOCAF_STATIC:
2396 // check that the size is in range
2397 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
2398 info->layout.payload.nptrs));
2400 // Select the right field from the constructor, and check
2401 // that the result isn't in to-space. It might be in
2402 // to-space if, for example, this constructor contains
2403 // pointers to younger-gen objects (and is on the mut-once
2408 q = selectee->payload[field];
2409 if (is_to_space(q)) {
2419 case IND_OLDGEN_PERM:
2421 selectee = ((StgInd *)selectee)->indirectee;
2425 // We don't follow pointers into to-space; the constructor
2426 // has already been evacuated, so we won't save any space
2427 // leaks by evaluating this selector thunk anyhow.
2430 case THUNK_SELECTOR:
2434 // check that we don't recurse too much, re-using the
2435 // depth bound also used in evacuate().
2436 if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2439 thunk_selector_depth++;
2441 val = eval_thunk_selector(info->layout.selector_offset,
2442 (StgSelector *)selectee);
2444 thunk_selector_depth--;
2449 // We evaluated this selector thunk, so update it with
2450 // an indirection. NOTE: we don't use UPD_IND here,
2451 // because we are guaranteed that p is in a generation
2452 // that we are collecting, and we never want to put the
2453 // indirection on a mutable list.
2455 // For the purposes of LDV profiling, we have destroyed
2456 // the original selector thunk.
2457 SET_INFO(p, info_ptr);
2458 LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2460 ((StgInd *)selectee)->indirectee = val;
2461 SET_INFO(selectee,&stg_IND_info);
2463 // For the purposes of LDV profiling, we have created an
2465 LDV_RECORD_CREATE(selectee);
2482 case SE_CAF_BLACKHOLE:
2494 // not evaluated yet
2498 barf("eval_thunk_selector: strange selectee %d",
2503 // We didn't manage to evaluate this thunk; restore the old info pointer
2504 SET_INFO(p, info_ptr);
2508 /* -----------------------------------------------------------------------------
2509 move_TSO is called to update the TSO structure after it has been
2510 moved from one place to another.
2511 -------------------------------------------------------------------------- */
2514 move_TSO (StgTSO *src, StgTSO *dest)
2518 // relocate the stack pointer...
2519 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2520 dest->sp = (StgPtr)dest->sp + diff;
2523 /* Similar to scavenge_large_bitmap(), but we don't write back the
2524 * pointers we get back from evacuate().
2527 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2534 bitmap = large_srt->l.bitmap[b];
2535 size = (nat)large_srt->l.size;
2536 p = (StgClosure **)large_srt->srt;
2537 for (i = 0; i < size; ) {
2538 if ((bitmap & 1) != 0) {
2543 if (i % BITS_IN(W_) == 0) {
2545 bitmap = large_srt->l.bitmap[b];
2547 bitmap = bitmap >> 1;
2552 /* evacuate the SRT. If srt_bitmap is zero, then there isn't an
2553 * srt field in the info table. That's ok, because we'll
2554 * never dereference it.
2557 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2562 bitmap = srt_bitmap;
2565 if (bitmap == (StgHalfWord)(-1)) {
2566 scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2570 while (bitmap != 0) {
2571 if ((bitmap & 1) != 0) {
2572 #ifdef ENABLE_WIN32_DLL_SUPPORT
2573 // Special-case to handle references to closures hiding out in DLLs, since
2574 // double indirections required to get at those. The code generator knows
2575 // which is which when generating the SRT, so it stores the (indirect)
2576 // reference to the DLL closure in the table by first adding one to it.
2577 // We check for this here, and undo the addition before evacuating it.
2579 // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2580 // closure that's fixed at link-time, and no extra magic is required.
2581 if ( (unsigned long)(*srt) & 0x1 ) {
2582 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2591 bitmap = bitmap >> 1;
2597 scavenge_thunk_srt(const StgInfoTable *info)
2599 StgThunkInfoTable *thunk_info;
2601 if (!major_gc) return;
2603 thunk_info = itbl_to_thunk_itbl(info);
2604 scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2608 scavenge_fun_srt(const StgInfoTable *info)
2610 StgFunInfoTable *fun_info;
2612 if (!major_gc) return;
2614 fun_info = itbl_to_fun_itbl(info);
2615 scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2618 /* -----------------------------------------------------------------------------
2620 -------------------------------------------------------------------------- */
2623 scavengeTSO (StgTSO *tso)
2625 if ( tso->why_blocked == BlockedOnMVar
2626 || tso->why_blocked == BlockedOnBlackHole
2627 || tso->why_blocked == BlockedOnException
2629 || tso->why_blocked == BlockedOnGA
2630 || tso->why_blocked == BlockedOnGA_NoSend
2633 tso->block_info.closure = evacuate(tso->block_info.closure);
2635 tso->blocked_exceptions =
2636 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2638 // We don't always chase the link field: TSOs on the blackhole
2639 // queue are not automatically alive, so the link field is a
2640 // "weak" pointer in that case.
2641 if (tso->why_blocked != BlockedOnBlackHole) {
2642 tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
2645 // scavange current transaction record
2646 tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2648 // scavenge this thread's stack
2649 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2652 /* -----------------------------------------------------------------------------
2653 Blocks of function args occur on the stack (at the top) and
2655 -------------------------------------------------------------------------- */
2657 STATIC_INLINE StgPtr
2658 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2665 switch (fun_info->f.fun_type) {
2667 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2668 size = BITMAP_SIZE(fun_info->f.b.bitmap);
2671 size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2672 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2676 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2677 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2680 if ((bitmap & 1) == 0) {
2681 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2684 bitmap = bitmap >> 1;
2692 STATIC_INLINE StgPtr
2693 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2697 StgFunInfoTable *fun_info;
2699 fun_info = get_fun_itbl(fun);
2700 ASSERT(fun_info->i.type != PAP);
2701 p = (StgPtr)payload;
2703 switch (fun_info->f.fun_type) {
2705 bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2708 scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2712 scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2716 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2719 if ((bitmap & 1) == 0) {
2720 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2723 bitmap = bitmap >> 1;
2731 STATIC_INLINE StgPtr
2732 scavenge_PAP (StgPAP *pap)
2734 pap->fun = evacuate(pap->fun);
2735 return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2738 STATIC_INLINE StgPtr
2739 scavenge_AP (StgAP *ap)
2741 ap->fun = evacuate(ap->fun);
2742 return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2745 /* -----------------------------------------------------------------------------
2746 Scavenge a given step until there are no more objects in this step
2749 evac_gen is set by the caller to be either zero (for a step in a
2750 generation < N) or G where G is the generation of the step being
2753 We sometimes temporarily change evac_gen back to zero if we're
2754 scavenging a mutable object where early promotion isn't such a good
2756 -------------------------------------------------------------------------- */
2764 nat saved_evac_gen = evac_gen;
2769 failed_to_evac = rtsFalse;
2771 /* scavenge phase - standard breadth-first scavenging of the
2775 while (bd != stp->hp_bd || p < stp->hp) {
2777 // If we're at the end of this block, move on to the next block
2778 if (bd != stp->hp_bd && p == bd->free) {
2784 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2785 info = get_itbl((StgClosure *)p);
2787 ASSERT(thunk_selector_depth == 0);
2790 switch (info->type) {
2794 StgMVar *mvar = ((StgMVar *)p);
2796 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2797 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2798 mvar->value = evacuate((StgClosure *)mvar->value);
2799 evac_gen = saved_evac_gen;
2800 failed_to_evac = rtsTrue; // mutable.
2801 p += sizeofW(StgMVar);
2806 scavenge_fun_srt(info);
2807 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2808 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2809 p += sizeofW(StgHeader) + 2;
2813 scavenge_thunk_srt(info);
2814 ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2815 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2816 p += sizeofW(StgThunk) + 2;
2820 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2821 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2822 p += sizeofW(StgHeader) + 2;
2826 scavenge_thunk_srt(info);
2827 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2828 p += sizeofW(StgThunk) + 1;
2832 scavenge_fun_srt(info);
2834 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2835 p += sizeofW(StgHeader) + 1;
2839 scavenge_thunk_srt(info);
2840 p += sizeofW(StgThunk) + 1;
2844 scavenge_fun_srt(info);
2846 p += sizeofW(StgHeader) + 1;
2850 scavenge_thunk_srt(info);
2851 p += sizeofW(StgThunk) + 2;
2855 scavenge_fun_srt(info);
2857 p += sizeofW(StgHeader) + 2;
2861 scavenge_thunk_srt(info);
2862 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2863 p += sizeofW(StgThunk) + 2;
2867 scavenge_fun_srt(info);
2869 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2870 p += sizeofW(StgHeader) + 2;
2874 scavenge_fun_srt(info);
2881 scavenge_thunk_srt(info);
2882 end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2883 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2884 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2886 p += info->layout.payload.nptrs;
2897 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2898 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2899 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2901 p += info->layout.payload.nptrs;
2906 StgBCO *bco = (StgBCO *)p;
2907 bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2908 bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2909 bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2910 bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2911 p += bco_sizeW(bco);
2916 if (stp->gen->no != 0) {
2919 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2920 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2921 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2924 // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2926 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2928 // We pretend that p has just been created.
2929 LDV_RECORD_CREATE((StgClosure *)p);
2932 case IND_OLDGEN_PERM:
2933 ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2934 p += sizeofW(StgInd);
2938 case MUT_VAR_DIRTY: {
2939 rtsBool saved_eager_promotion = eager_promotion;
2941 eager_promotion = rtsFalse;
2942 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2943 eager_promotion = saved_eager_promotion;
2945 if (failed_to_evac) {
2946 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
2948 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
2950 p += sizeofW(StgMutVar);
2955 case SE_CAF_BLACKHOLE:
2958 p += BLACKHOLE_sizeW();
2961 case THUNK_SELECTOR:
2963 StgSelector *s = (StgSelector *)p;
2964 s->selectee = evacuate(s->selectee);
2965 p += THUNK_SELECTOR_sizeW();
2969 // A chunk of stack saved in a heap object
2972 StgAP_STACK *ap = (StgAP_STACK *)p;
2974 ap->fun = evacuate(ap->fun);
2975 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2976 p = (StgPtr)ap->payload + ap->size;
2981 p = scavenge_PAP((StgPAP *)p);
2985 p = scavenge_AP((StgAP *)p);
2989 // nothing to follow
2990 p += arr_words_sizeW((StgArrWords *)p);
2993 case MUT_ARR_PTRS_CLEAN:
2994 case MUT_ARR_PTRS_DIRTY:
2995 // follow everything
2998 rtsBool saved_eager;
3000 // We don't eagerly promote objects pointed to by a mutable
3001 // array, but if we find the array only points to objects in
3002 // the same or an older generation, we mark it "clean" and
3003 // avoid traversing it during minor GCs.
3004 saved_eager = eager_promotion;
3005 eager_promotion = rtsFalse;
3006 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3007 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3008 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3010 eager_promotion = saved_eager;
3012 if (failed_to_evac) {
3013 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3015 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3018 failed_to_evac = rtsTrue; // always put it on the mutable list.
3022 case MUT_ARR_PTRS_FROZEN:
3023 case MUT_ARR_PTRS_FROZEN0:
3024 // follow everything
3028 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3029 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3030 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3033 // If we're going to put this object on the mutable list, then
3034 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3035 if (failed_to_evac) {
3036 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3038 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3045 StgTSO *tso = (StgTSO *)p;
3046 rtsBool saved_eager = eager_promotion;
3048 eager_promotion = rtsFalse;
3050 eager_promotion = saved_eager;
3052 if (failed_to_evac) {
3053 tso->flags |= TSO_DIRTY;
3055 tso->flags &= ~TSO_DIRTY;
3058 failed_to_evac = rtsTrue; // always on the mutable list
3059 p += tso_sizeW(tso);
3067 nat size, ptrs, nonptrs, vhs;
3069 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3071 StgRBH *rbh = (StgRBH *)p;
3072 (StgClosure *)rbh->blocking_queue =
3073 evacuate((StgClosure *)rbh->blocking_queue);
3074 failed_to_evac = rtsTrue; // mutable anyhow.
3075 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3076 p, info_type(p), (StgClosure *)rbh->blocking_queue);
3077 // ToDo: use size of reverted closure here!
3078 p += BLACKHOLE_sizeW();
3084 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3085 // follow the pointer to the node which is being demanded
3086 (StgClosure *)bf->node =
3087 evacuate((StgClosure *)bf->node);
3088 // follow the link to the rest of the blocking queue
3089 (StgClosure *)bf->link =
3090 evacuate((StgClosure *)bf->link);
3091 debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3092 bf, info_type((StgClosure *)bf),
3093 bf->node, info_type(bf->node)));
3094 p += sizeofW(StgBlockedFetch);
3102 p += sizeofW(StgFetchMe);
3103 break; // nothing to do in this case
3107 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3108 (StgClosure *)fmbq->blocking_queue =
3109 evacuate((StgClosure *)fmbq->blocking_queue);
3110 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3111 p, info_type((StgClosure *)p)));
3112 p += sizeofW(StgFetchMeBlockingQueue);
3117 case TVAR_WAIT_QUEUE:
3119 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3121 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3122 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3123 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3124 evac_gen = saved_evac_gen;
3125 failed_to_evac = rtsTrue; // mutable
3126 p += sizeofW(StgTVarWaitQueue);
3132 StgTVar *tvar = ((StgTVar *) p);
3134 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3135 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3136 evac_gen = saved_evac_gen;
3137 failed_to_evac = rtsTrue; // mutable
3138 p += sizeofW(StgTVar);
3144 StgTRecHeader *trec = ((StgTRecHeader *) p);
3146 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3147 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3148 evac_gen = saved_evac_gen;
3149 failed_to_evac = rtsTrue; // mutable
3150 p += sizeofW(StgTRecHeader);
3157 StgTRecChunk *tc = ((StgTRecChunk *) p);
3158 TRecEntry *e = &(tc -> entries[0]);
3160 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3161 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3162 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3163 e->expected_value = evacuate((StgClosure*)e->expected_value);
3164 e->new_value = evacuate((StgClosure*)e->new_value);
3166 evac_gen = saved_evac_gen;
3167 failed_to_evac = rtsTrue; // mutable
3168 p += sizeofW(StgTRecChunk);
3173 barf("scavenge: unimplemented/strange closure type %d @ %p",
3178 * We need to record the current object on the mutable list if
3179 * (a) It is actually mutable, or
3180 * (b) It contains pointers to a younger generation.
3181 * Case (b) arises if we didn't manage to promote everything that
3182 * the current object points to into the current generation.
3184 if (failed_to_evac) {
3185 failed_to_evac = rtsFalse;
3186 if (stp->gen_no > 0) {
3187 recordMutableGen((StgClosure *)q, stp->gen);
3196 /* -----------------------------------------------------------------------------
3197 Scavenge everything on the mark stack.
3199 This is slightly different from scavenge():
3200 - we don't walk linearly through the objects, so the scavenger
3201 doesn't need to advance the pointer on to the next object.
3202 -------------------------------------------------------------------------- */
3205 scavenge_mark_stack(void)
3211 evac_gen = oldest_gen->no;
3212 saved_evac_gen = evac_gen;
3215 while (!mark_stack_empty()) {
3216 p = pop_mark_stack();
3218 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3219 info = get_itbl((StgClosure *)p);
3222 switch (info->type) {
3226 StgMVar *mvar = ((StgMVar *)p);
3228 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3229 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3230 mvar->value = evacuate((StgClosure *)mvar->value);
3231 evac_gen = saved_evac_gen;
3232 failed_to_evac = rtsTrue; // mutable.
3237 scavenge_fun_srt(info);
3238 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3239 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3243 scavenge_thunk_srt(info);
3244 ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
3245 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3249 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3250 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3255 scavenge_fun_srt(info);
3256 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3261 scavenge_thunk_srt(info);
3262 ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3267 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3272 scavenge_fun_srt(info);
3277 scavenge_thunk_srt(info);
3285 scavenge_fun_srt(info);
3292 scavenge_thunk_srt(info);
3293 end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3294 for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3295 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3307 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3308 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3309 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3315 StgBCO *bco = (StgBCO *)p;
3316 bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3317 bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3318 bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3319 bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3324 // don't need to do anything here: the only possible case
3325 // is that we're in a 1-space compacting collector, with
3326 // no "old" generation.
3330 case IND_OLDGEN_PERM:
3331 ((StgInd *)p)->indirectee =
3332 evacuate(((StgInd *)p)->indirectee);
3336 case MUT_VAR_DIRTY: {
3337 rtsBool saved_eager_promotion = eager_promotion;
3339 eager_promotion = rtsFalse;
3340 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3341 eager_promotion = saved_eager_promotion;
3343 if (failed_to_evac) {
3344 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3346 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3352 case SE_CAF_BLACKHOLE:
3358 case THUNK_SELECTOR:
3360 StgSelector *s = (StgSelector *)p;
3361 s->selectee = evacuate(s->selectee);
3365 // A chunk of stack saved in a heap object
3368 StgAP_STACK *ap = (StgAP_STACK *)p;
3370 ap->fun = evacuate(ap->fun);
3371 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3376 scavenge_PAP((StgPAP *)p);
3380 scavenge_AP((StgAP *)p);
3383 case MUT_ARR_PTRS_CLEAN:
3384 case MUT_ARR_PTRS_DIRTY:
3385 // follow everything
3388 rtsBool saved_eager;
3390 // We don't eagerly promote objects pointed to by a mutable
3391 // array, but if we find the array only points to objects in
3392 // the same or an older generation, we mark it "clean" and
3393 // avoid traversing it during minor GCs.
3394 saved_eager = eager_promotion;
3395 eager_promotion = rtsFalse;
3396 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3397 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3398 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3400 eager_promotion = saved_eager;
3402 if (failed_to_evac) {
3403 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3405 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3408 failed_to_evac = rtsTrue; // mutable anyhow.
3412 case MUT_ARR_PTRS_FROZEN:
3413 case MUT_ARR_PTRS_FROZEN0:
3414 // follow everything
3418 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3419 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3420 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3423 // If we're going to put this object on the mutable list, then
3424 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3425 if (failed_to_evac) {
3426 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3428 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3435 StgTSO *tso = (StgTSO *)p;
3436 rtsBool saved_eager = eager_promotion;
3438 eager_promotion = rtsFalse;
3440 eager_promotion = saved_eager;
3442 if (failed_to_evac) {
3443 tso->flags |= TSO_DIRTY;
3445 tso->flags &= ~TSO_DIRTY;
3448 failed_to_evac = rtsTrue; // always on the mutable list
3456 nat size, ptrs, nonptrs, vhs;
3458 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3460 StgRBH *rbh = (StgRBH *)p;
3461 bh->blocking_queue =
3462 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3463 failed_to_evac = rtsTrue; // mutable anyhow.
3464 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3465 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3471 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3472 // follow the pointer to the node which is being demanded
3473 (StgClosure *)bf->node =
3474 evacuate((StgClosure *)bf->node);
3475 // follow the link to the rest of the blocking queue
3476 (StgClosure *)bf->link =
3477 evacuate((StgClosure *)bf->link);
3478 debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3479 bf, info_type((StgClosure *)bf),
3480 bf->node, info_type(bf->node)));
3488 break; // nothing to do in this case
3492 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3493 (StgClosure *)fmbq->blocking_queue =
3494 evacuate((StgClosure *)fmbq->blocking_queue);
3495 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3496 p, info_type((StgClosure *)p)));
3501 case TVAR_WAIT_QUEUE:
3503 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3505 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3506 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3507 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3508 evac_gen = saved_evac_gen;
3509 failed_to_evac = rtsTrue; // mutable
3515 StgTVar *tvar = ((StgTVar *) p);
3517 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3518 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3519 evac_gen = saved_evac_gen;
3520 failed_to_evac = rtsTrue; // mutable
3527 StgTRecChunk *tc = ((StgTRecChunk *) p);
3528 TRecEntry *e = &(tc -> entries[0]);
3530 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3531 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3532 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3533 e->expected_value = evacuate((StgClosure*)e->expected_value);
3534 e->new_value = evacuate((StgClosure*)e->new_value);
3536 evac_gen = saved_evac_gen;
3537 failed_to_evac = rtsTrue; // mutable
3543 StgTRecHeader *trec = ((StgTRecHeader *) p);
3545 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3546 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3547 evac_gen = saved_evac_gen;
3548 failed_to_evac = rtsTrue; // mutable
3553 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3557 if (failed_to_evac) {
3558 failed_to_evac = rtsFalse;
3560 recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3564 // mark the next bit to indicate "scavenged"
3565 mark(q+1, Bdescr(q));
3567 } // while (!mark_stack_empty())
3569 // start a new linear scan if the mark stack overflowed at some point
3570 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3571 debugTrace(DEBUG_gc, "scavenge_mark_stack: starting linear scan");
3572 mark_stack_overflowed = rtsFalse;
3573 oldgen_scan_bd = oldest_gen->steps[0].old_blocks;
3574 oldgen_scan = oldgen_scan_bd->start;
3577 if (oldgen_scan_bd) {
3578 // push a new thing on the mark stack
3580 // find a closure that is marked but not scavenged, and start
3582 while (oldgen_scan < oldgen_scan_bd->free
3583 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3587 if (oldgen_scan < oldgen_scan_bd->free) {
3589 // already scavenged?
3590 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3591 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3594 push_mark_stack(oldgen_scan);
3595 // ToDo: bump the linear scan by the actual size of the object
3596 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3600 oldgen_scan_bd = oldgen_scan_bd->link;
3601 if (oldgen_scan_bd != NULL) {
3602 oldgen_scan = oldgen_scan_bd->start;
3608 /* -----------------------------------------------------------------------------
3609 Scavenge one object.
3611 This is used for objects that are temporarily marked as mutable
3612 because they contain old-to-new generation pointers. Only certain
3613 objects can have this property.
3614 -------------------------------------------------------------------------- */
3617 scavenge_one(StgPtr p)
3619 const StgInfoTable *info;
3620 nat saved_evac_gen = evac_gen;
3623 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3624 info = get_itbl((StgClosure *)p);
3626 switch (info->type) {
3630 StgMVar *mvar = ((StgMVar *)p);
3632 mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3633 mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3634 mvar->value = evacuate((StgClosure *)mvar->value);
3635 evac_gen = saved_evac_gen;
3636 failed_to_evac = rtsTrue; // mutable.
3649 end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3650 for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3651 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3657 case FUN_1_0: // hardly worth specialising these guys
3673 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3674 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3675 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3681 case MUT_VAR_DIRTY: {
3683 rtsBool saved_eager_promotion = eager_promotion;
3685 eager_promotion = rtsFalse;
3686 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3687 eager_promotion = saved_eager_promotion;
3689 if (failed_to_evac) {
3690 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3692 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3698 case SE_CAF_BLACKHOLE:
3703 case THUNK_SELECTOR:
3705 StgSelector *s = (StgSelector *)p;
3706 s->selectee = evacuate(s->selectee);
3712 StgAP_STACK *ap = (StgAP_STACK *)p;
3714 ap->fun = evacuate(ap->fun);
3715 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3716 p = (StgPtr)ap->payload + ap->size;
3721 p = scavenge_PAP((StgPAP *)p);
3725 p = scavenge_AP((StgAP *)p);
3729 // nothing to follow
3732 case MUT_ARR_PTRS_CLEAN:
3733 case MUT_ARR_PTRS_DIRTY:
3736 rtsBool saved_eager;
3738 // We don't eagerly promote objects pointed to by a mutable
3739 // array, but if we find the array only points to objects in
3740 // the same or an older generation, we mark it "clean" and
3741 // avoid traversing it during minor GCs.
3742 saved_eager = eager_promotion;
3743 eager_promotion = rtsFalse;
3745 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3746 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3747 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3749 eager_promotion = saved_eager;
3751 if (failed_to_evac) {
3752 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3754 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3757 failed_to_evac = rtsTrue;
3761 case MUT_ARR_PTRS_FROZEN:
3762 case MUT_ARR_PTRS_FROZEN0:
3764 // follow everything
3767 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3768 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3769 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3772 // If we're going to put this object on the mutable list, then
3773 // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3774 if (failed_to_evac) {
3775 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3777 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3784 StgTSO *tso = (StgTSO *)p;
3785 rtsBool saved_eager = eager_promotion;
3787 eager_promotion = rtsFalse;
3789 eager_promotion = saved_eager;
3791 if (failed_to_evac) {
3792 tso->flags |= TSO_DIRTY;
3794 tso->flags &= ~TSO_DIRTY;
3797 failed_to_evac = rtsTrue; // always on the mutable list
3805 nat size, ptrs, nonptrs, vhs;
3807 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3809 StgRBH *rbh = (StgRBH *)p;
3810 (StgClosure *)rbh->blocking_queue =
3811 evacuate((StgClosure *)rbh->blocking_queue);
3812 failed_to_evac = rtsTrue; // mutable anyhow.
3813 debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3814 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3815 // ToDo: use size of reverted closure here!
3821 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3822 // follow the pointer to the node which is being demanded
3823 (StgClosure *)bf->node =
3824 evacuate((StgClosure *)bf->node);
3825 // follow the link to the rest of the blocking queue
3826 (StgClosure *)bf->link =
3827 evacuate((StgClosure *)bf->link);
3828 debugTrace(DEBUG_gc,
3829 "scavenge: %p (%s); node is now %p; exciting, isn't it",
3830 bf, info_type((StgClosure *)bf),
3831 bf->node, info_type(bf->node)));
3839 break; // nothing to do in this case
3843 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3844 (StgClosure *)fmbq->blocking_queue =
3845 evacuate((StgClosure *)fmbq->blocking_queue);
3846 debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3847 p, info_type((StgClosure *)p)));
3852 case TVAR_WAIT_QUEUE:
3854 StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3856 wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3857 wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3858 wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3859 evac_gen = saved_evac_gen;
3860 failed_to_evac = rtsTrue; // mutable
3866 StgTVar *tvar = ((StgTVar *) p);
3868 tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3869 tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3870 evac_gen = saved_evac_gen;
3871 failed_to_evac = rtsTrue; // mutable
3877 StgTRecHeader *trec = ((StgTRecHeader *) p);
3879 trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3880 trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3881 evac_gen = saved_evac_gen;
3882 failed_to_evac = rtsTrue; // mutable
3889 StgTRecChunk *tc = ((StgTRecChunk *) p);
3890 TRecEntry *e = &(tc -> entries[0]);
3892 tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3893 for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3894 e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3895 e->expected_value = evacuate((StgClosure*)e->expected_value);
3896 e->new_value = evacuate((StgClosure*)e->new_value);
3898 evac_gen = saved_evac_gen;
3899 failed_to_evac = rtsTrue; // mutable
3904 case IND_OLDGEN_PERM:
3907 /* Careful here: a THUNK can be on the mutable list because
3908 * it contains pointers to young gen objects. If such a thunk
3909 * is updated, the IND_OLDGEN will be added to the mutable
3910 * list again, and we'll scavenge it twice. evacuate()
3911 * doesn't check whether the object has already been
3912 * evacuated, so we perform that check here.
3914 StgClosure *q = ((StgInd *)p)->indirectee;
3915 if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
3918 ((StgInd *)p)->indirectee = evacuate(q);
3921 #if 0 && defined(DEBUG)
3922 if (RtsFlags.DebugFlags.gc)
3923 /* Debugging code to print out the size of the thing we just
3927 StgPtr start = gen->steps[0].scan;
3928 bdescr *start_bd = gen->steps[0].scan_bd;
3930 scavenge(&gen->steps[0]);
3931 if (start_bd != gen->steps[0].scan_bd) {
3932 size += (P_)BLOCK_ROUND_UP(start) - start;
3933 start_bd = start_bd->link;
3934 while (start_bd != gen->steps[0].scan_bd) {
3935 size += BLOCK_SIZE_W;
3936 start_bd = start_bd->link;
3938 size += gen->steps[0].scan -
3939 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3941 size = gen->steps[0].scan - start;
3943 debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3949 barf("scavenge_one: strange object %d", (int)(info->type));
3952 no_luck = failed_to_evac;
3953 failed_to_evac = rtsFalse;
3957 /* -----------------------------------------------------------------------------
3958 Scavenging mutable lists.
3960 We treat the mutable list of each generation > N (i.e. all the
3961 generations older than the one being collected) as roots. We also
3962 remove non-mutable objects from the mutable list at this point.
3963 -------------------------------------------------------------------------- */
3966 scavenge_mutable_list(generation *gen)
3971 bd = gen->saved_mut_list;
3974 for (; bd != NULL; bd = bd->link) {
3975 for (q = bd->start; q < bd->free; q++) {
3977 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3980 switch (get_itbl((StgClosure *)p)->type) {
3982 barf("MUT_VAR_CLEAN on mutable list");
3984 mutlist_MUTVARS++; break;
3985 case MUT_ARR_PTRS_CLEAN:
3986 case MUT_ARR_PTRS_DIRTY:
3987 case MUT_ARR_PTRS_FROZEN:
3988 case MUT_ARR_PTRS_FROZEN0:
3989 mutlist_MUTARRS++; break;
3991 mutlist_OTHERS++; break;
3995 // Check whether this object is "clean", that is it
3996 // definitely doesn't point into a young generation.
3997 // Clean objects don't need to be scavenged. Some clean
3998 // objects (MUT_VAR_CLEAN) are not kept on the mutable
3999 // list at all; others, such as MUT_ARR_PTRS_CLEAN and
4000 // TSO, are always on the mutable list.
4002 switch (get_itbl((StgClosure *)p)->type) {
4003 case MUT_ARR_PTRS_CLEAN:
4004 recordMutableGen((StgClosure *)p,gen);
4007 StgTSO *tso = (StgTSO *)p;
4008 if ((tso->flags & TSO_DIRTY) == 0) {
4009 // A clean TSO: we don't have to traverse its
4010 // stack. However, we *do* follow the link field:
4011 // we don't want to have to mark a TSO dirty just
4012 // because we put it on a different queue.
4013 if (tso->why_blocked != BlockedOnBlackHole) {
4014 tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
4016 recordMutableGen((StgClosure *)p,gen);
4024 if (scavenge_one(p)) {
4025 // didn't manage to promote everything, so put the
4026 // object back on the list.
4027 recordMutableGen((StgClosure *)p,gen);
4032 // free the old mut_list
4033 freeChain(gen->saved_mut_list);
4034 gen->saved_mut_list = NULL;
4039 scavenge_static(void)
4041 StgClosure* p = static_objects;
4042 const StgInfoTable *info;
4044 /* Always evacuate straight to the oldest generation for static
4046 evac_gen = oldest_gen->no;
4048 /* keep going until we've scavenged all the objects on the linked
4050 while (p != END_OF_STATIC_LIST) {
4052 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
4055 if (info->type==RBH)
4056 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
4058 // make sure the info pointer is into text space
4060 /* Take this object *off* the static_objects list,
4061 * and put it on the scavenged_static_objects list.
4063 static_objects = *STATIC_LINK(info,p);
4064 *STATIC_LINK(info,p) = scavenged_static_objects;
4065 scavenged_static_objects = p;
4067 switch (info -> type) {
4071 StgInd *ind = (StgInd *)p;
4072 ind->indirectee = evacuate(ind->indirectee);
4074 /* might fail to evacuate it, in which case we have to pop it
4075 * back on the mutable list of the oldest generation. We
4076 * leave it *on* the scavenged_static_objects list, though,
4077 * in case we visit this object again.
4079 if (failed_to_evac) {
4080 failed_to_evac = rtsFalse;
4081 recordMutableGen((StgClosure *)p,oldest_gen);
4087 scavenge_thunk_srt(info);
4091 scavenge_fun_srt(info);
4098 next = (P_)p->payload + info->layout.payload.ptrs;
4099 // evacuate the pointers
4100 for (q = (P_)p->payload; q < next; q++) {
4101 *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
4107 barf("scavenge_static: strange closure %d", (int)(info->type));
4110 ASSERT(failed_to_evac == rtsFalse);
4112 /* get the next static object from the list. Remember, there might
4113 * be more stuff on this list now that we've done some evacuating!
4114 * (static_objects is a global)
4120 /* -----------------------------------------------------------------------------
4121 scavenge a chunk of memory described by a bitmap
4122 -------------------------------------------------------------------------- */
4125 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
4131 bitmap = large_bitmap->bitmap[b];
4132 for (i = 0; i < size; ) {
4133 if ((bitmap & 1) == 0) {
4134 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4138 if (i % BITS_IN(W_) == 0) {
4140 bitmap = large_bitmap->bitmap[b];
4142 bitmap = bitmap >> 1;
4147 STATIC_INLINE StgPtr
4148 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
4151 if ((bitmap & 1) == 0) {
4152 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4155 bitmap = bitmap >> 1;
4161 /* -----------------------------------------------------------------------------
4162 scavenge_stack walks over a section of stack and evacuates all the
4163 objects pointed to by it. We can use the same code for walking
4164 AP_STACK_UPDs, since these are just sections of copied stack.
4165 -------------------------------------------------------------------------- */
4169 scavenge_stack(StgPtr p, StgPtr stack_end)
4171 const StgRetInfoTable* info;
4176 * Each time around this loop, we are looking at a chunk of stack
4177 * that starts with an activation record.
4180 while (p < stack_end) {
4181 info = get_ret_itbl((StgClosure *)p);
4183 switch (info->i.type) {
4186 // In SMP, we can get update frames that point to indirections
4187 // when two threads evaluate the same thunk. We do attempt to
4188 // discover this situation in threadPaused(), but it's
4189 // possible that the following sequence occurs:
4198 // Now T is an indirection, and the update frame is already
4199 // marked on A's stack, so we won't traverse it again in
4200 // threadPaused(). We could traverse the whole stack again
4201 // before GC, but that seems like overkill.
4203 // Scavenging this update frame as normal would be disastrous;
4204 // the updatee would end up pointing to the value. So we turn
4205 // the indirection into an IND_PERM, so that evacuate will
4206 // copy the indirection into the old generation instead of
4208 if (get_itbl(((StgUpdateFrame *)p)->updatee)->type == IND) {
4209 ((StgUpdateFrame *)p)->updatee->header.info =
4210 (StgInfoTable *)&stg_IND_PERM_info;
4212 ((StgUpdateFrame *)p)->updatee
4213 = evacuate(((StgUpdateFrame *)p)->updatee);
4214 p += sizeofW(StgUpdateFrame);
4217 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
4218 case CATCH_STM_FRAME:
4219 case CATCH_RETRY_FRAME:
4220 case ATOMICALLY_FRAME:
4225 bitmap = BITMAP_BITS(info->i.layout.bitmap);
4226 size = BITMAP_SIZE(info->i.layout.bitmap);
4227 // NOTE: the payload starts immediately after the info-ptr, we
4228 // don't have an StgHeader in the same sense as a heap closure.
4230 p = scavenge_small_bitmap(p, size, bitmap);
4234 scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
4242 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4245 size = BCO_BITMAP_SIZE(bco);
4246 scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
4251 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
4257 size = GET_LARGE_BITMAP(&info->i)->size;
4259 scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
4261 // and don't forget to follow the SRT
4265 // Dynamic bitmap: the mask is stored on the stack, and
4266 // there are a number of non-pointers followed by a number
4267 // of pointers above the bitmapped area. (see StgMacros.h,
4272 dyn = ((StgRetDyn *)p)->liveness;
4274 // traverse the bitmap first
4275 bitmap = RET_DYN_LIVENESS(dyn);
4276 p = (P_)&((StgRetDyn *)p)->payload[0];
4277 size = RET_DYN_BITMAP_SIZE;
4278 p = scavenge_small_bitmap(p, size, bitmap);
4280 // skip over the non-ptr words
4281 p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
4283 // follow the ptr words
4284 for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
4285 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4293 StgRetFun *ret_fun = (StgRetFun *)p;
4294 StgFunInfoTable *fun_info;
4296 ret_fun->fun = evacuate(ret_fun->fun);
4297 fun_info = get_fun_itbl(ret_fun->fun);
4298 p = scavenge_arg_block(fun_info, ret_fun->payload);
4303 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
4308 /*-----------------------------------------------------------------------------
4309 scavenge the large object list.
4311 evac_gen set by caller; similar games played with evac_gen as with
4312 scavenge() - see comment at the top of scavenge(). Most large
4313 objects are (repeatedly) mutable, so most of the time evac_gen will
4315 --------------------------------------------------------------------------- */
4318 scavenge_large(step *stp)
4323 bd = stp->new_large_objects;
4325 for (; bd != NULL; bd = stp->new_large_objects) {
4327 /* take this object *off* the large objects list and put it on
4328 * the scavenged large objects list. This is so that we can
4329 * treat new_large_objects as a stack and push new objects on
4330 * the front when evacuating.
4332 stp->new_large_objects = bd->link;
4333 dbl_link_onto(bd, &stp->scavenged_large_objects);
4335 // update the block count in this step.
4336 stp->n_scavenged_large_blocks += bd->blocks;
4339 if (scavenge_one(p)) {
4340 if (stp->gen_no > 0) {
4341 recordMutableGen((StgClosure *)p, stp->gen);
4347 /* -----------------------------------------------------------------------------
4348 Initialising the static object & mutable lists
4349 -------------------------------------------------------------------------- */
4352 zero_static_object_list(StgClosure* first_static)
4356 const StgInfoTable *info;
4358 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
4360 link = *STATIC_LINK(info, p);
4361 *STATIC_LINK(info,p) = NULL;
4365 /* -----------------------------------------------------------------------------
4367 -------------------------------------------------------------------------- */
4374 for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4375 c = (StgIndStatic *)c->static_link)
4377 SET_INFO(c, c->saved_info);
4378 c->saved_info = NULL;
4379 // could, but not necessary: c->static_link = NULL;
4381 revertible_caf_list = NULL;
4385 markCAFs( evac_fn evac )
4389 for (c = (StgIndStatic *)caf_list; c != NULL;
4390 c = (StgIndStatic *)c->static_link)
4392 evac(&c->indirectee);
4394 for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4395 c = (StgIndStatic *)c->static_link)
4397 evac(&c->indirectee);
4401 /* -----------------------------------------------------------------------------
4402 Sanity code for CAF garbage collection.
4404 With DEBUG turned on, we manage a CAF list in addition to the SRT
4405 mechanism. After GC, we run down the CAF list and blackhole any
4406 CAFs which have been garbage collected. This means we get an error
4407 whenever the program tries to enter a garbage collected CAF.
4409 Any garbage collected CAFs are taken off the CAF list at the same
4411 -------------------------------------------------------------------------- */
4413 #if 0 && defined(DEBUG)
4420 const StgInfoTable *info;
4431 ASSERT(info->type == IND_STATIC);
4433 if (STATIC_LINK(info,p) == NULL) {
4434 debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p);
4436 SET_INFO(p,&stg_BLACKHOLE_info);
4437 p = STATIC_LINK2(info,p);
4441 pp = &STATIC_LINK2(info,p);
4448 debugTrace(DEBUG_gccafs, "%d CAFs live", i);
4453 /* -----------------------------------------------------------------------------
4456 * Code largely pinched from old RTS, then hacked to bits. We also do
4457 * lazy black holing here.
4459 * -------------------------------------------------------------------------- */
4461 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4464 stackSqueeze(StgTSO *tso, StgPtr bottom)
4467 rtsBool prev_was_update_frame;
4468 StgClosure *updatee = NULL;
4469 StgRetInfoTable *info;
4470 StgWord current_gap_size;
4471 struct stack_gap *gap;
4474 // Traverse the stack upwards, replacing adjacent update frames
4475 // with a single update frame and a "stack gap". A stack gap
4476 // contains two values: the size of the gap, and the distance
4477 // to the next gap (or the stack top).
4481 ASSERT(frame < bottom);
4483 prev_was_update_frame = rtsFalse;
4484 current_gap_size = 0;
4485 gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4487 while (frame < bottom) {
4489 info = get_ret_itbl((StgClosure *)frame);
4490 switch (info->i.type) {
4494 StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4496 if (prev_was_update_frame) {
4498 TICK_UPD_SQUEEZED();
4499 /* wasn't there something about update squeezing and ticky to be
4500 * sorted out? oh yes: we aren't counting each enter properly
4501 * in this case. See the log somewhere. KSW 1999-04-21
4503 * Check two things: that the two update frames don't point to
4504 * the same object, and that the updatee_bypass isn't already an
4505 * indirection. Both of these cases only happen when we're in a
4506 * block hole-style loop (and there are multiple update frames
4507 * on the stack pointing to the same closure), but they can both
4508 * screw us up if we don't check.
4510 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4511 UPD_IND_NOLOCK(upd->updatee, updatee);
4514 // now mark this update frame as a stack gap. The gap
4515 // marker resides in the bottom-most update frame of
4516 // the series of adjacent frames, and covers all the
4517 // frames in this series.
4518 current_gap_size += sizeofW(StgUpdateFrame);
4519 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4520 ((struct stack_gap *)frame)->next_gap = gap;
4522 frame += sizeofW(StgUpdateFrame);
4526 // single update frame, or the topmost update frame in a series
4528 prev_was_update_frame = rtsTrue;
4529 updatee = upd->updatee;
4530 frame += sizeofW(StgUpdateFrame);
4536 prev_was_update_frame = rtsFalse;
4538 // we're not in a gap... check whether this is the end of a gap
4539 // (an update frame can't be the end of a gap).
4540 if (current_gap_size != 0) {
4541 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4543 current_gap_size = 0;
4545 frame += stack_frame_sizeW((StgClosure *)frame);
4550 if (current_gap_size != 0) {
4551 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4554 // Now we have a stack with gaps in it, and we have to walk down
4555 // shoving the stack up to fill in the gaps. A diagram might
4559 // | ********* | <- sp
4563 // | stack_gap | <- gap | chunk_size
4565 // | ......... | <- gap_end v
4571 // 'sp' points the the current top-of-stack
4572 // 'gap' points to the stack_gap structure inside the gap
4573 // ***** indicates real stack data
4574 // ..... indicates gap
4575 // <empty> indicates unused
4579 void *gap_start, *next_gap_start, *gap_end;
4582 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4583 sp = next_gap_start;
4585 while ((StgPtr)gap > tso->sp) {
4587 // we're working in *bytes* now...
4588 gap_start = next_gap_start;
4589 gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4591 gap = gap->next_gap;
4592 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4594 chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4596 memmove(sp, next_gap_start, chunk_size);
4599 tso->sp = (StgPtr)sp;
4603 /* -----------------------------------------------------------------------------
4606 * We have to prepare for GC - this means doing lazy black holing
4607 * here. We also take the opportunity to do stack squeezing if it's
4609 * -------------------------------------------------------------------------- */
4611 threadPaused(Capability *cap, StgTSO *tso)
4614 StgRetInfoTable *info;
4617 nat words_to_squeeze = 0;
4619 nat weight_pending = 0;
4620 rtsBool prev_was_update_frame;
4622 // Check to see whether we have threads waiting to raise
4623 // exceptions, and we're not blocking exceptions, or are blocked
4624 // interruptibly. This is important; if a thread is running with
4625 // TSO_BLOCKEX and becomes blocked interruptibly, this is the only
4626 // place we ensure that the blocked_exceptions get a chance.
4627 maybePerformBlockedException (cap, tso);
4628 if (tso->what_next == ThreadKilled) { return; }
4630 stack_end = &tso->stack[tso->stack_size];
4632 frame = (StgClosure *)tso->sp;
4635 // If we've already marked this frame, then stop here.
4636 if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) {
4640 info = get_ret_itbl(frame);
4642 switch (info->i.type) {
4646 SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info);
4648 bh = ((StgUpdateFrame *)frame)->updatee;
4650 if (closure_IND(bh) || bh->header.info == &stg_BLACKHOLE_info) {
4651 debugTrace(DEBUG_squeeze,
4652 "suspending duplicate work: %ld words of stack",
4653 (long)((StgPtr)frame - tso->sp));
4655 // If this closure is already an indirection, then
4656 // suspend the computation up to this point:
4657 suspendComputation(cap,tso,(StgPtr)frame);
4659 // Now drop the update frame, and arrange to return
4660 // the value to the frame underneath:
4661 tso->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2;
4662 tso->sp[1] = (StgWord)bh;
4663 tso->sp[0] = (W_)&stg_enter_info;
4665 // And continue with threadPaused; there might be
4666 // yet more computation to suspend.
4667 threadPaused(cap,tso);
4671 if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
4672 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4673 debugBelch("Unexpected lazy BHing required at 0x%04lx\n",(long)bh);
4675 // zero out the slop so that the sanity checker can tell
4676 // where the next closure is.
4677 DEBUG_FILL_SLOP(bh);
4680 // We pretend that bh is now dead.
4681 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4683 SET_INFO(bh,&stg_BLACKHOLE_info);
4685 // We pretend that bh has just been created.
4686 LDV_RECORD_CREATE(bh);
4689 frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4690 if (prev_was_update_frame) {
4691 words_to_squeeze += sizeofW(StgUpdateFrame);
4692 weight += weight_pending;
4695 prev_was_update_frame = rtsTrue;
4701 // normal stack frames; do nothing except advance the pointer
4704 nat frame_size = stack_frame_sizeW(frame);
4705 weight_pending += frame_size;
4706 frame = (StgClosure *)((StgPtr)frame + frame_size);
4707 prev_was_update_frame = rtsFalse;
4713 debugTrace(DEBUG_squeeze,
4714 "words_to_squeeze: %d, weight: %d, squeeze: %s",
4715 words_to_squeeze, weight,
4716 weight < words_to_squeeze ? "YES" : "NO");
4718 // Should we squeeze or not? Arbitrary heuristic: we squeeze if
4719 // the number of words we have to shift down is less than the
4720 // number of stack words we squeeze away by doing so.
4721 if (RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue &&
4722 weight < words_to_squeeze) {
4723 stackSqueeze(tso, (StgPtr)frame);
4727 /* -----------------------------------------------------------------------------
4729 * -------------------------------------------------------------------------- */
4733 printMutableList(generation *gen)
4738 debugBelch("mutable list %p: ", gen->mut_list);
4740 for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
4741 for (p = bd->start; p < bd->free; p++) {
4742 debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));