1 /* -----------------------------------------------------------------------------
2 * $Id: GC.c,v 1.167 2004/05/21 13:28:59 simonmar Exp $
4 * (c) The GHC Team 1998-2003
6 * Generational garbage collector
8 * ---------------------------------------------------------------------------*/
10 #include "PosixSource.h"
16 #include "StoragePriv.h"
19 #include "SchedAPI.h" // for ReverCAFs prototype
21 #include "BlockAlloc.h"
26 #include "StablePriv.h"
28 #include "ParTicky.h" // ToDo: move into Rts.h
29 #include "GCCompact.h"
31 #if defined(GRAN) || defined(PAR)
32 # include "GranSimRts.h"
33 # include "ParallelRts.h"
37 # include "ParallelDebug.h"
42 #if defined(RTS_GTK_FRONTPANEL)
43 #include "FrontPanel.h"
46 #include "RetainerProfile.h"
47 #include "LdvProfile.h"
51 /* STATIC OBJECT LIST.
54 * We maintain a linked list of static objects that are still live.
55 * The requirements for this list are:
57 * - we need to scan the list while adding to it, in order to
58 * scavenge all the static objects (in the same way that
59 * breadth-first scavenging works for dynamic objects).
61 * - we need to be able to tell whether an object is already on
62 * the list, to break loops.
64 * Each static object has a "static link field", which we use for
65 * linking objects on to the list. We use a stack-type list, consing
66 * objects on the front as they are added (this means that the
67 * scavenge phase is depth-first, not breadth-first, but that
70 * A separate list is kept for objects that have been scavenged
71 * already - this is so that we can zero all the marks afterwards.
73 * An object is on the list if its static link field is non-zero; this
74 * means that we have to mark the end of the list with '1', not NULL.
76 * Extra notes for generational GC:
78 * Each generation has a static object list associated with it. When
79 * collecting generations up to N, we treat the static object lists
80 * from generations > N as roots.
82 * We build up a static object list while collecting generations 0..N,
83 * which is then appended to the static object list of generation N+1.
85 static StgClosure* static_objects; // live static objects
86 StgClosure* scavenged_static_objects; // static objects scavenged so far
88 /* N is the oldest generation being collected, where the generations
89 * are numbered starting at 0. A major GC (indicated by the major_gc
90 * flag) is when we're collecting all generations. We only attempt to
91 * deal with static objects and GC CAFs when doing a major GC.
94 static rtsBool major_gc;
96 /* Youngest generation that objects should be evacuated to in
97 * evacuate(). (Logically an argument to evacuate, but it's static
98 * a lot of the time so we optimise it into a global variable).
104 StgWeak *old_weak_ptr_list; // also pending finaliser list
106 /* Which stage of processing various kinds of weak pointer are we at?
107 * (see traverse_weak_ptr_list() below for discussion).
109 typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage;
110 static WeakStage weak_stage;
112 /* List of all threads during GC
114 static StgTSO *old_all_threads;
115 StgTSO *resurrected_threads;
117 /* Flag indicating failure to evacuate an object to the desired
120 static rtsBool failed_to_evac;
122 /* Old to-space (used for two-space collector only)
124 static bdescr *old_to_blocks;
126 /* Data used for allocation area sizing.
128 static lnat new_blocks; // blocks allocated during this GC
129 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC
131 /* Used to avoid long recursion due to selector thunks
133 static lnat thunk_selector_depth = 0;
134 #define MAX_THUNK_SELECTOR_DEPTH 8
136 /* -----------------------------------------------------------------------------
137 Static function declarations
138 -------------------------------------------------------------------------- */
140 static bdescr * gc_alloc_block ( step *stp );
141 static void mark_root ( StgClosure **root );
143 // Use a register argument for evacuate, if available.
145 #define REGPARM1 __attribute__((regparm(1)))
150 REGPARM1 static StgClosure * evacuate (StgClosure *q);
152 static void zero_static_object_list ( StgClosure* first_static );
153 static void zero_mutable_list ( StgMutClosure *first );
155 static rtsBool traverse_weak_ptr_list ( void );
156 static void mark_weak_ptr_list ( StgWeak **list );
158 static StgClosure * eval_thunk_selector ( nat field, StgSelector * p );
161 static void scavenge ( step * );
162 static void scavenge_mark_stack ( void );
163 static void scavenge_stack ( StgPtr p, StgPtr stack_end );
164 static rtsBool scavenge_one ( StgPtr p );
165 static void scavenge_large ( step * );
166 static void scavenge_static ( void );
167 static void scavenge_mutable_list ( generation *g );
168 static void scavenge_mut_once_list ( generation *g );
170 static void scavenge_large_bitmap ( StgPtr p,
171 StgLargeBitmap *large_bitmap,
174 #if 0 && defined(DEBUG)
175 static void gcCAFs ( void );
178 /* -----------------------------------------------------------------------------
179 inline functions etc. for dealing with the mark bitmap & stack.
180 -------------------------------------------------------------------------- */
182 #define MARK_STACK_BLOCKS 4
184 static bdescr *mark_stack_bdescr;
185 static StgPtr *mark_stack;
186 static StgPtr *mark_sp;
187 static StgPtr *mark_splim;
189 // Flag and pointers used for falling back to a linear scan when the
190 // mark stack overflows.
191 static rtsBool mark_stack_overflowed;
192 static bdescr *oldgen_scan_bd;
193 static StgPtr oldgen_scan;
195 STATIC_INLINE rtsBool
196 mark_stack_empty(void)
198 return mark_sp == mark_stack;
201 STATIC_INLINE rtsBool
202 mark_stack_full(void)
204 return mark_sp >= mark_splim;
208 reset_mark_stack(void)
210 mark_sp = mark_stack;
214 push_mark_stack(StgPtr p)
225 /* -----------------------------------------------------------------------------
226 Allocate a new to-space block in the given step.
227 -------------------------------------------------------------------------- */
230 gc_alloc_block(step *stp)
232 bdescr *bd = allocBlock();
233 bd->gen_no = stp->gen_no;
237 // blocks in to-space in generations up to and including N
238 // get the BF_EVACUATED flag.
239 if (stp->gen_no <= N) {
240 bd->flags = BF_EVACUATED;
245 // Start a new to-space block, chain it on after the previous one.
246 if (stp->hp_bd == NULL) {
249 stp->hp_bd->free = stp->hp;
250 stp->hp_bd->link = bd;
255 stp->hpLim = stp->hp + BLOCK_SIZE_W;
263 /* -----------------------------------------------------------------------------
266 Rough outline of the algorithm: for garbage collecting generation N
267 (and all younger generations):
269 - follow all pointers in the root set. the root set includes all
270 mutable objects in all generations (mutable_list and mut_once_list).
272 - for each pointer, evacuate the object it points to into either
274 + to-space of the step given by step->to, which is the next
275 highest step in this generation or the first step in the next
276 generation if this is the last step.
278 + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
279 When we evacuate an object we attempt to evacuate
280 everything it points to into the same generation - this is
281 achieved by setting evac_gen to the desired generation. If
282 we can't do this, then an entry in the mut_once list has to
283 be made for the cross-generation pointer.
285 + if the object is already in a generation > N, then leave
288 - repeatedly scavenge to-space from each step in each generation
289 being collected until no more objects can be evacuated.
291 - free from-space in each step, and set from-space = to-space.
293 Locks held: sched_mutex
295 -------------------------------------------------------------------------- */
298 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
302 lnat live, allocated, collected = 0, copied = 0;
303 lnat oldgen_saved_blocks = 0;
307 CostCentreStack *prev_CCS;
310 #if defined(DEBUG) && defined(GRAN)
311 IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n",
315 #if defined(RTS_USER_SIGNALS)
320 // tell the stats department that we've started a GC
323 // Init stats and print par specific (timing) info
324 PAR_TICKY_PAR_START();
326 // attribute any costs to CCS_GC
332 /* Approximate how much we allocated.
333 * Todo: only when generating stats?
335 allocated = calcAllocated();
337 /* Figure out which generation to collect
339 if (force_major_gc) {
340 N = RtsFlags.GcFlags.generations - 1;
344 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
345 if (generations[g].steps[0].n_blocks +
346 generations[g].steps[0].n_large_blocks
347 >= generations[g].max_blocks) {
351 major_gc = (N == RtsFlags.GcFlags.generations-1);
354 #ifdef RTS_GTK_FRONTPANEL
355 if (RtsFlags.GcFlags.frontpanel) {
356 updateFrontPanelBeforeGC(N);
360 // check stack sanity *before* GC (ToDo: check all threads)
362 // ToDo!: check sanity IF_DEBUG(sanity, checkTSOsSanity());
364 IF_DEBUG(sanity, checkFreeListSanity());
366 /* Initialise the static object lists
368 static_objects = END_OF_STATIC_LIST;
369 scavenged_static_objects = END_OF_STATIC_LIST;
371 /* zero the mutable list for the oldest generation (see comment by
372 * zero_mutable_list below).
375 zero_mutable_list(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
378 /* Save the old to-space if we're doing a two-space collection
380 if (RtsFlags.GcFlags.generations == 1) {
381 old_to_blocks = g0s0->to_blocks;
382 g0s0->to_blocks = NULL;
383 g0s0->n_to_blocks = 0;
386 /* Keep a count of how many new blocks we allocated during this GC
387 * (used for resizing the allocation area, later).
391 // Initialise to-space in all the generations/steps that we're
394 for (g = 0; g <= N; g++) {
395 generations[g].mut_once_list = END_MUT_LIST;
396 generations[g].mut_list = END_MUT_LIST;
398 for (s = 0; s < generations[g].n_steps; s++) {
400 // generation 0, step 0 doesn't need to-space
401 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
405 stp = &generations[g].steps[s];
406 ASSERT(stp->gen_no == g);
408 // start a new to-space for this step.
411 stp->to_blocks = NULL;
413 // allocate the first to-space block; extra blocks will be
414 // chained on as necessary.
415 bd = gc_alloc_block(stp);
417 stp->scan = bd->start;
420 // initialise the large object queues.
421 stp->new_large_objects = NULL;
422 stp->scavenged_large_objects = NULL;
423 stp->n_scavenged_large_blocks = 0;
425 // mark the large objects as not evacuated yet
426 for (bd = stp->large_objects; bd; bd = bd->link) {
427 bd->flags &= ~BF_EVACUATED;
430 // for a compacted step, we need to allocate the bitmap
431 if (stp->is_compacted) {
432 nat bitmap_size; // in bytes
433 bdescr *bitmap_bdescr;
436 bitmap_size = stp->n_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
438 if (bitmap_size > 0) {
439 bitmap_bdescr = allocGroup((nat)BLOCK_ROUND_UP(bitmap_size)
441 stp->bitmap = bitmap_bdescr;
442 bitmap = bitmap_bdescr->start;
444 IF_DEBUG(gc, belch("bitmap_size: %d, bitmap: %p",
445 bitmap_size, bitmap););
447 // don't forget to fill it with zeros!
448 memset(bitmap, 0, bitmap_size);
450 // For each block in this step, point to its bitmap from the
452 for (bd=stp->blocks; bd != NULL; bd = bd->link) {
453 bd->u.bitmap = bitmap;
454 bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
456 // Also at this point we set the BF_COMPACTED flag
457 // for this block. The invariant is that
458 // BF_COMPACTED is always unset, except during GC
459 // when it is set on those blocks which will be
461 bd->flags |= BF_COMPACTED;
468 /* make sure the older generations have at least one block to
469 * allocate into (this makes things easier for copy(), see below).
471 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
472 for (s = 0; s < generations[g].n_steps; s++) {
473 stp = &generations[g].steps[s];
474 if (stp->hp_bd == NULL) {
475 ASSERT(stp->blocks == NULL);
476 bd = gc_alloc_block(stp);
480 /* Set the scan pointer for older generations: remember we
481 * still have to scavenge objects that have been promoted. */
483 stp->scan_bd = stp->hp_bd;
484 stp->to_blocks = NULL;
485 stp->n_to_blocks = 0;
486 stp->new_large_objects = NULL;
487 stp->scavenged_large_objects = NULL;
488 stp->n_scavenged_large_blocks = 0;
492 /* Allocate a mark stack if we're doing a major collection.
495 mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
496 mark_stack = (StgPtr *)mark_stack_bdescr->start;
497 mark_sp = mark_stack;
498 mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
500 mark_stack_bdescr = NULL;
503 /* -----------------------------------------------------------------------
504 * follow all the roots that we know about:
505 * - mutable lists from each generation > N
506 * we want to *scavenge* these roots, not evacuate them: they're not
507 * going to move in this GC.
508 * Also: do them in reverse generation order. This is because we
509 * often want to promote objects that are pointed to by older
510 * generations early, so we don't have to repeatedly copy them.
511 * Doing the generations in reverse order ensures that we don't end
512 * up in the situation where we want to evac an object to gen 3 and
513 * it has already been evaced to gen 2.
517 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
518 generations[g].saved_mut_list = generations[g].mut_list;
519 generations[g].mut_list = END_MUT_LIST;
522 // Do the mut-once lists first
523 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
524 IF_PAR_DEBUG(verbose,
525 printMutOnceList(&generations[g]));
526 scavenge_mut_once_list(&generations[g]);
528 for (st = generations[g].n_steps-1; st >= 0; st--) {
529 scavenge(&generations[g].steps[st]);
533 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
534 IF_PAR_DEBUG(verbose,
535 printMutableList(&generations[g]));
536 scavenge_mutable_list(&generations[g]);
538 for (st = generations[g].n_steps-1; st >= 0; st--) {
539 scavenge(&generations[g].steps[st]);
544 /* follow roots from the CAF list (used by GHCi)
549 /* follow all the roots that the application knows about.
552 get_roots(mark_root);
555 /* And don't forget to mark the TSO if we got here direct from
557 /* Not needed in a seq version?
559 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
563 // Mark the entries in the GALA table of the parallel system
564 markLocalGAs(major_gc);
565 // Mark all entries on the list of pending fetches
566 markPendingFetches(major_gc);
569 /* Mark the weak pointer list, and prepare to detect dead weak
572 mark_weak_ptr_list(&weak_ptr_list);
573 old_weak_ptr_list = weak_ptr_list;
574 weak_ptr_list = NULL;
575 weak_stage = WeakPtrs;
577 /* The all_threads list is like the weak_ptr_list.
578 * See traverse_weak_ptr_list() for the details.
580 old_all_threads = all_threads;
581 all_threads = END_TSO_QUEUE;
582 resurrected_threads = END_TSO_QUEUE;
584 /* Mark the stable pointer table.
586 markStablePtrTable(mark_root);
590 /* ToDo: To fix the caf leak, we need to make the commented out
591 * parts of this code do something sensible - as described in
594 extern void markHugsObjects(void);
599 /* -------------------------------------------------------------------------
600 * Repeatedly scavenge all the areas we know about until there's no
601 * more scavenging to be done.
608 // scavenge static objects
609 if (major_gc && static_objects != END_OF_STATIC_LIST) {
610 IF_DEBUG(sanity, checkStaticObjects(static_objects));
614 /* When scavenging the older generations: Objects may have been
615 * evacuated from generations <= N into older generations, and we
616 * need to scavenge these objects. We're going to try to ensure that
617 * any evacuations that occur move the objects into at least the
618 * same generation as the object being scavenged, otherwise we
619 * have to create new entries on the mutable list for the older
623 // scavenge each step in generations 0..maxgen
629 // scavenge objects in compacted generation
630 if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
631 (mark_stack_bdescr != NULL && !mark_stack_empty())) {
632 scavenge_mark_stack();
636 for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
637 for (st = generations[gen].n_steps; --st >= 0; ) {
638 if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
641 stp = &generations[gen].steps[st];
643 if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
648 if (stp->new_large_objects != NULL) {
657 if (flag) { goto loop; }
659 // must be last... invariant is that everything is fully
660 // scavenged at this point.
661 if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something
666 /* Update the pointers from the "main thread" list - these are
667 * treated as weak pointers because we want to allow a main thread
668 * to get a BlockedOnDeadMVar exception in the same way as any other
669 * thread. Note that the threads should all have been retained by
670 * GC by virtue of being on the all_threads list, we're just
671 * updating pointers here.
676 for (m = main_threads; m != NULL; m = m->link) {
677 tso = (StgTSO *) isAlive((StgClosure *)m->tso);
679 barf("main thread has been GC'd");
686 // Reconstruct the Global Address tables used in GUM
687 rebuildGAtables(major_gc);
688 IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
691 // Now see which stable names are still alive.
694 // Tidy the end of the to-space chains
695 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
696 for (s = 0; s < generations[g].n_steps; s++) {
697 stp = &generations[g].steps[s];
698 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
699 ASSERT(Bdescr(stp->hp) == stp->hp_bd);
700 stp->hp_bd->free = stp->hp;
706 // We call processHeapClosureForDead() on every closure destroyed during
707 // the current garbage collection, so we invoke LdvCensusForDead().
708 if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
709 || RtsFlags.ProfFlags.bioSelector != NULL)
713 // NO MORE EVACUATION AFTER THIS POINT!
714 // Finally: compaction of the oldest generation.
715 if (major_gc && oldest_gen->steps[0].is_compacted) {
716 // save number of blocks for stats
717 oldgen_saved_blocks = oldest_gen->steps[0].n_blocks;
721 IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
723 /* run through all the generations/steps and tidy up
725 copied = new_blocks * BLOCK_SIZE_W;
726 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
729 generations[g].collections++; // for stats
732 for (s = 0; s < generations[g].n_steps; s++) {
734 stp = &generations[g].steps[s];
736 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
737 // stats information: how much we copied
739 copied -= stp->hp_bd->start + BLOCK_SIZE_W -
744 // for generations we collected...
747 // rough calculation of garbage collected, for stats output
748 if (stp->is_compacted) {
749 collected += (oldgen_saved_blocks - stp->n_blocks) * BLOCK_SIZE_W;
751 collected += stp->n_blocks * BLOCK_SIZE_W;
754 /* free old memory and shift to-space into from-space for all
755 * the collected steps (except the allocation area). These
756 * freed blocks will probaby be quickly recycled.
758 if (!(g == 0 && s == 0)) {
759 if (stp->is_compacted) {
760 // for a compacted step, just shift the new to-space
761 // onto the front of the now-compacted existing blocks.
762 for (bd = stp->to_blocks; bd != NULL; bd = bd->link) {
763 bd->flags &= ~BF_EVACUATED; // now from-space
765 // tack the new blocks on the end of the existing blocks
766 if (stp->blocks == NULL) {
767 stp->blocks = stp->to_blocks;
769 for (bd = stp->blocks; bd != NULL; bd = next) {
772 bd->link = stp->to_blocks;
774 // NB. this step might not be compacted next
775 // time, so reset the BF_COMPACTED flags.
776 // They are set before GC if we're going to
777 // compact. (search for BF_COMPACTED above).
778 bd->flags &= ~BF_COMPACTED;
781 // add the new blocks to the block tally
782 stp->n_blocks += stp->n_to_blocks;
784 freeChain(stp->blocks);
785 stp->blocks = stp->to_blocks;
786 stp->n_blocks = stp->n_to_blocks;
787 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
788 bd->flags &= ~BF_EVACUATED; // now from-space
791 stp->to_blocks = NULL;
792 stp->n_to_blocks = 0;
795 /* LARGE OBJECTS. The current live large objects are chained on
796 * scavenged_large, having been moved during garbage
797 * collection from large_objects. Any objects left on
798 * large_objects list are therefore dead, so we free them here.
800 for (bd = stp->large_objects; bd != NULL; bd = next) {
806 // update the count of blocks used by large objects
807 for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
808 bd->flags &= ~BF_EVACUATED;
810 stp->large_objects = stp->scavenged_large_objects;
811 stp->n_large_blocks = stp->n_scavenged_large_blocks;
814 // for older generations...
816 /* For older generations, we need to append the
817 * scavenged_large_object list (i.e. large objects that have been
818 * promoted during this GC) to the large_object list for that step.
820 for (bd = stp->scavenged_large_objects; bd; bd = next) {
822 bd->flags &= ~BF_EVACUATED;
823 dbl_link_onto(bd, &stp->large_objects);
826 // add the new blocks we promoted during this GC
827 stp->n_blocks += stp->n_to_blocks;
828 stp->n_to_blocks = 0;
829 stp->n_large_blocks += stp->n_scavenged_large_blocks;
834 /* Reset the sizes of the older generations when we do a major
837 * CURRENT STRATEGY: make all generations except zero the same size.
838 * We have to stay within the maximum heap size, and leave a certain
839 * percentage of the maximum heap size available to allocate into.
841 if (major_gc && RtsFlags.GcFlags.generations > 1) {
842 nat live, size, min_alloc;
843 nat max = RtsFlags.GcFlags.maxHeapSize;
844 nat gens = RtsFlags.GcFlags.generations;
846 // live in the oldest generations
847 live = oldest_gen->steps[0].n_blocks +
848 oldest_gen->steps[0].n_large_blocks;
850 // default max size for all generations except zero
851 size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
852 RtsFlags.GcFlags.minOldGenSize);
854 // minimum size for generation zero
855 min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
856 RtsFlags.GcFlags.minAllocAreaSize);
858 // Auto-enable compaction when the residency reaches a
859 // certain percentage of the maximum heap size (default: 30%).
860 if (RtsFlags.GcFlags.generations > 1 &&
861 (RtsFlags.GcFlags.compact ||
863 oldest_gen->steps[0].n_blocks >
864 (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
865 oldest_gen->steps[0].is_compacted = 1;
866 // fprintf(stderr,"compaction: on\n", live);
868 oldest_gen->steps[0].is_compacted = 0;
869 // fprintf(stderr,"compaction: off\n", live);
872 // if we're going to go over the maximum heap size, reduce the
873 // size of the generations accordingly. The calculation is
874 // different if compaction is turned on, because we don't need
875 // to double the space required to collect the old generation.
878 // this test is necessary to ensure that the calculations
879 // below don't have any negative results - we're working
880 // with unsigned values here.
881 if (max < min_alloc) {
885 if (oldest_gen->steps[0].is_compacted) {
886 if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
887 size = (max - min_alloc) / ((gens - 1) * 2 - 1);
890 if ( (size * (gens - 1) * 2) + min_alloc > max ) {
891 size = (max - min_alloc) / ((gens - 1) * 2);
901 fprintf(stderr,"live: %d, min_alloc: %d, size : %d, max = %d\n", live,
902 min_alloc, size, max);
905 for (g = 0; g < gens; g++) {
906 generations[g].max_blocks = size;
910 // Guess the amount of live data for stats.
913 /* Free the small objects allocated via allocate(), since this will
914 * all have been copied into G0S1 now.
916 if (small_alloc_list != NULL) {
917 freeChain(small_alloc_list);
919 small_alloc_list = NULL;
923 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
925 // Start a new pinned_object_block
926 pinned_object_block = NULL;
928 /* Free the mark stack.
930 if (mark_stack_bdescr != NULL) {
931 freeGroup(mark_stack_bdescr);
936 for (g = 0; g <= N; g++) {
937 for (s = 0; s < generations[g].n_steps; s++) {
938 stp = &generations[g].steps[s];
939 if (stp->is_compacted && stp->bitmap != NULL) {
940 freeGroup(stp->bitmap);
945 /* Two-space collector:
946 * Free the old to-space, and estimate the amount of live data.
948 if (RtsFlags.GcFlags.generations == 1) {
951 if (old_to_blocks != NULL) {
952 freeChain(old_to_blocks);
954 for (bd = g0s0->to_blocks; bd != NULL; bd = bd->link) {
955 bd->flags = 0; // now from-space
958 /* For a two-space collector, we need to resize the nursery. */
960 /* set up a new nursery. Allocate a nursery size based on a
961 * function of the amount of live data (by default a factor of 2)
962 * Use the blocks from the old nursery if possible, freeing up any
965 * If we get near the maximum heap size, then adjust our nursery
966 * size accordingly. If the nursery is the same size as the live
967 * data (L), then we need 3L bytes. We can reduce the size of the
968 * nursery to bring the required memory down near 2L bytes.
970 * A normal 2-space collector would need 4L bytes to give the same
971 * performance we get from 3L bytes, reducing to the same
972 * performance at 2L bytes.
974 blocks = g0s0->n_to_blocks;
976 if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
977 blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
978 RtsFlags.GcFlags.maxHeapSize ) {
979 long adjusted_blocks; // signed on purpose
982 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
983 IF_DEBUG(gc, belch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
984 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
985 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
988 blocks = adjusted_blocks;
991 blocks *= RtsFlags.GcFlags.oldGenFactor;
992 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
993 blocks = RtsFlags.GcFlags.minAllocAreaSize;
996 resizeNursery(blocks);
999 /* Generational collector:
1000 * If the user has given us a suggested heap size, adjust our
1001 * allocation area to make best use of the memory available.
1004 if (RtsFlags.GcFlags.heapSizeSuggestion) {
1006 nat needed = calcNeeded(); // approx blocks needed at next GC
1008 /* Guess how much will be live in generation 0 step 0 next time.
1009 * A good approximation is obtained by finding the
1010 * percentage of g0s0 that was live at the last minor GC.
1013 g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
1016 /* Estimate a size for the allocation area based on the
1017 * information available. We might end up going slightly under
1018 * or over the suggested heap size, but we should be pretty
1021 * Formula: suggested - needed
1022 * ----------------------------
1023 * 1 + g0s0_pcnt_kept/100
1025 * where 'needed' is the amount of memory needed at the next
1026 * collection for collecting all steps except g0s0.
1029 (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
1030 (100 + (long)g0s0_pcnt_kept);
1032 if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
1033 blocks = RtsFlags.GcFlags.minAllocAreaSize;
1036 resizeNursery((nat)blocks);
1039 // we might have added extra large blocks to the nursery, so
1040 // resize back to minAllocAreaSize again.
1041 resizeNursery(RtsFlags.GcFlags.minAllocAreaSize);
1045 // mark the garbage collected CAFs as dead
1046 #if 0 && defined(DEBUG) // doesn't work at the moment
1047 if (major_gc) { gcCAFs(); }
1051 // resetStaticObjectForRetainerProfiling() must be called before
1053 resetStaticObjectForRetainerProfiling();
1056 // zero the scavenged static object list
1058 zero_static_object_list(scavenged_static_objects);
1061 // Reset the nursery
1064 RELEASE_LOCK(&sched_mutex);
1066 // start any pending finalizers
1067 scheduleFinalizers(old_weak_ptr_list);
1069 // send exceptions to any threads which were about to die
1070 resurrectThreads(resurrected_threads);
1072 ACQUIRE_LOCK(&sched_mutex);
1074 // Update the stable pointer hash table.
1075 updateStablePtrTable(major_gc);
1077 // check sanity after GC
1078 IF_DEBUG(sanity, checkSanity());
1080 // extra GC trace info
1081 IF_DEBUG(gc, statDescribeGens());
1084 // symbol-table based profiling
1085 /* heapCensus(to_blocks); */ /* ToDo */
1088 // restore enclosing cost centre
1093 // check for memory leaks if sanity checking is on
1094 IF_DEBUG(sanity, memInventory());
1096 #ifdef RTS_GTK_FRONTPANEL
1097 if (RtsFlags.GcFlags.frontpanel) {
1098 updateFrontPanelAfterGC( N, live );
1102 // ok, GC over: tell the stats department what happened.
1103 stat_endGC(allocated, collected, live, copied, N);
1105 #if defined(RTS_USER_SIGNALS)
1106 // unblock signals again
1107 unblockUserSignals();
1114 /* -----------------------------------------------------------------------------
1117 traverse_weak_ptr_list is called possibly many times during garbage
1118 collection. It returns a flag indicating whether it did any work
1119 (i.e. called evacuate on any live pointers).
1121 Invariant: traverse_weak_ptr_list is called when the heap is in an
1122 idempotent state. That means that there are no pending
1123 evacuate/scavenge operations. This invariant helps the weak
1124 pointer code decide which weak pointers are dead - if there are no
1125 new live weak pointers, then all the currently unreachable ones are
1128 For generational GC: we just don't try to finalize weak pointers in
1129 older generations than the one we're collecting. This could
1130 probably be optimised by keeping per-generation lists of weak
1131 pointers, but for a few weak pointers this scheme will work.
1133 There are three distinct stages to processing weak pointers:
1135 - weak_stage == WeakPtrs
1137 We process all the weak pointers whos keys are alive (evacuate
1138 their values and finalizers), and repeat until we can find no new
1139 live keys. If no live keys are found in this pass, then we
1140 evacuate the finalizers of all the dead weak pointers in order to
1143 - weak_stage == WeakThreads
1145 Now, we discover which *threads* are still alive. Pointers to
1146 threads from the all_threads and main thread lists are the
1147 weakest of all: a pointers from the finalizer of a dead weak
1148 pointer can keep a thread alive. Any threads found to be unreachable
1149 are evacuated and placed on the resurrected_threads list so we
1150 can send them a signal later.
1152 - weak_stage == WeakDone
1154 No more evacuation is done.
1156 -------------------------------------------------------------------------- */
1159 traverse_weak_ptr_list(void)
1161 StgWeak *w, **last_w, *next_w;
1163 rtsBool flag = rtsFalse;
1165 switch (weak_stage) {
1171 /* doesn't matter where we evacuate values/finalizers to, since
1172 * these pointers are treated as roots (iff the keys are alive).
1176 last_w = &old_weak_ptr_list;
1177 for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1179 /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1180 * called on a live weak pointer object. Just remove it.
1182 if (w->header.info == &stg_DEAD_WEAK_info) {
1183 next_w = ((StgDeadWeak *)w)->link;
1188 switch (get_itbl(w)->type) {
1191 next_w = (StgWeak *)((StgEvacuated *)w)->evacuee;
1196 /* Now, check whether the key is reachable.
1198 new = isAlive(w->key);
1201 // evacuate the value and finalizer
1202 w->value = evacuate(w->value);
1203 w->finalizer = evacuate(w->finalizer);
1204 // remove this weak ptr from the old_weak_ptr list
1206 // and put it on the new weak ptr list
1208 w->link = weak_ptr_list;
1211 IF_DEBUG(weak, belch("Weak pointer still alive at %p -> %p",
1216 last_w = &(w->link);
1222 barf("traverse_weak_ptr_list: not WEAK");
1226 /* If we didn't make any changes, then we can go round and kill all
1227 * the dead weak pointers. The old_weak_ptr list is used as a list
1228 * of pending finalizers later on.
1230 if (flag == rtsFalse) {
1231 for (w = old_weak_ptr_list; w; w = w->link) {
1232 w->finalizer = evacuate(w->finalizer);
1235 // Next, move to the WeakThreads stage after fully
1236 // scavenging the finalizers we've just evacuated.
1237 weak_stage = WeakThreads;
1243 /* Now deal with the all_threads list, which behaves somewhat like
1244 * the weak ptr list. If we discover any threads that are about to
1245 * become garbage, we wake them up and administer an exception.
1248 StgTSO *t, *tmp, *next, **prev;
1250 prev = &old_all_threads;
1251 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1253 (StgClosure *)tmp = isAlive((StgClosure *)t);
1259 ASSERT(get_itbl(t)->type == TSO);
1260 switch (t->what_next) {
1261 case ThreadRelocated:
1266 case ThreadComplete:
1267 // finshed or died. The thread might still be alive, but we
1268 // don't keep it on the all_threads list. Don't forget to
1269 // stub out its global_link field.
1270 next = t->global_link;
1271 t->global_link = END_TSO_QUEUE;
1279 // not alive (yet): leave this thread on the
1280 // old_all_threads list.
1281 prev = &(t->global_link);
1282 next = t->global_link;
1285 // alive: move this thread onto the all_threads list.
1286 next = t->global_link;
1287 t->global_link = all_threads;
1294 /* And resurrect any threads which were about to become garbage.
1297 StgTSO *t, *tmp, *next;
1298 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1299 next = t->global_link;
1300 (StgClosure *)tmp = evacuate((StgClosure *)t);
1301 tmp->global_link = resurrected_threads;
1302 resurrected_threads = tmp;
1306 weak_stage = WeakDone; // *now* we're done,
1307 return rtsTrue; // but one more round of scavenging, please
1310 barf("traverse_weak_ptr_list");
1316 /* -----------------------------------------------------------------------------
1317 After GC, the live weak pointer list may have forwarding pointers
1318 on it, because a weak pointer object was evacuated after being
1319 moved to the live weak pointer list. We remove those forwarding
1322 Also, we don't consider weak pointer objects to be reachable, but
1323 we must nevertheless consider them to be "live" and retain them.
1324 Therefore any weak pointer objects which haven't as yet been
1325 evacuated need to be evacuated now.
1326 -------------------------------------------------------------------------- */
1330 mark_weak_ptr_list ( StgWeak **list )
1332 StgWeak *w, **last_w;
1335 for (w = *list; w; w = w->link) {
1336 // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
1337 ASSERT(w->header.info == &stg_DEAD_WEAK_info
1338 || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
1339 (StgClosure *)w = evacuate((StgClosure *)w);
1341 last_w = &(w->link);
1345 /* -----------------------------------------------------------------------------
1346 isAlive determines whether the given closure is still alive (after
1347 a garbage collection) or not. It returns the new address of the
1348 closure if it is alive, or NULL otherwise.
1350 NOTE: Use it before compaction only!
1351 -------------------------------------------------------------------------- */
1355 isAlive(StgClosure *p)
1357 const StgInfoTable *info;
1362 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1365 // ignore static closures
1367 // ToDo: for static closures, check the static link field.
1368 // Problem here is that we sometimes don't set the link field, eg.
1369 // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1371 if (!HEAP_ALLOCED(p)) {
1375 // ignore closures in generations that we're not collecting.
1377 if (bd->gen_no > N) {
1381 // if it's a pointer into to-space, then we're done
1382 if (bd->flags & BF_EVACUATED) {
1386 // large objects use the evacuated flag
1387 if (bd->flags & BF_LARGE) {
1391 // check the mark bit for compacted steps
1392 if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1396 switch (info->type) {
1401 case IND_OLDGEN: // rely on compatible layout with StgInd
1402 case IND_OLDGEN_PERM:
1403 // follow indirections
1404 p = ((StgInd *)p)->indirectee;
1409 return ((StgEvacuated *)p)->evacuee;
1412 if (((StgTSO *)p)->what_next == ThreadRelocated) {
1413 p = (StgClosure *)((StgTSO *)p)->link;
1426 mark_root(StgClosure **root)
1428 *root = evacuate(*root);
1432 upd_evacuee(StgClosure *p, StgClosure *dest)
1434 // Source object must be in from-space:
1435 ASSERT((Bdescr((P_)p)->flags & BF_EVACUATED) == 0);
1436 // not true: (ToDo: perhaps it should be)
1437 // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
1438 p->header.info = &stg_EVACUATED_info;
1439 ((StgEvacuated *)p)->evacuee = dest;
1443 STATIC_INLINE StgClosure *
1444 copy(StgClosure *src, nat size, step *stp)
1449 nat size_org = size;
1452 TICK_GC_WORDS_COPIED(size);
1453 /* Find out where we're going, using the handy "to" pointer in
1454 * the step of the source object. If it turns out we need to
1455 * evacuate to an older generation, adjust it here (see comment
1458 if (stp->gen_no < evac_gen) {
1459 #ifdef NO_EAGER_PROMOTION
1460 failed_to_evac = rtsTrue;
1462 stp = &generations[evac_gen].steps[0];
1466 /* chain a new block onto the to-space for the destination step if
1469 if (stp->hp + size >= stp->hpLim) {
1470 gc_alloc_block(stp);
1473 for(to = stp->hp, from = (P_)src; size>0; --size) {
1479 upd_evacuee(src,(StgClosure *)dest);
1481 // We store the size of the just evacuated object in the LDV word so that
1482 // the profiler can guess the position of the next object later.
1483 SET_EVACUAEE_FOR_LDV(src, size_org);
1485 return (StgClosure *)dest;
1488 /* Special version of copy() for when we only want to copy the info
1489 * pointer of an object, but reserve some padding after it. This is
1490 * used to optimise evacuation of BLACKHOLEs.
1495 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1500 nat size_to_copy_org = size_to_copy;
1503 TICK_GC_WORDS_COPIED(size_to_copy);
1504 if (stp->gen_no < evac_gen) {
1505 #ifdef NO_EAGER_PROMOTION
1506 failed_to_evac = rtsTrue;
1508 stp = &generations[evac_gen].steps[0];
1512 if (stp->hp + size_to_reserve >= stp->hpLim) {
1513 gc_alloc_block(stp);
1516 for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1521 stp->hp += size_to_reserve;
1522 upd_evacuee(src,(StgClosure *)dest);
1524 // We store the size of the just evacuated object in the LDV word so that
1525 // the profiler can guess the position of the next object later.
1526 // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1528 SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1530 if (size_to_reserve - size_to_copy_org > 0)
1531 FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1533 return (StgClosure *)dest;
1537 /* -----------------------------------------------------------------------------
1538 Evacuate a large object
1540 This just consists of removing the object from the (doubly-linked)
1541 step->large_objects list, and linking it on to the (singly-linked)
1542 step->new_large_objects list, from where it will be scavenged later.
1544 Convention: bd->flags has BF_EVACUATED set for a large object
1545 that has been evacuated, or unset otherwise.
1546 -------------------------------------------------------------------------- */
1550 evacuate_large(StgPtr p)
1552 bdescr *bd = Bdescr(p);
1555 // object must be at the beginning of the block (or be a ByteArray)
1556 ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1557 (((W_)p & BLOCK_MASK) == 0));
1559 // already evacuated?
1560 if (bd->flags & BF_EVACUATED) {
1561 /* Don't forget to set the failed_to_evac flag if we didn't get
1562 * the desired destination (see comments in evacuate()).
1564 if (bd->gen_no < evac_gen) {
1565 failed_to_evac = rtsTrue;
1566 TICK_GC_FAILED_PROMOTION();
1572 // remove from large_object list
1574 bd->u.back->link = bd->link;
1575 } else { // first object in the list
1576 stp->large_objects = bd->link;
1579 bd->link->u.back = bd->u.back;
1582 /* link it on to the evacuated large object list of the destination step
1585 if (stp->gen_no < evac_gen) {
1586 #ifdef NO_EAGER_PROMOTION
1587 failed_to_evac = rtsTrue;
1589 stp = &generations[evac_gen].steps[0];
1594 bd->gen_no = stp->gen_no;
1595 bd->link = stp->new_large_objects;
1596 stp->new_large_objects = bd;
1597 bd->flags |= BF_EVACUATED;
1600 /* -----------------------------------------------------------------------------
1601 Adding a MUT_CONS to an older generation.
1603 This is necessary from time to time when we end up with an
1604 old-to-new generation pointer in a non-mutable object. We defer
1605 the promotion until the next GC.
1606 -------------------------------------------------------------------------- */
1609 mkMutCons(StgClosure *ptr, generation *gen)
1614 stp = &gen->steps[0];
1616 /* chain a new block onto the to-space for the destination step if
1619 if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
1620 gc_alloc_block(stp);
1623 q = (StgMutVar *)stp->hp;
1624 stp->hp += sizeofW(StgMutVar);
1626 SET_HDR(q,&stg_MUT_CONS_info,CCS_GC);
1628 recordOldToNewPtrs((StgMutClosure *)q);
1630 return (StgClosure *)q;
1633 /* -----------------------------------------------------------------------------
1636 This is called (eventually) for every live object in the system.
1638 The caller to evacuate specifies a desired generation in the
1639 evac_gen global variable. The following conditions apply to
1640 evacuating an object which resides in generation M when we're
1641 collecting up to generation N
1645 else evac to step->to
1647 if M < evac_gen evac to evac_gen, step 0
1649 if the object is already evacuated, then we check which generation
1652 if M >= evac_gen do nothing
1653 if M < evac_gen set failed_to_evac flag to indicate that we
1654 didn't manage to evacuate this object into evac_gen.
1659 evacuate() is the single most important function performance-wise
1660 in the GC. Various things have been tried to speed it up, but as
1661 far as I can tell the code generated by gcc 3.2 with -O2 is about
1662 as good as it's going to get. We pass the argument to evacuate()
1663 in a register using the 'regparm' attribute (see the prototype for
1664 evacuate() near the top of this file).
1666 Changing evacuate() to take an (StgClosure **) rather than
1667 returning the new pointer seems attractive, because we can avoid
1668 writing back the pointer when it hasn't changed (eg. for a static
1669 object, or an object in a generation > N). However, I tried it and
1670 it doesn't help. One reason is that the (StgClosure **) pointer
1671 gets spilled to the stack inside evacuate(), resulting in far more
1672 extra reads/writes than we save.
1673 -------------------------------------------------------------------------- */
1675 REGPARM1 static StgClosure *
1676 evacuate(StgClosure *q)
1681 const StgInfoTable *info;
1684 if (HEAP_ALLOCED(q)) {
1687 if (bd->gen_no > N) {
1688 /* Can't evacuate this object, because it's in a generation
1689 * older than the ones we're collecting. Let's hope that it's
1690 * in evac_gen or older, or we will have to arrange to track
1691 * this pointer using the mutable list.
1693 if (bd->gen_no < evac_gen) {
1695 failed_to_evac = rtsTrue;
1696 TICK_GC_FAILED_PROMOTION();
1701 /* evacuate large objects by re-linking them onto a different list.
1703 if (bd->flags & BF_LARGE) {
1705 if (info->type == TSO &&
1706 ((StgTSO *)q)->what_next == ThreadRelocated) {
1707 q = (StgClosure *)((StgTSO *)q)->link;
1710 evacuate_large((P_)q);
1714 /* If the object is in a step that we're compacting, then we
1715 * need to use an alternative evacuate procedure.
1717 if (bd->flags & BF_COMPACTED) {
1718 if (!is_marked((P_)q,bd)) {
1720 if (mark_stack_full()) {
1721 mark_stack_overflowed = rtsTrue;
1724 push_mark_stack((P_)q);
1732 else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1735 // make sure the info pointer is into text space
1736 ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
1739 switch (info -> type) {
1743 return copy(q,sizeW_fromITBL(info),stp);
1747 StgWord w = (StgWord)q->payload[0];
1748 if (q->header.info == Czh_con_info &&
1749 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
1750 (StgChar)w <= MAX_CHARLIKE) {
1751 return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1753 if (q->header.info == Izh_con_info &&
1754 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1755 return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1757 // else, fall through ...
1763 return copy(q,sizeofW(StgHeader)+1,stp);
1765 case THUNK_1_0: // here because of MIN_UPD_SIZE
1770 #ifdef NO_PROMOTE_THUNKS
1771 if (bd->gen_no == 0 &&
1772 bd->step->no != 0 &&
1773 bd->step->no == generations[bd->gen_no].n_steps-1) {
1777 return copy(q,sizeofW(StgHeader)+2,stp);
1785 return copy(q,sizeofW(StgHeader)+2,stp);
1791 case IND_OLDGEN_PERM:
1795 return copy(q,sizeW_fromITBL(info),stp);
1798 return copy(q,bco_sizeW((StgBCO *)q),stp);
1801 case SE_CAF_BLACKHOLE:
1804 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1807 to = copy(q,BLACKHOLE_sizeW(),stp);
1810 case THUNK_SELECTOR:
1814 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
1815 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1818 p = eval_thunk_selector(info->layout.selector_offset,
1822 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1824 // q is still BLACKHOLE'd.
1825 thunk_selector_depth++;
1827 thunk_selector_depth--;
1830 // We store the size of the just evacuated object in the
1831 // LDV word so that the profiler can guess the position of
1832 // the next object later.
1833 SET_EVACUAEE_FOR_LDV(q, THUNK_SELECTOR_sizeW());
1841 // follow chains of indirections, don't evacuate them
1842 q = ((StgInd*)q)->indirectee;
1846 if (info->srt_bitmap != 0 && major_gc &&
1847 THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1848 THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1849 static_objects = (StgClosure *)q;
1854 if (info->srt_bitmap != 0 && major_gc &&
1855 FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1856 FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1857 static_objects = (StgClosure *)q;
1862 /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1863 * on the CAF list, so don't do anything with it here (we'll
1864 * scavenge it later).
1867 && ((StgIndStatic *)q)->saved_info == NULL
1868 && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1869 IND_STATIC_LINK((StgClosure *)q) = static_objects;
1870 static_objects = (StgClosure *)q;
1875 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1876 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1877 static_objects = (StgClosure *)q;
1881 case CONSTR_INTLIKE:
1882 case CONSTR_CHARLIKE:
1883 case CONSTR_NOCAF_STATIC:
1884 /* no need to put these on the static linked list, they don't need
1898 // shouldn't see these
1899 barf("evacuate: stack frame at %p\n", q);
1903 return copy(q,pap_sizeW((StgPAP*)q),stp);
1906 return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
1909 /* Already evacuated, just return the forwarding address.
1910 * HOWEVER: if the requested destination generation (evac_gen) is
1911 * older than the actual generation (because the object was
1912 * already evacuated to a younger generation) then we have to
1913 * set the failed_to_evac flag to indicate that we couldn't
1914 * manage to promote the object to the desired generation.
1916 if (evac_gen > 0) { // optimisation
1917 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1918 if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
1919 failed_to_evac = rtsTrue;
1920 TICK_GC_FAILED_PROMOTION();
1923 return ((StgEvacuated*)q)->evacuee;
1926 // just copy the block
1927 return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1930 case MUT_ARR_PTRS_FROZEN:
1931 // just copy the block
1932 return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1936 StgTSO *tso = (StgTSO *)q;
1938 /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1940 if (tso->what_next == ThreadRelocated) {
1941 q = (StgClosure *)tso->link;
1945 /* To evacuate a small TSO, we need to relocate the update frame
1952 new_tso = (StgTSO *)copyPart((StgClosure *)tso,
1954 sizeofW(StgTSO), stp);
1955 move_TSO(tso, new_tso);
1956 for (p = tso->sp, q = new_tso->sp;
1957 p < tso->stack+tso->stack_size;) {
1961 return (StgClosure *)new_tso;
1966 case RBH: // cf. BLACKHOLE_BQ
1968 //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1969 to = copy(q,BLACKHOLE_sizeW(),stp);
1970 //ToDo: derive size etc from reverted IP
1971 //to = copy(q,size,stp);
1973 belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1974 q, info_type(q), to, info_type(to)));
1979 ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1980 to = copy(q,sizeofW(StgBlockedFetch),stp);
1982 belch("@@ evacuate: %p (%s) to %p (%s)",
1983 q, info_type(q), to, info_type(to)));
1990 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1991 to = copy(q,sizeofW(StgFetchMe),stp);
1993 belch("@@ evacuate: %p (%s) to %p (%s)",
1994 q, info_type(q), to, info_type(to)));
1998 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1999 to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2001 belch("@@ evacuate: %p (%s) to %p (%s)",
2002 q, info_type(q), to, info_type(to)));
2007 barf("evacuate: strange closure type %d", (int)(info->type));
2013 /* -----------------------------------------------------------------------------
2014 Evaluate a THUNK_SELECTOR if possible.
2016 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2017 a closure pointer if we evaluated it and this is the result. Note
2018 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2019 reducing it to HNF, just that we have eliminated the selection.
2020 The result might be another thunk, or even another THUNK_SELECTOR.
2022 If the return value is non-NULL, the original selector thunk has
2023 been BLACKHOLE'd, and should be updated with an indirection or a
2024 forwarding pointer. If the return value is NULL, then the selector
2026 -------------------------------------------------------------------------- */
2028 static inline rtsBool
2029 is_to_space ( StgClosure *p )
2033 bd = Bdescr((StgPtr)p);
2034 if (HEAP_ALLOCED(p) &&
2035 ((bd->flags & BF_EVACUATED)
2036 || ((bd->flags & BF_COMPACTED) &&
2037 is_marked((P_)p,bd)))) {
2045 eval_thunk_selector( nat field, StgSelector * p )
2048 const StgInfoTable *info_ptr;
2049 StgClosure *selectee;
2051 selectee = p->selectee;
2053 // Save the real info pointer (NOTE: not the same as get_itbl()).
2054 info_ptr = p->header.info;
2056 // If the THUNK_SELECTOR is in a generation that we are not
2057 // collecting, then bail out early. We won't be able to save any
2058 // space in any case, and updating with an indirection is trickier
2060 if (Bdescr((StgPtr)p)->gen_no > N) {
2064 // BLACKHOLE the selector thunk, since it is now under evaluation.
2065 // This is important to stop us going into an infinite loop if
2066 // this selector thunk eventually refers to itself.
2067 SET_INFO(p,&stg_BLACKHOLE_info);
2071 // We don't want to end up in to-space, because this causes
2072 // problems when the GC later tries to evacuate the result of
2073 // eval_thunk_selector(). There are various ways this could
2076 // 1. following an IND_STATIC
2078 // 2. when the old generation is compacted, the mark phase updates
2079 // from-space pointers to be to-space pointers, and we can't
2080 // reliably tell which we're following (eg. from an IND_STATIC).
2082 // 3. compacting GC again: if we're looking at a constructor in
2083 // the compacted generation, it might point directly to objects
2084 // in to-space. We must bale out here, otherwise doing the selection
2085 // will result in a to-space pointer being returned.
2087 // (1) is dealt with using a BF_EVACUATED test on the
2088 // selectee. (2) and (3): we can tell if we're looking at an
2089 // object in the compacted generation that might point to
2090 // to-space objects by testing that (a) it is BF_COMPACTED, (b)
2091 // the compacted generation is being collected, and (c) the
2092 // object is marked. Only a marked object may have pointers that
2093 // point to to-space objects, because that happens when
2096 // The to-space test is now embodied in the in_to_space() inline
2097 // function, as it is re-used below.
2099 if (is_to_space(selectee)) {
2103 info = get_itbl(selectee);
2104 switch (info->type) {
2112 case CONSTR_NOCAF_STATIC:
2113 // check that the size is in range
2114 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
2115 info->layout.payload.nptrs));
2117 // Select the right field from the constructor, and check
2118 // that the result isn't in to-space. It might be in
2119 // to-space if, for example, this constructor contains
2120 // pointers to younger-gen objects (and is on the mut-once
2125 q = selectee->payload[field];
2126 if (is_to_space(q)) {
2136 case IND_OLDGEN_PERM:
2138 selectee = ((StgInd *)selectee)->indirectee;
2142 // We don't follow pointers into to-space; the constructor
2143 // has already been evacuated, so we won't save any space
2144 // leaks by evaluating this selector thunk anyhow.
2147 case THUNK_SELECTOR:
2151 // check that we don't recurse too much, re-using the
2152 // depth bound also used in evacuate().
2153 thunk_selector_depth++;
2154 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2158 val = eval_thunk_selector(info->layout.selector_offset,
2159 (StgSelector *)selectee);
2161 thunk_selector_depth--;
2166 // We evaluated this selector thunk, so update it with
2167 // an indirection. NOTE: we don't use UPD_IND here,
2168 // because we are guaranteed that p is in a generation
2169 // that we are collecting, and we never want to put the
2170 // indirection on a mutable list.
2172 // For the purposes of LDV profiling, we have destroyed
2173 // the original selector thunk.
2174 SET_INFO(p, info_ptr);
2175 LDV_recordDead_FILL_SLOP_DYNAMIC(selectee);
2177 ((StgInd *)selectee)->indirectee = val;
2178 SET_INFO(selectee,&stg_IND_info);
2180 // For the purposes of LDV profiling, we have created an
2182 LDV_recordCreate(selectee);
2199 case SE_CAF_BLACKHOLE:
2212 // not evaluated yet
2216 barf("eval_thunk_selector: strange selectee %d",
2221 // We didn't manage to evaluate this thunk; restore the old info pointer
2222 SET_INFO(p, info_ptr);
2226 /* -----------------------------------------------------------------------------
2227 move_TSO is called to update the TSO structure after it has been
2228 moved from one place to another.
2229 -------------------------------------------------------------------------- */
2232 move_TSO (StgTSO *src, StgTSO *dest)
2236 // relocate the stack pointer...
2237 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2238 dest->sp = (StgPtr)dest->sp + diff;
2241 /* Similar to scavenge_large_bitmap(), but we don't write back the
2242 * pointers we get back from evacuate().
2245 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2252 bitmap = large_srt->l.bitmap[b];
2253 size = (nat)large_srt->l.size;
2254 p = (StgClosure **)large_srt->srt;
2255 for (i = 0; i < size; ) {
2256 if ((bitmap & 1) != 0) {
2261 if (i % BITS_IN(W_) == 0) {
2263 bitmap = large_srt->l.bitmap[b];
2265 bitmap = bitmap >> 1;
2270 /* evacuate the SRT. If srt_bitmap is zero, then there isn't an
2271 * srt field in the info table. That's ok, because we'll
2272 * never dereference it.
2275 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2280 bitmap = srt_bitmap;
2283 if (bitmap == (StgHalfWord)(-1)) {
2284 scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2288 while (bitmap != 0) {
2289 if ((bitmap & 1) != 0) {
2290 #ifdef ENABLE_WIN32_DLL_SUPPORT
2291 // Special-case to handle references to closures hiding out in DLLs, since
2292 // double indirections required to get at those. The code generator knows
2293 // which is which when generating the SRT, so it stores the (indirect)
2294 // reference to the DLL closure in the table by first adding one to it.
2295 // We check for this here, and undo the addition before evacuating it.
2297 // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2298 // closure that's fixed at link-time, and no extra magic is required.
2299 if ( (unsigned long)(*srt) & 0x1 ) {
2300 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2309 bitmap = bitmap >> 1;
2315 scavenge_thunk_srt(const StgInfoTable *info)
2317 StgThunkInfoTable *thunk_info;
2319 thunk_info = itbl_to_thunk_itbl(info);
2320 scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_bitmap);
2324 scavenge_fun_srt(const StgInfoTable *info)
2326 StgFunInfoTable *fun_info;
2328 fun_info = itbl_to_fun_itbl(info);
2329 scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_bitmap);
2333 scavenge_ret_srt(const StgInfoTable *info)
2335 StgRetInfoTable *ret_info;
2337 ret_info = itbl_to_ret_itbl(info);
2338 scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_bitmap);
2341 /* -----------------------------------------------------------------------------
2343 -------------------------------------------------------------------------- */
2346 scavengeTSO (StgTSO *tso)
2348 // chase the link field for any TSOs on the same queue
2349 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2350 if ( tso->why_blocked == BlockedOnMVar
2351 || tso->why_blocked == BlockedOnBlackHole
2352 || tso->why_blocked == BlockedOnException
2354 || tso->why_blocked == BlockedOnGA
2355 || tso->why_blocked == BlockedOnGA_NoSend
2358 tso->block_info.closure = evacuate(tso->block_info.closure);
2360 if ( tso->blocked_exceptions != NULL ) {
2361 tso->blocked_exceptions =
2362 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2365 // scavenge this thread's stack
2366 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2369 /* -----------------------------------------------------------------------------
2370 Blocks of function args occur on the stack (at the top) and
2372 -------------------------------------------------------------------------- */
2374 STATIC_INLINE StgPtr
2375 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2382 switch (fun_info->fun_type) {
2384 bitmap = BITMAP_BITS(fun_info->bitmap);
2385 size = BITMAP_SIZE(fun_info->bitmap);
2388 size = ((StgLargeBitmap *)fun_info->bitmap)->size;
2389 scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
2393 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
2394 size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
2397 if ((bitmap & 1) == 0) {
2398 (StgClosure *)*p = evacuate((StgClosure *)*p);
2401 bitmap = bitmap >> 1;
2409 STATIC_INLINE StgPtr
2410 scavenge_PAP (StgPAP *pap)
2413 StgWord bitmap, size;
2414 StgFunInfoTable *fun_info;
2416 pap->fun = evacuate(pap->fun);
2417 fun_info = get_fun_itbl(pap->fun);
2418 ASSERT(fun_info->i.type != PAP);
2420 p = (StgPtr)pap->payload;
2423 switch (fun_info->fun_type) {
2425 bitmap = BITMAP_BITS(fun_info->bitmap);
2428 scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
2432 scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
2436 bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
2440 if ((bitmap & 1) == 0) {
2441 (StgClosure *)*p = evacuate((StgClosure *)*p);
2444 bitmap = bitmap >> 1;
2452 /* -----------------------------------------------------------------------------
2453 Scavenge a given step until there are no more objects in this step
2456 evac_gen is set by the caller to be either zero (for a step in a
2457 generation < N) or G where G is the generation of the step being
2460 We sometimes temporarily change evac_gen back to zero if we're
2461 scavenging a mutable object where early promotion isn't such a good
2463 -------------------------------------------------------------------------- */
2471 nat saved_evac_gen = evac_gen;
2476 failed_to_evac = rtsFalse;
2478 /* scavenge phase - standard breadth-first scavenging of the
2482 while (bd != stp->hp_bd || p < stp->hp) {
2484 // If we're at the end of this block, move on to the next block
2485 if (bd != stp->hp_bd && p == bd->free) {
2491 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2492 info = get_itbl((StgClosure *)p);
2494 ASSERT(thunk_selector_depth == 0);
2497 switch (info->type) {
2500 /* treat MVars specially, because we don't want to evacuate the
2501 * mut_link field in the middle of the closure.
2504 StgMVar *mvar = ((StgMVar *)p);
2506 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2507 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2508 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2509 evac_gen = saved_evac_gen;
2510 recordMutable((StgMutClosure *)mvar);
2511 failed_to_evac = rtsFalse; // mutable.
2512 p += sizeofW(StgMVar);
2517 scavenge_fun_srt(info);
2518 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2519 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2520 p += sizeofW(StgHeader) + 2;
2524 scavenge_thunk_srt(info);
2526 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2527 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2528 p += sizeofW(StgHeader) + 2;
2532 scavenge_thunk_srt(info);
2533 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2534 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2538 scavenge_fun_srt(info);
2540 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2541 p += sizeofW(StgHeader) + 1;
2545 scavenge_thunk_srt(info);
2546 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2550 scavenge_fun_srt(info);
2552 p += sizeofW(StgHeader) + 1;
2556 scavenge_thunk_srt(info);
2557 p += sizeofW(StgHeader) + 2;
2561 scavenge_fun_srt(info);
2563 p += sizeofW(StgHeader) + 2;
2567 scavenge_thunk_srt(info);
2568 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2569 p += sizeofW(StgHeader) + 2;
2573 scavenge_fun_srt(info);
2575 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2576 p += sizeofW(StgHeader) + 2;
2580 scavenge_fun_srt(info);
2584 scavenge_thunk_srt(info);
2595 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2596 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2597 (StgClosure *)*p = evacuate((StgClosure *)*p);
2599 p += info->layout.payload.nptrs;
2604 StgBCO *bco = (StgBCO *)p;
2605 (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2606 (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2607 (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2608 (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2609 p += bco_sizeW(bco);
2614 if (stp->gen->no != 0) {
2617 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2618 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2619 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2622 // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
2624 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2627 // We pretend that p has just been created.
2628 LDV_recordCreate((StgClosure *)p);
2632 case IND_OLDGEN_PERM:
2633 ((StgIndOldGen *)p)->indirectee =
2634 evacuate(((StgIndOldGen *)p)->indirectee);
2635 if (failed_to_evac) {
2636 failed_to_evac = rtsFalse;
2637 recordOldToNewPtrs((StgMutClosure *)p);
2639 p += sizeofW(StgIndOldGen);
2644 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2645 evac_gen = saved_evac_gen;
2646 recordMutable((StgMutClosure *)p);
2647 failed_to_evac = rtsFalse; // mutable anyhow
2648 p += sizeofW(StgMutVar);
2653 failed_to_evac = rtsFalse; // mutable anyhow
2654 p += sizeofW(StgMutVar);
2658 case SE_CAF_BLACKHOLE:
2661 p += BLACKHOLE_sizeW();
2666 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2667 (StgClosure *)bh->blocking_queue =
2668 evacuate((StgClosure *)bh->blocking_queue);
2669 recordMutable((StgMutClosure *)bh);
2670 failed_to_evac = rtsFalse;
2671 p += BLACKHOLE_sizeW();
2675 case THUNK_SELECTOR:
2677 StgSelector *s = (StgSelector *)p;
2678 s->selectee = evacuate(s->selectee);
2679 p += THUNK_SELECTOR_sizeW();
2683 // A chunk of stack saved in a heap object
2686 StgAP_STACK *ap = (StgAP_STACK *)p;
2688 ap->fun = evacuate(ap->fun);
2689 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2690 p = (StgPtr)ap->payload + ap->size;
2696 p = scavenge_PAP((StgPAP *)p);
2700 // nothing to follow
2701 p += arr_words_sizeW((StgArrWords *)p);
2705 // follow everything
2709 evac_gen = 0; // repeatedly mutable
2710 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2711 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2712 (StgClosure *)*p = evacuate((StgClosure *)*p);
2714 evac_gen = saved_evac_gen;
2715 recordMutable((StgMutClosure *)q);
2716 failed_to_evac = rtsFalse; // mutable anyhow.
2720 case MUT_ARR_PTRS_FROZEN:
2721 // follow everything
2725 // Set the mut_link field to NULL, so that we will put this
2726 // array back on the mutable list if it is subsequently thawed
2728 ((StgMutArrPtrs*)p)->mut_link = NULL;
2730 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2731 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2732 (StgClosure *)*p = evacuate((StgClosure *)*p);
2734 // it's tempting to recordMutable() if failed_to_evac is
2735 // false, but that breaks some assumptions (eg. every
2736 // closure on the mutable list is supposed to have the MUT
2737 // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2743 StgTSO *tso = (StgTSO *)p;
2746 evac_gen = saved_evac_gen;
2747 recordMutable((StgMutClosure *)tso);
2748 failed_to_evac = rtsFalse; // mutable anyhow.
2749 p += tso_sizeW(tso);
2754 case RBH: // cf. BLACKHOLE_BQ
2757 nat size, ptrs, nonptrs, vhs;
2759 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2761 StgRBH *rbh = (StgRBH *)p;
2762 (StgClosure *)rbh->blocking_queue =
2763 evacuate((StgClosure *)rbh->blocking_queue);
2764 recordMutable((StgMutClosure *)to);
2765 failed_to_evac = rtsFalse; // mutable anyhow.
2767 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2768 p, info_type(p), (StgClosure *)rbh->blocking_queue));
2769 // ToDo: use size of reverted closure here!
2770 p += BLACKHOLE_sizeW();
2776 StgBlockedFetch *bf = (StgBlockedFetch *)p;
2777 // follow the pointer to the node which is being demanded
2778 (StgClosure *)bf->node =
2779 evacuate((StgClosure *)bf->node);
2780 // follow the link to the rest of the blocking queue
2781 (StgClosure *)bf->link =
2782 evacuate((StgClosure *)bf->link);
2783 if (failed_to_evac) {
2784 failed_to_evac = rtsFalse;
2785 recordMutable((StgMutClosure *)bf);
2788 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2789 bf, info_type((StgClosure *)bf),
2790 bf->node, info_type(bf->node)));
2791 p += sizeofW(StgBlockedFetch);
2799 p += sizeofW(StgFetchMe);
2800 break; // nothing to do in this case
2802 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2804 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2805 (StgClosure *)fmbq->blocking_queue =
2806 evacuate((StgClosure *)fmbq->blocking_queue);
2807 if (failed_to_evac) {
2808 failed_to_evac = rtsFalse;
2809 recordMutable((StgMutClosure *)fmbq);
2812 belch("@@ scavenge: %p (%s) exciting, isn't it",
2813 p, info_type((StgClosure *)p)));
2814 p += sizeofW(StgFetchMeBlockingQueue);
2820 barf("scavenge: unimplemented/strange closure type %d @ %p",
2824 /* If we didn't manage to promote all the objects pointed to by
2825 * the current object, then we have to designate this object as
2826 * mutable (because it contains old-to-new generation pointers).
2828 if (failed_to_evac) {
2829 failed_to_evac = rtsFalse;
2830 mkMutCons((StgClosure *)q, &generations[evac_gen]);
2838 /* -----------------------------------------------------------------------------
2839 Scavenge everything on the mark stack.
2841 This is slightly different from scavenge():
2842 - we don't walk linearly through the objects, so the scavenger
2843 doesn't need to advance the pointer on to the next object.
2844 -------------------------------------------------------------------------- */
2847 scavenge_mark_stack(void)
2853 evac_gen = oldest_gen->no;
2854 saved_evac_gen = evac_gen;
2857 while (!mark_stack_empty()) {
2858 p = pop_mark_stack();
2860 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2861 info = get_itbl((StgClosure *)p);
2864 switch (info->type) {
2867 /* treat MVars specially, because we don't want to evacuate the
2868 * mut_link field in the middle of the closure.
2871 StgMVar *mvar = ((StgMVar *)p);
2873 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2874 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2875 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2876 evac_gen = saved_evac_gen;
2877 failed_to_evac = rtsFalse; // mutable.
2882 scavenge_fun_srt(info);
2883 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2884 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2888 scavenge_thunk_srt(info);
2890 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2891 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2896 scavenge_fun_srt(info);
2897 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2902 scavenge_thunk_srt(info);
2905 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2910 scavenge_fun_srt(info);
2915 scavenge_thunk_srt(info);
2923 scavenge_fun_srt(info);
2927 scavenge_thunk_srt(info);
2938 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2939 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2940 (StgClosure *)*p = evacuate((StgClosure *)*p);
2946 StgBCO *bco = (StgBCO *)p;
2947 (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2948 (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2949 (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2950 (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2955 // don't need to do anything here: the only possible case
2956 // is that we're in a 1-space compacting collector, with
2957 // no "old" generation.
2961 case IND_OLDGEN_PERM:
2962 ((StgIndOldGen *)p)->indirectee =
2963 evacuate(((StgIndOldGen *)p)->indirectee);
2964 if (failed_to_evac) {
2965 recordOldToNewPtrs((StgMutClosure *)p);
2967 failed_to_evac = rtsFalse;
2972 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2973 evac_gen = saved_evac_gen;
2974 failed_to_evac = rtsFalse;
2979 failed_to_evac = rtsFalse;
2983 case SE_CAF_BLACKHOLE:
2991 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2992 (StgClosure *)bh->blocking_queue =
2993 evacuate((StgClosure *)bh->blocking_queue);
2994 failed_to_evac = rtsFalse;
2998 case THUNK_SELECTOR:
3000 StgSelector *s = (StgSelector *)p;
3001 s->selectee = evacuate(s->selectee);
3005 // A chunk of stack saved in a heap object
3008 StgAP_STACK *ap = (StgAP_STACK *)p;
3010 ap->fun = evacuate(ap->fun);
3011 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3017 scavenge_PAP((StgPAP *)p);
3021 // follow everything
3025 evac_gen = 0; // repeatedly mutable
3026 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3027 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3028 (StgClosure *)*p = evacuate((StgClosure *)*p);
3030 evac_gen = saved_evac_gen;
3031 failed_to_evac = rtsFalse; // mutable anyhow.
3035 case MUT_ARR_PTRS_FROZEN:
3036 // follow everything
3040 // Set the mut_link field to NULL, so that we will put this
3041 // array on the mutable list if it is subsequently thawed
3043 ((StgMutArrPtrs*)p)->mut_link = NULL;
3045 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3046 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3047 (StgClosure *)*p = evacuate((StgClosure *)*p);
3054 StgTSO *tso = (StgTSO *)p;
3057 evac_gen = saved_evac_gen;
3058 failed_to_evac = rtsFalse;
3063 case RBH: // cf. BLACKHOLE_BQ
3066 nat size, ptrs, nonptrs, vhs;
3068 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3070 StgRBH *rbh = (StgRBH *)p;
3071 (StgClosure *)rbh->blocking_queue =
3072 evacuate((StgClosure *)rbh->blocking_queue);
3073 recordMutable((StgMutClosure *)rbh);
3074 failed_to_evac = rtsFalse; // mutable anyhow.
3076 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3077 p, info_type(p), (StgClosure *)rbh->blocking_queue));
3083 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3084 // follow the pointer to the node which is being demanded
3085 (StgClosure *)bf->node =
3086 evacuate((StgClosure *)bf->node);
3087 // follow the link to the rest of the blocking queue
3088 (StgClosure *)bf->link =
3089 evacuate((StgClosure *)bf->link);
3090 if (failed_to_evac) {
3091 failed_to_evac = rtsFalse;
3092 recordMutable((StgMutClosure *)bf);
3095 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3096 bf, info_type((StgClosure *)bf),
3097 bf->node, info_type(bf->node)));
3105 break; // nothing to do in this case
3107 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3109 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3110 (StgClosure *)fmbq->blocking_queue =
3111 evacuate((StgClosure *)fmbq->blocking_queue);
3112 if (failed_to_evac) {
3113 failed_to_evac = rtsFalse;
3114 recordMutable((StgMutClosure *)fmbq);
3117 belch("@@ scavenge: %p (%s) exciting, isn't it",
3118 p, info_type((StgClosure *)p)));
3124 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3128 if (failed_to_evac) {
3129 failed_to_evac = rtsFalse;
3130 mkMutCons((StgClosure *)q, &generations[evac_gen]);
3133 // mark the next bit to indicate "scavenged"
3134 mark(q+1, Bdescr(q));
3136 } // while (!mark_stack_empty())
3138 // start a new linear scan if the mark stack overflowed at some point
3139 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3140 IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
3141 mark_stack_overflowed = rtsFalse;
3142 oldgen_scan_bd = oldest_gen->steps[0].blocks;
3143 oldgen_scan = oldgen_scan_bd->start;
3146 if (oldgen_scan_bd) {
3147 // push a new thing on the mark stack
3149 // find a closure that is marked but not scavenged, and start
3151 while (oldgen_scan < oldgen_scan_bd->free
3152 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3156 if (oldgen_scan < oldgen_scan_bd->free) {
3158 // already scavenged?
3159 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3160 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3163 push_mark_stack(oldgen_scan);
3164 // ToDo: bump the linear scan by the actual size of the object
3165 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3169 oldgen_scan_bd = oldgen_scan_bd->link;
3170 if (oldgen_scan_bd != NULL) {
3171 oldgen_scan = oldgen_scan_bd->start;
3177 /* -----------------------------------------------------------------------------
3178 Scavenge one object.
3180 This is used for objects that are temporarily marked as mutable
3181 because they contain old-to-new generation pointers. Only certain
3182 objects can have this property.
3183 -------------------------------------------------------------------------- */
3186 scavenge_one(StgPtr p)
3188 const StgInfoTable *info;
3189 nat saved_evac_gen = evac_gen;
3192 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3193 info = get_itbl((StgClosure *)p);
3195 switch (info->type) {
3198 case FUN_1_0: // hardly worth specialising these guys
3218 case IND_OLDGEN_PERM:
3222 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3223 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3224 (StgClosure *)*q = evacuate((StgClosure *)*q);
3230 case SE_CAF_BLACKHOLE:
3235 case THUNK_SELECTOR:
3237 StgSelector *s = (StgSelector *)p;
3238 s->selectee = evacuate(s->selectee);
3243 // nothing to follow
3248 // follow everything
3251 evac_gen = 0; // repeatedly mutable
3252 recordMutable((StgMutClosure *)p);
3253 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3254 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3255 (StgClosure *)*p = evacuate((StgClosure *)*p);
3257 evac_gen = saved_evac_gen;
3258 failed_to_evac = rtsFalse;
3262 case MUT_ARR_PTRS_FROZEN:
3264 // follow everything
3267 // Set the mut_link field to NULL, so that we will put this
3268 // array on the mutable list if it is subsequently thawed
3270 ((StgMutArrPtrs*)p)->mut_link = NULL;
3272 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3273 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3274 (StgClosure *)*p = evacuate((StgClosure *)*p);
3281 StgTSO *tso = (StgTSO *)p;
3283 evac_gen = 0; // repeatedly mutable
3285 recordMutable((StgMutClosure *)tso);
3286 evac_gen = saved_evac_gen;
3287 failed_to_evac = rtsFalse;
3293 StgAP_STACK *ap = (StgAP_STACK *)p;
3295 ap->fun = evacuate(ap->fun);
3296 scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3297 p = (StgPtr)ap->payload + ap->size;
3303 p = scavenge_PAP((StgPAP *)p);
3307 // This might happen if for instance a MUT_CONS was pointing to a
3308 // THUNK which has since been updated. The IND_OLDGEN will
3309 // be on the mutable list anyway, so we don't need to do anything
3314 barf("scavenge_one: strange object %d", (int)(info->type));
3317 no_luck = failed_to_evac;
3318 failed_to_evac = rtsFalse;
3322 /* -----------------------------------------------------------------------------
3323 Scavenging mutable lists.
3325 We treat the mutable list of each generation > N (i.e. all the
3326 generations older than the one being collected) as roots. We also
3327 remove non-mutable objects from the mutable list at this point.
3328 -------------------------------------------------------------------------- */
3331 scavenge_mut_once_list(generation *gen)
3333 const StgInfoTable *info;
3334 StgMutClosure *p, *next, *new_list;
3336 p = gen->mut_once_list;
3337 new_list = END_MUT_LIST;
3341 failed_to_evac = rtsFalse;
3343 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3345 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3348 if (info->type==RBH)
3349 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3351 switch(info->type) {
3354 case IND_OLDGEN_PERM:
3356 /* Try to pull the indirectee into this generation, so we can
3357 * remove the indirection from the mutable list.
3359 ((StgIndOldGen *)p)->indirectee =
3360 evacuate(((StgIndOldGen *)p)->indirectee);
3362 #if 0 && defined(DEBUG)
3363 if (RtsFlags.DebugFlags.gc)
3364 /* Debugging code to print out the size of the thing we just
3368 StgPtr start = gen->steps[0].scan;
3369 bdescr *start_bd = gen->steps[0].scan_bd;
3371 scavenge(&gen->steps[0]);
3372 if (start_bd != gen->steps[0].scan_bd) {
3373 size += (P_)BLOCK_ROUND_UP(start) - start;
3374 start_bd = start_bd->link;
3375 while (start_bd != gen->steps[0].scan_bd) {
3376 size += BLOCK_SIZE_W;
3377 start_bd = start_bd->link;
3379 size += gen->steps[0].scan -
3380 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3382 size = gen->steps[0].scan - start;
3384 belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3388 /* failed_to_evac might happen if we've got more than two
3389 * generations, we're collecting only generation 0, the
3390 * indirection resides in generation 2 and the indirectee is
3393 if (failed_to_evac) {
3394 failed_to_evac = rtsFalse;
3395 p->mut_link = new_list;
3398 /* the mut_link field of an IND_STATIC is overloaded as the
3399 * static link field too (it just so happens that we don't need
3400 * both at the same time), so we need to NULL it out when
3401 * removing this object from the mutable list because the static
3402 * link fields are all assumed to be NULL before doing a major
3410 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3411 * it from the mutable list if possible by promoting whatever it
3414 if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3415 /* didn't manage to promote everything, so put the
3416 * MUT_CONS back on the list.
3418 p->mut_link = new_list;
3424 // shouldn't have anything else on the mutables list
3425 barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3429 gen->mut_once_list = new_list;
3434 scavenge_mutable_list(generation *gen)
3436 const StgInfoTable *info;
3437 StgMutClosure *p, *next;
3439 p = gen->saved_mut_list;
3443 failed_to_evac = rtsFalse;
3445 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3447 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3450 if (info->type==RBH)
3451 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3453 switch(info->type) {
3456 // follow everything
3457 p->mut_link = gen->mut_list;
3462 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3463 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3464 (StgClosure *)*q = evacuate((StgClosure *)*q);
3469 // Happens if a MUT_ARR_PTRS in the old generation is frozen
3470 case MUT_ARR_PTRS_FROZEN:
3475 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3476 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3477 (StgClosure *)*q = evacuate((StgClosure *)*q);
3480 // Set the mut_link field to NULL, so that we will put this
3481 // array back on the mutable list if it is subsequently thawed
3484 if (failed_to_evac) {
3485 failed_to_evac = rtsFalse;
3486 mkMutCons((StgClosure *)p, gen);
3492 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3493 p->mut_link = gen->mut_list;
3499 StgMVar *mvar = (StgMVar *)p;
3500 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3501 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3502 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3503 p->mut_link = gen->mut_list;
3510 StgTSO *tso = (StgTSO *)p;
3514 /* Don't take this TSO off the mutable list - it might still
3515 * point to some younger objects (because we set evac_gen to 0
3518 tso->mut_link = gen->mut_list;
3519 gen->mut_list = (StgMutClosure *)tso;
3525 StgBlockingQueue *bh = (StgBlockingQueue *)p;
3526 (StgClosure *)bh->blocking_queue =
3527 evacuate((StgClosure *)bh->blocking_queue);
3528 p->mut_link = gen->mut_list;
3533 /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3536 case IND_OLDGEN_PERM:
3537 /* Try to pull the indirectee into this generation, so we can
3538 * remove the indirection from the mutable list.
3541 ((StgIndOldGen *)p)->indirectee =
3542 evacuate(((StgIndOldGen *)p)->indirectee);
3545 if (failed_to_evac) {
3546 failed_to_evac = rtsFalse;
3547 p->mut_link = gen->mut_once_list;
3548 gen->mut_once_list = p;
3555 // HWL: check whether all of these are necessary
3557 case RBH: // cf. BLACKHOLE_BQ
3559 // nat size, ptrs, nonptrs, vhs;
3561 // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3562 StgRBH *rbh = (StgRBH *)p;
3563 (StgClosure *)rbh->blocking_queue =
3564 evacuate((StgClosure *)rbh->blocking_queue);
3565 if (failed_to_evac) {
3566 failed_to_evac = rtsFalse;
3567 recordMutable((StgMutClosure *)rbh);
3569 // ToDo: use size of reverted closure here!
3570 p += BLACKHOLE_sizeW();
3576 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3577 // follow the pointer to the node which is being demanded
3578 (StgClosure *)bf->node =
3579 evacuate((StgClosure *)bf->node);
3580 // follow the link to the rest of the blocking queue
3581 (StgClosure *)bf->link =
3582 evacuate((StgClosure *)bf->link);
3583 if (failed_to_evac) {
3584 failed_to_evac = rtsFalse;
3585 recordMutable((StgMutClosure *)bf);
3587 p += sizeofW(StgBlockedFetch);
3593 barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3596 p += sizeofW(StgFetchMe);
3597 break; // nothing to do in this case
3599 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3601 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3602 (StgClosure *)fmbq->blocking_queue =
3603 evacuate((StgClosure *)fmbq->blocking_queue);
3604 if (failed_to_evac) {
3605 failed_to_evac = rtsFalse;
3606 recordMutable((StgMutClosure *)fmbq);
3608 p += sizeofW(StgFetchMeBlockingQueue);
3614 // shouldn't have anything else on the mutables list
3615 barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3622 scavenge_static(void)
3624 StgClosure* p = static_objects;
3625 const StgInfoTable *info;
3627 /* Always evacuate straight to the oldest generation for static
3629 evac_gen = oldest_gen->no;
3631 /* keep going until we've scavenged all the objects on the linked
3633 while (p != END_OF_STATIC_LIST) {
3635 ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3638 if (info->type==RBH)
3639 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3641 // make sure the info pointer is into text space
3643 /* Take this object *off* the static_objects list,
3644 * and put it on the scavenged_static_objects list.
3646 static_objects = STATIC_LINK(info,p);
3647 STATIC_LINK(info,p) = scavenged_static_objects;
3648 scavenged_static_objects = p;
3650 switch (info -> type) {
3654 StgInd *ind = (StgInd *)p;
3655 ind->indirectee = evacuate(ind->indirectee);
3657 /* might fail to evacuate it, in which case we have to pop it
3658 * back on the mutable list (and take it off the
3659 * scavenged_static list because the static link and mut link
3660 * pointers are one and the same).
3662 if (failed_to_evac) {
3663 failed_to_evac = rtsFalse;
3664 scavenged_static_objects = IND_STATIC_LINK(p);
3665 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3666 oldest_gen->mut_once_list = (StgMutClosure *)ind;
3672 scavenge_thunk_srt(info);
3676 scavenge_fun_srt(info);
3683 next = (P_)p->payload + info->layout.payload.ptrs;
3684 // evacuate the pointers
3685 for (q = (P_)p->payload; q < next; q++) {
3686 (StgClosure *)*q = evacuate((StgClosure *)*q);
3692 barf("scavenge_static: strange closure %d", (int)(info->type));
3695 ASSERT(failed_to_evac == rtsFalse);
3697 /* get the next static object from the list. Remember, there might
3698 * be more stuff on this list now that we've done some evacuating!
3699 * (static_objects is a global)
3705 /* -----------------------------------------------------------------------------
3706 scavenge a chunk of memory described by a bitmap
3707 -------------------------------------------------------------------------- */
3710 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
3716 bitmap = large_bitmap->bitmap[b];
3717 for (i = 0; i < size; ) {
3718 if ((bitmap & 1) == 0) {
3719 (StgClosure *)*p = evacuate((StgClosure *)*p);
3723 if (i % BITS_IN(W_) == 0) {
3725 bitmap = large_bitmap->bitmap[b];
3727 bitmap = bitmap >> 1;
3732 STATIC_INLINE StgPtr
3733 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
3736 if ((bitmap & 1) == 0) {
3737 (StgClosure *)*p = evacuate((StgClosure *)*p);
3740 bitmap = bitmap >> 1;
3746 /* -----------------------------------------------------------------------------
3747 scavenge_stack walks over a section of stack and evacuates all the
3748 objects pointed to by it. We can use the same code for walking
3749 AP_STACK_UPDs, since these are just sections of copied stack.
3750 -------------------------------------------------------------------------- */
3754 scavenge_stack(StgPtr p, StgPtr stack_end)
3756 const StgRetInfoTable* info;
3760 //IF_DEBUG(sanity, belch(" scavenging stack between %p and %p", p, stack_end));
3763 * Each time around this loop, we are looking at a chunk of stack
3764 * that starts with an activation record.
3767 while (p < stack_end) {
3768 info = get_ret_itbl((StgClosure *)p);
3770 switch (info->i.type) {
3773 ((StgUpdateFrame *)p)->updatee
3774 = evacuate(((StgUpdateFrame *)p)->updatee);
3775 p += sizeofW(StgUpdateFrame);
3778 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3783 bitmap = BITMAP_BITS(info->i.layout.bitmap);
3784 size = BITMAP_SIZE(info->i.layout.bitmap);
3785 // NOTE: the payload starts immediately after the info-ptr, we
3786 // don't have an StgHeader in the same sense as a heap closure.
3788 p = scavenge_small_bitmap(p, size, bitmap);
3791 scavenge_srt((StgClosure **)info->srt, info->i.srt_bitmap);
3799 (StgClosure *)*p = evacuate((StgClosure *)*p);
3802 size = BCO_BITMAP_SIZE(bco);
3803 scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
3808 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3814 size = info->i.layout.large_bitmap->size;
3816 scavenge_large_bitmap(p, info->i.layout.large_bitmap, size);
3818 // and don't forget to follow the SRT
3822 // Dynamic bitmap: the mask is stored on the stack, and
3823 // there are a number of non-pointers followed by a number
3824 // of pointers above the bitmapped area. (see StgMacros.h,
3829 dyn = ((StgRetDyn *)p)->liveness;
3831 // traverse the bitmap first
3832 bitmap = GET_LIVENESS(dyn);
3833 p = (P_)&((StgRetDyn *)p)->payload[0];
3834 size = RET_DYN_BITMAP_SIZE;
3835 p = scavenge_small_bitmap(p, size, bitmap);
3837 // skip over the non-ptr words
3838 p += GET_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
3840 // follow the ptr words
3841 for (size = GET_PTRS(dyn); size > 0; size--) {
3842 (StgClosure *)*p = evacuate((StgClosure *)*p);
3850 StgRetFun *ret_fun = (StgRetFun *)p;
3851 StgFunInfoTable *fun_info;
3853 ret_fun->fun = evacuate(ret_fun->fun);
3854 fun_info = get_fun_itbl(ret_fun->fun);
3855 p = scavenge_arg_block(fun_info, ret_fun->payload);
3860 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
3865 /*-----------------------------------------------------------------------------
3866 scavenge the large object list.
3868 evac_gen set by caller; similar games played with evac_gen as with
3869 scavenge() - see comment at the top of scavenge(). Most large
3870 objects are (repeatedly) mutable, so most of the time evac_gen will
3872 --------------------------------------------------------------------------- */
3875 scavenge_large(step *stp)
3880 bd = stp->new_large_objects;
3882 for (; bd != NULL; bd = stp->new_large_objects) {
3884 /* take this object *off* the large objects list and put it on
3885 * the scavenged large objects list. This is so that we can
3886 * treat new_large_objects as a stack and push new objects on
3887 * the front when evacuating.
3889 stp->new_large_objects = bd->link;
3890 dbl_link_onto(bd, &stp->scavenged_large_objects);
3892 // update the block count in this step.
3893 stp->n_scavenged_large_blocks += bd->blocks;
3896 if (scavenge_one(p)) {
3897 mkMutCons((StgClosure *)p, stp->gen);
3902 /* -----------------------------------------------------------------------------
3903 Initialising the static object & mutable lists
3904 -------------------------------------------------------------------------- */
3907 zero_static_object_list(StgClosure* first_static)
3911 const StgInfoTable *info;
3913 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3915 link = STATIC_LINK(info, p);
3916 STATIC_LINK(info,p) = NULL;
3920 /* This function is only needed because we share the mutable link
3921 * field with the static link field in an IND_STATIC, so we have to
3922 * zero the mut_link field before doing a major GC, which needs the
3923 * static link field.
3925 * It doesn't do any harm to zero all the mutable link fields on the
3930 zero_mutable_list( StgMutClosure *first )
3932 StgMutClosure *next, *c;
3934 for (c = first; c != END_MUT_LIST; c = next) {
3940 /* -----------------------------------------------------------------------------
3942 -------------------------------------------------------------------------- */
3949 for (c = (StgIndStatic *)caf_list; c != NULL;
3950 c = (StgIndStatic *)c->static_link)
3952 c->header.info = c->saved_info;
3953 c->saved_info = NULL;
3954 // could, but not necessary: c->static_link = NULL;
3960 markCAFs( evac_fn evac )
3964 for (c = (StgIndStatic *)caf_list; c != NULL;
3965 c = (StgIndStatic *)c->static_link)
3967 evac(&c->indirectee);
3971 /* -----------------------------------------------------------------------------
3972 Sanity code for CAF garbage collection.
3974 With DEBUG turned on, we manage a CAF list in addition to the SRT
3975 mechanism. After GC, we run down the CAF list and blackhole any
3976 CAFs which have been garbage collected. This means we get an error
3977 whenever the program tries to enter a garbage collected CAF.
3979 Any garbage collected CAFs are taken off the CAF list at the same
3981 -------------------------------------------------------------------------- */
3983 #if 0 && defined(DEBUG)
3990 const StgInfoTable *info;
4001 ASSERT(info->type == IND_STATIC);
4003 if (STATIC_LINK(info,p) == NULL) {
4004 IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
4006 SET_INFO(p,&stg_BLACKHOLE_info);
4007 p = STATIC_LINK2(info,p);
4011 pp = &STATIC_LINK2(info,p);
4018 // belch("%d CAFs live", i);
4023 /* -----------------------------------------------------------------------------
4026 Whenever a thread returns to the scheduler after possibly doing
4027 some work, we have to run down the stack and black-hole all the
4028 closures referred to by update frames.
4029 -------------------------------------------------------------------------- */
4032 threadLazyBlackHole(StgTSO *tso)
4035 StgRetInfoTable *info;
4036 StgBlockingQueue *bh;
4039 stack_end = &tso->stack[tso->stack_size];
4041 frame = (StgClosure *)tso->sp;
4044 info = get_ret_itbl(frame);
4046 switch (info->i.type) {
4049 bh = (StgBlockingQueue *)((StgUpdateFrame *)frame)->updatee;
4051 /* if the thunk is already blackholed, it means we've also
4052 * already blackholed the rest of the thunks on this stack,
4053 * so we can stop early.
4055 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
4056 * don't interfere with this optimisation.
4058 if (bh->header.info == &stg_BLACKHOLE_info) {
4062 if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
4063 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4064 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4065 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4069 // We pretend that bh is now dead.
4070 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4072 SET_INFO(bh,&stg_BLACKHOLE_info);
4075 // We pretend that bh has just been created.
4076 LDV_recordCreate(bh);
4080 frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4086 // normal stack frames; do nothing except advance the pointer
4088 (StgPtr)frame += stack_frame_sizeW(frame);
4094 /* -----------------------------------------------------------------------------
4097 * Code largely pinched from old RTS, then hacked to bits. We also do
4098 * lazy black holing here.
4100 * -------------------------------------------------------------------------- */
4102 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4105 threadSqueezeStack(StgTSO *tso)
4108 rtsBool prev_was_update_frame;
4109 StgClosure *updatee = NULL;
4111 StgRetInfoTable *info;
4112 StgWord current_gap_size;
4113 struct stack_gap *gap;
4116 // Traverse the stack upwards, replacing adjacent update frames
4117 // with a single update frame and a "stack gap". A stack gap
4118 // contains two values: the size of the gap, and the distance
4119 // to the next gap (or the stack top).
4121 bottom = &(tso->stack[tso->stack_size]);
4125 ASSERT(frame < bottom);
4127 prev_was_update_frame = rtsFalse;
4128 current_gap_size = 0;
4129 gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4131 while (frame < bottom) {
4133 info = get_ret_itbl((StgClosure *)frame);
4134 switch (info->i.type) {
4138 StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4140 if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
4142 // found a BLACKHOLE'd update frame; we've been here
4143 // before, in a previous GC, so just break out.
4145 // Mark the end of the gap, if we're in one.
4146 if (current_gap_size != 0) {
4147 gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
4150 frame += sizeofW(StgUpdateFrame);
4151 goto done_traversing;
4154 if (prev_was_update_frame) {
4156 TICK_UPD_SQUEEZED();
4157 /* wasn't there something about update squeezing and ticky to be
4158 * sorted out? oh yes: we aren't counting each enter properly
4159 * in this case. See the log somewhere. KSW 1999-04-21
4161 * Check two things: that the two update frames don't point to
4162 * the same object, and that the updatee_bypass isn't already an
4163 * indirection. Both of these cases only happen when we're in a
4164 * block hole-style loop (and there are multiple update frames
4165 * on the stack pointing to the same closure), but they can both
4166 * screw us up if we don't check.
4168 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4169 // this wakes the threads up
4170 UPD_IND_NOLOCK(upd->updatee, updatee);
4173 // now mark this update frame as a stack gap. The gap
4174 // marker resides in the bottom-most update frame of
4175 // the series of adjacent frames, and covers all the
4176 // frames in this series.
4177 current_gap_size += sizeofW(StgUpdateFrame);
4178 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4179 ((struct stack_gap *)frame)->next_gap = gap;
4181 frame += sizeofW(StgUpdateFrame);
4185 // single update frame, or the topmost update frame in a series
4187 StgBlockingQueue *bh = (StgBlockingQueue *)upd->updatee;
4189 // Do lazy black-holing
4190 if (bh->header.info != &stg_BLACKHOLE_info &&
4191 bh->header.info != &stg_BLACKHOLE_BQ_info &&
4192 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4193 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4194 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4197 /* zero out the slop so that the sanity checker can tell
4198 * where the next closure is.
4201 StgInfoTable *bh_info = get_itbl(bh);
4202 nat np = bh_info->layout.payload.ptrs,
4203 nw = bh_info->layout.payload.nptrs, i;
4204 /* don't zero out slop for a THUNK_SELECTOR,
4205 * because its layout info is used for a
4206 * different purpose, and it's exactly the
4207 * same size as a BLACKHOLE in any case.
4209 if (bh_info->type != THUNK_SELECTOR) {
4210 for (i = np; i < np + nw; i++) {
4211 ((StgClosure *)bh)->payload[i] = 0;
4217 // We pretend that bh is now dead.
4218 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4220 // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
4221 SET_INFO(bh,&stg_BLACKHOLE_info);
4223 // We pretend that bh has just been created.
4224 LDV_recordCreate(bh);
4228 prev_was_update_frame = rtsTrue;
4229 updatee = upd->updatee;
4230 frame += sizeofW(StgUpdateFrame);
4236 prev_was_update_frame = rtsFalse;
4238 // we're not in a gap... check whether this is the end of a gap
4239 // (an update frame can't be the end of a gap).
4240 if (current_gap_size != 0) {
4241 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4243 current_gap_size = 0;
4245 frame += stack_frame_sizeW((StgClosure *)frame);
4252 // Now we have a stack with gaps in it, and we have to walk down
4253 // shoving the stack up to fill in the gaps. A diagram might
4257 // | ********* | <- sp
4261 // | stack_gap | <- gap | chunk_size
4263 // | ......... | <- gap_end v
4269 // 'sp' points the the current top-of-stack
4270 // 'gap' points to the stack_gap structure inside the gap
4271 // ***** indicates real stack data
4272 // ..... indicates gap
4273 // <empty> indicates unused
4277 void *gap_start, *next_gap_start, *gap_end;
4280 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4281 sp = next_gap_start;
4283 while ((StgPtr)gap > tso->sp) {
4285 // we're working in *bytes* now...
4286 gap_start = next_gap_start;
4287 gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4289 gap = gap->next_gap;
4290 next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4292 chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4293 (unsigned char*)sp -= chunk_size;
4294 memmove(sp, next_gap_start, chunk_size);
4297 tso->sp = (StgPtr)sp;
4301 /* -----------------------------------------------------------------------------
4304 * We have to prepare for GC - this means doing lazy black holing
4305 * here. We also take the opportunity to do stack squeezing if it's
4307 * -------------------------------------------------------------------------- */
4309 threadPaused(StgTSO *tso)
4311 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4312 threadSqueezeStack(tso); // does black holing too
4314 threadLazyBlackHole(tso);
4317 /* -----------------------------------------------------------------------------
4319 * -------------------------------------------------------------------------- */
4323 printMutOnceList(generation *gen)
4325 StgMutClosure *p, *next;
4327 p = gen->mut_once_list;
4330 fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4331 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4332 fprintf(stderr, "%p (%s), ",
4333 p, info_type((StgClosure *)p));
4335 fputc('\n', stderr);
4339 printMutableList(generation *gen)
4341 StgMutClosure *p, *next;
4346 fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4347 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4348 fprintf(stderr, "%p (%s), ",
4349 p, info_type((StgClosure *)p));
4351 fputc('\n', stderr);
4354 STATIC_INLINE rtsBool
4355 maybeLarge(StgClosure *closure)
4357 StgInfoTable *info = get_itbl(closure);
4359 /* closure types that may be found on the new_large_objects list;
4360 see scavenge_large */
4361 return (info->type == MUT_ARR_PTRS ||
4362 info->type == MUT_ARR_PTRS_FROZEN ||
4363 info->type == TSO ||
4364 info->type == ARR_WORDS);