1 /* -----------------------------------------------------------------------------
2 * $Id: GC.c,v 1.145 2002/10/25 09:40:47 simonmar Exp $
4 * (c) The GHC Team 1998-1999
6 * Generational garbage collector
8 * ---------------------------------------------------------------------------*/
10 #include "PosixSource.h"
15 #include "StoragePriv.h"
18 #include "SchedAPI.h" // for ReverCAFs prototype
20 #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 void mark_root ( StgClosure **root );
141 static StgClosure * evacuate ( StgClosure *q );
142 static void zero_static_object_list ( StgClosure* first_static );
143 static void zero_mutable_list ( StgMutClosure *first );
145 static rtsBool traverse_weak_ptr_list ( void );
146 static void mark_weak_ptr_list ( StgWeak **list );
148 static StgClosure * eval_thunk_selector ( nat field, StgSelector * p );
150 static void scavenge ( step * );
151 static void scavenge_mark_stack ( void );
152 static void scavenge_stack ( StgPtr p, StgPtr stack_end );
153 static rtsBool scavenge_one ( StgPtr p );
154 static void scavenge_large ( step * );
155 static void scavenge_static ( void );
156 static void scavenge_mutable_list ( generation *g );
157 static void scavenge_mut_once_list ( generation *g );
159 #if 0 && defined(DEBUG)
160 static void gcCAFs ( void );
163 /* -----------------------------------------------------------------------------
164 inline functions etc. for dealing with the mark bitmap & stack.
165 -------------------------------------------------------------------------- */
167 #define MARK_STACK_BLOCKS 4
169 static bdescr *mark_stack_bdescr;
170 static StgPtr *mark_stack;
171 static StgPtr *mark_sp;
172 static StgPtr *mark_splim;
174 // Flag and pointers used for falling back to a linear scan when the
175 // mark stack overflows.
176 static rtsBool mark_stack_overflowed;
177 static bdescr *oldgen_scan_bd;
178 static StgPtr oldgen_scan;
180 static inline rtsBool
181 mark_stack_empty(void)
183 return mark_sp == mark_stack;
186 static inline rtsBool
187 mark_stack_full(void)
189 return mark_sp >= mark_splim;
193 reset_mark_stack(void)
195 mark_sp = mark_stack;
199 push_mark_stack(StgPtr p)
210 /* -----------------------------------------------------------------------------
213 For garbage collecting generation N (and all younger generations):
215 - follow all pointers in the root set. the root set includes all
216 mutable objects in all steps in all generations.
218 - for each pointer, evacuate the object it points to into either
219 + to-space in the next higher step in that generation, if one exists,
220 + if the object's generation == N, then evacuate it to the next
221 generation if one exists, or else to-space in the current
223 + if the object's generation < N, then evacuate it to to-space
224 in the next generation.
226 - repeatedly scavenge to-space from each step in each generation
227 being collected until no more objects can be evacuated.
229 - free from-space in each step, and set from-space = to-space.
231 Locks held: sched_mutex
233 -------------------------------------------------------------------------- */
236 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
240 lnat live, allocated, collected = 0, copied = 0;
241 lnat oldgen_saved_blocks = 0;
245 CostCentreStack *prev_CCS;
248 #if defined(DEBUG) && defined(GRAN)
249 IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n",
253 #ifndef mingw32_TARGET_OS
258 // tell the stats department that we've started a GC
261 // Init stats and print par specific (timing) info
262 PAR_TICKY_PAR_START();
264 // attribute any costs to CCS_GC
270 /* Approximate how much we allocated.
271 * Todo: only when generating stats?
273 allocated = calcAllocated();
275 /* Figure out which generation to collect
277 if (force_major_gc) {
278 N = RtsFlags.GcFlags.generations - 1;
282 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
283 if (generations[g].steps[0].n_blocks +
284 generations[g].steps[0].n_large_blocks
285 >= generations[g].max_blocks) {
289 major_gc = (N == RtsFlags.GcFlags.generations-1);
292 #ifdef RTS_GTK_FRONTPANEL
293 if (RtsFlags.GcFlags.frontpanel) {
294 updateFrontPanelBeforeGC(N);
298 // check stack sanity *before* GC (ToDo: check all threads)
300 // ToDo!: check sanity IF_DEBUG(sanity, checkTSOsSanity());
302 IF_DEBUG(sanity, checkFreeListSanity());
304 /* Initialise the static object lists
306 static_objects = END_OF_STATIC_LIST;
307 scavenged_static_objects = END_OF_STATIC_LIST;
309 /* zero the mutable list for the oldest generation (see comment by
310 * zero_mutable_list below).
313 zero_mutable_list(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
316 /* Save the old to-space if we're doing a two-space collection
318 if (RtsFlags.GcFlags.generations == 1) {
319 old_to_blocks = g0s0->to_blocks;
320 g0s0->to_blocks = NULL;
323 /* Keep a count of how many new blocks we allocated during this GC
324 * (used for resizing the allocation area, later).
328 /* Initialise to-space in all the generations/steps that we're
331 for (g = 0; g <= N; g++) {
332 generations[g].mut_once_list = END_MUT_LIST;
333 generations[g].mut_list = END_MUT_LIST;
335 for (s = 0; s < generations[g].n_steps; s++) {
337 // generation 0, step 0 doesn't need to-space
338 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
342 /* Get a free block for to-space. Extra blocks will be chained on
346 stp = &generations[g].steps[s];
347 ASSERT(stp->gen_no == g);
348 ASSERT(stp->hp ? Bdescr(stp->hp)->step == stp : rtsTrue);
352 bd->flags = BF_EVACUATED; // it's a to-space block
354 stp->hpLim = stp->hp + BLOCK_SIZE_W;
357 stp->n_to_blocks = 1;
358 stp->scan = bd->start;
360 stp->new_large_objects = NULL;
361 stp->scavenged_large_objects = NULL;
362 stp->n_scavenged_large_blocks = 0;
364 // mark the large objects as not evacuated yet
365 for (bd = stp->large_objects; bd; bd = bd->link) {
366 bd->flags = BF_LARGE;
369 // for a compacted step, we need to allocate the bitmap
370 if (stp->is_compacted) {
371 nat bitmap_size; // in bytes
372 bdescr *bitmap_bdescr;
375 bitmap_size = stp->n_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
377 if (bitmap_size > 0) {
378 bitmap_bdescr = allocGroup((nat)BLOCK_ROUND_UP(bitmap_size)
380 stp->bitmap = bitmap_bdescr;
381 bitmap = bitmap_bdescr->start;
383 IF_DEBUG(gc, belch("bitmap_size: %d, bitmap: %p",
384 bitmap_size, bitmap););
386 // don't forget to fill it with zeros!
387 memset(bitmap, 0, bitmap_size);
389 // for each block in this step, point to its bitmap from the
391 for (bd=stp->blocks; bd != NULL; bd = bd->link) {
392 bd->u.bitmap = bitmap;
393 bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
400 /* make sure the older generations have at least one block to
401 * allocate into (this makes things easier for copy(), see below.
403 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
404 for (s = 0; s < generations[g].n_steps; s++) {
405 stp = &generations[g].steps[s];
406 if (stp->hp_bd == NULL) {
407 ASSERT(stp->blocks == NULL);
412 bd->flags = 0; // *not* a to-space block or a large object
414 stp->hpLim = stp->hp + BLOCK_SIZE_W;
420 /* Set the scan pointer for older generations: remember we
421 * still have to scavenge objects that have been promoted. */
423 stp->scan_bd = stp->hp_bd;
424 stp->to_blocks = NULL;
425 stp->n_to_blocks = 0;
426 stp->new_large_objects = NULL;
427 stp->scavenged_large_objects = NULL;
428 stp->n_scavenged_large_blocks = 0;
432 /* Allocate a mark stack if we're doing a major collection.
435 mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
436 mark_stack = (StgPtr *)mark_stack_bdescr->start;
437 mark_sp = mark_stack;
438 mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
440 mark_stack_bdescr = NULL;
443 /* -----------------------------------------------------------------------
444 * follow all the roots that we know about:
445 * - mutable lists from each generation > N
446 * we want to *scavenge* these roots, not evacuate them: they're not
447 * going to move in this GC.
448 * Also: do them in reverse generation order. This is because we
449 * often want to promote objects that are pointed to by older
450 * generations early, so we don't have to repeatedly copy them.
451 * Doing the generations in reverse order ensures that we don't end
452 * up in the situation where we want to evac an object to gen 3 and
453 * it has already been evaced to gen 2.
457 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
458 generations[g].saved_mut_list = generations[g].mut_list;
459 generations[g].mut_list = END_MUT_LIST;
462 // Do the mut-once lists first
463 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
464 IF_PAR_DEBUG(verbose,
465 printMutOnceList(&generations[g]));
466 scavenge_mut_once_list(&generations[g]);
468 for (st = generations[g].n_steps-1; st >= 0; st--) {
469 scavenge(&generations[g].steps[st]);
473 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
474 IF_PAR_DEBUG(verbose,
475 printMutableList(&generations[g]));
476 scavenge_mutable_list(&generations[g]);
478 for (st = generations[g].n_steps-1; st >= 0; st--) {
479 scavenge(&generations[g].steps[st]);
484 /* follow roots from the CAF list (used by GHCi)
489 /* follow all the roots that the application knows about.
492 get_roots(mark_root);
495 /* And don't forget to mark the TSO if we got here direct from
497 /* Not needed in a seq version?
499 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
503 // Mark the entries in the GALA table of the parallel system
504 markLocalGAs(major_gc);
505 // Mark all entries on the list of pending fetches
506 markPendingFetches(major_gc);
509 /* Mark the weak pointer list, and prepare to detect dead weak
512 mark_weak_ptr_list(&weak_ptr_list);
513 old_weak_ptr_list = weak_ptr_list;
514 weak_ptr_list = NULL;
515 weak_stage = WeakPtrs;
517 /* The all_threads list is like the weak_ptr_list.
518 * See traverse_weak_ptr_list() for the details.
520 old_all_threads = all_threads;
521 all_threads = END_TSO_QUEUE;
522 resurrected_threads = END_TSO_QUEUE;
524 /* Mark the stable pointer table.
526 markStablePtrTable(mark_root);
530 /* ToDo: To fix the caf leak, we need to make the commented out
531 * parts of this code do something sensible - as described in
534 extern void markHugsObjects(void);
539 /* -------------------------------------------------------------------------
540 * Repeatedly scavenge all the areas we know about until there's no
541 * more scavenging to be done.
548 // scavenge static objects
549 if (major_gc && static_objects != END_OF_STATIC_LIST) {
550 IF_DEBUG(sanity, checkStaticObjects(static_objects));
554 /* When scavenging the older generations: Objects may have been
555 * evacuated from generations <= N into older generations, and we
556 * need to scavenge these objects. We're going to try to ensure that
557 * any evacuations that occur move the objects into at least the
558 * same generation as the object being scavenged, otherwise we
559 * have to create new entries on the mutable list for the older
563 // scavenge each step in generations 0..maxgen
569 // scavenge objects in compacted generation
570 if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
571 (mark_stack_bdescr != NULL && !mark_stack_empty())) {
572 scavenge_mark_stack();
576 for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
577 for (st = generations[gen].n_steps; --st >= 0; ) {
578 if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
581 stp = &generations[gen].steps[st];
583 if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
588 if (stp->new_large_objects != NULL) {
597 if (flag) { goto loop; }
599 // must be last... invariant is that everything is fully
600 // scavenged at this point.
601 if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something
606 /* Update the pointers from the "main thread" list - these are
607 * treated as weak pointers because we want to allow a main thread
608 * to get a BlockedOnDeadMVar exception in the same way as any other
609 * thread. Note that the threads should all have been retained by
610 * GC by virtue of being on the all_threads list, we're just
611 * updating pointers here.
616 for (m = main_threads; m != NULL; m = m->link) {
617 tso = (StgTSO *) isAlive((StgClosure *)m->tso);
619 barf("main thread has been GC'd");
626 // Reconstruct the Global Address tables used in GUM
627 rebuildGAtables(major_gc);
628 IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
631 // Now see which stable names are still alive.
634 // Tidy the end of the to-space chains
635 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
636 for (s = 0; s < generations[g].n_steps; s++) {
637 stp = &generations[g].steps[s];
638 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
639 stp->hp_bd->free = stp->hp;
640 stp->hp_bd->link = NULL;
646 // We call processHeapClosureForDead() on every closure destroyed during
647 // the current garbage collection, so we invoke LdvCensusForDead().
648 if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
649 || RtsFlags.ProfFlags.bioSelector != NULL)
653 // NO MORE EVACUATION AFTER THIS POINT!
654 // Finally: compaction of the oldest generation.
655 if (major_gc && oldest_gen->steps[0].is_compacted) {
656 // save number of blocks for stats
657 oldgen_saved_blocks = oldest_gen->steps[0].n_blocks;
661 IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
663 /* run through all the generations/steps and tidy up
665 copied = new_blocks * BLOCK_SIZE_W;
666 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
669 generations[g].collections++; // for stats
672 for (s = 0; s < generations[g].n_steps; s++) {
674 stp = &generations[g].steps[s];
676 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
677 // stats information: how much we copied
679 copied -= stp->hp_bd->start + BLOCK_SIZE_W -
684 // for generations we collected...
687 // rough calculation of garbage collected, for stats output
688 if (stp->is_compacted) {
689 collected += (oldgen_saved_blocks - stp->n_blocks) * BLOCK_SIZE_W;
691 collected += stp->n_blocks * BLOCK_SIZE_W;
694 /* free old memory and shift to-space into from-space for all
695 * the collected steps (except the allocation area). These
696 * freed blocks will probaby be quickly recycled.
698 if (!(g == 0 && s == 0)) {
699 if (stp->is_compacted) {
700 // for a compacted step, just shift the new to-space
701 // onto the front of the now-compacted existing blocks.
702 for (bd = stp->to_blocks; bd != NULL; bd = bd->link) {
703 bd->flags &= ~BF_EVACUATED; // now from-space
705 // tack the new blocks on the end of the existing blocks
706 if (stp->blocks == NULL) {
707 stp->blocks = stp->to_blocks;
709 for (bd = stp->blocks; bd != NULL; bd = next) {
712 bd->link = stp->to_blocks;
716 // add the new blocks to the block tally
717 stp->n_blocks += stp->n_to_blocks;
719 freeChain(stp->blocks);
720 stp->blocks = stp->to_blocks;
721 stp->n_blocks = stp->n_to_blocks;
722 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
723 bd->flags &= ~BF_EVACUATED; // now from-space
726 stp->to_blocks = NULL;
727 stp->n_to_blocks = 0;
730 /* LARGE OBJECTS. The current live large objects are chained on
731 * scavenged_large, having been moved during garbage
732 * collection from large_objects. Any objects left on
733 * large_objects list are therefore dead, so we free them here.
735 for (bd = stp->large_objects; bd != NULL; bd = next) {
741 // update the count of blocks used by large objects
742 for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
743 bd->flags &= ~BF_EVACUATED;
745 stp->large_objects = stp->scavenged_large_objects;
746 stp->n_large_blocks = stp->n_scavenged_large_blocks;
749 // for older generations...
751 /* For older generations, we need to append the
752 * scavenged_large_object list (i.e. large objects that have been
753 * promoted during this GC) to the large_object list for that step.
755 for (bd = stp->scavenged_large_objects; bd; bd = next) {
757 bd->flags &= ~BF_EVACUATED;
758 dbl_link_onto(bd, &stp->large_objects);
761 // add the new blocks we promoted during this GC
762 stp->n_blocks += stp->n_to_blocks;
763 stp->n_large_blocks += stp->n_scavenged_large_blocks;
768 /* Reset the sizes of the older generations when we do a major
771 * CURRENT STRATEGY: make all generations except zero the same size.
772 * We have to stay within the maximum heap size, and leave a certain
773 * percentage of the maximum heap size available to allocate into.
775 if (major_gc && RtsFlags.GcFlags.generations > 1) {
776 nat live, size, min_alloc;
777 nat max = RtsFlags.GcFlags.maxHeapSize;
778 nat gens = RtsFlags.GcFlags.generations;
780 // live in the oldest generations
781 live = oldest_gen->steps[0].n_blocks +
782 oldest_gen->steps[0].n_large_blocks;
784 // default max size for all generations except zero
785 size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
786 RtsFlags.GcFlags.minOldGenSize);
788 // minimum size for generation zero
789 min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
790 RtsFlags.GcFlags.minAllocAreaSize);
792 // Auto-enable compaction when the residency reaches a
793 // certain percentage of the maximum heap size (default: 30%).
794 if (RtsFlags.GcFlags.generations > 1 &&
795 (RtsFlags.GcFlags.compact ||
797 oldest_gen->steps[0].n_blocks >
798 (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
799 oldest_gen->steps[0].is_compacted = 1;
800 // fprintf(stderr,"compaction: on\n", live);
802 oldest_gen->steps[0].is_compacted = 0;
803 // fprintf(stderr,"compaction: off\n", live);
806 // if we're going to go over the maximum heap size, reduce the
807 // size of the generations accordingly. The calculation is
808 // different if compaction is turned on, because we don't need
809 // to double the space required to collect the old generation.
812 // this test is necessary to ensure that the calculations
813 // below don't have any negative results - we're working
814 // with unsigned values here.
815 if (max < min_alloc) {
819 if (oldest_gen->steps[0].is_compacted) {
820 if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
821 size = (max - min_alloc) / ((gens - 1) * 2 - 1);
824 if ( (size * (gens - 1) * 2) + min_alloc > max ) {
825 size = (max - min_alloc) / ((gens - 1) * 2);
835 fprintf(stderr,"live: %d, min_alloc: %d, size : %d, max = %d\n", live,
836 min_alloc, size, max);
839 for (g = 0; g < gens; g++) {
840 generations[g].max_blocks = size;
844 // Guess the amount of live data for stats.
847 /* Free the small objects allocated via allocate(), since this will
848 * all have been copied into G0S1 now.
850 if (small_alloc_list != NULL) {
851 freeChain(small_alloc_list);
853 small_alloc_list = NULL;
857 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
859 // Start a new pinned_object_block
860 pinned_object_block = NULL;
862 /* Free the mark stack.
864 if (mark_stack_bdescr != NULL) {
865 freeGroup(mark_stack_bdescr);
870 for (g = 0; g <= N; g++) {
871 for (s = 0; s < generations[g].n_steps; s++) {
872 stp = &generations[g].steps[s];
873 if (stp->is_compacted && stp->bitmap != NULL) {
874 freeGroup(stp->bitmap);
879 /* Two-space collector:
880 * Free the old to-space, and estimate the amount of live data.
882 if (RtsFlags.GcFlags.generations == 1) {
885 if (old_to_blocks != NULL) {
886 freeChain(old_to_blocks);
888 for (bd = g0s0->to_blocks; bd != NULL; bd = bd->link) {
889 bd->flags = 0; // now from-space
892 /* For a two-space collector, we need to resize the nursery. */
894 /* set up a new nursery. Allocate a nursery size based on a
895 * function of the amount of live data (by default a factor of 2)
896 * Use the blocks from the old nursery if possible, freeing up any
899 * If we get near the maximum heap size, then adjust our nursery
900 * size accordingly. If the nursery is the same size as the live
901 * data (L), then we need 3L bytes. We can reduce the size of the
902 * nursery to bring the required memory down near 2L bytes.
904 * A normal 2-space collector would need 4L bytes to give the same
905 * performance we get from 3L bytes, reducing to the same
906 * performance at 2L bytes.
908 blocks = g0s0->n_to_blocks;
910 if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
911 blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
912 RtsFlags.GcFlags.maxHeapSize ) {
913 long adjusted_blocks; // signed on purpose
916 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
917 IF_DEBUG(gc, belch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
918 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
919 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
922 blocks = adjusted_blocks;
925 blocks *= RtsFlags.GcFlags.oldGenFactor;
926 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
927 blocks = RtsFlags.GcFlags.minAllocAreaSize;
930 resizeNursery(blocks);
933 /* Generational collector:
934 * If the user has given us a suggested heap size, adjust our
935 * allocation area to make best use of the memory available.
938 if (RtsFlags.GcFlags.heapSizeSuggestion) {
940 nat needed = calcNeeded(); // approx blocks needed at next GC
942 /* Guess how much will be live in generation 0 step 0 next time.
943 * A good approximation is obtained by finding the
944 * percentage of g0s0 that was live at the last minor GC.
947 g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
950 /* Estimate a size for the allocation area based on the
951 * information available. We might end up going slightly under
952 * or over the suggested heap size, but we should be pretty
955 * Formula: suggested - needed
956 * ----------------------------
957 * 1 + g0s0_pcnt_kept/100
959 * where 'needed' is the amount of memory needed at the next
960 * collection for collecting all steps except g0s0.
963 (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
964 (100 + (long)g0s0_pcnt_kept);
966 if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
967 blocks = RtsFlags.GcFlags.minAllocAreaSize;
970 resizeNursery((nat)blocks);
973 // we might have added extra large blocks to the nursery, so
974 // resize back to minAllocAreaSize again.
975 resizeNursery(RtsFlags.GcFlags.minAllocAreaSize);
979 // mark the garbage collected CAFs as dead
980 #if 0 && defined(DEBUG) // doesn't work at the moment
981 if (major_gc) { gcCAFs(); }
985 // resetStaticObjectForRetainerProfiling() must be called before
987 resetStaticObjectForRetainerProfiling();
990 // zero the scavenged static object list
992 zero_static_object_list(scavenged_static_objects);
998 RELEASE_LOCK(&sched_mutex);
1000 // start any pending finalizers
1001 scheduleFinalizers(old_weak_ptr_list);
1003 // send exceptions to any threads which were about to die
1004 resurrectThreads(resurrected_threads);
1006 ACQUIRE_LOCK(&sched_mutex);
1008 // Update the stable pointer hash table.
1009 updateStablePtrTable(major_gc);
1011 // check sanity after GC
1012 IF_DEBUG(sanity, checkSanity());
1014 // extra GC trace info
1015 IF_DEBUG(gc, statDescribeGens());
1018 // symbol-table based profiling
1019 /* heapCensus(to_blocks); */ /* ToDo */
1022 // restore enclosing cost centre
1027 // check for memory leaks if sanity checking is on
1028 IF_DEBUG(sanity, memInventory());
1030 #ifdef RTS_GTK_FRONTPANEL
1031 if (RtsFlags.GcFlags.frontpanel) {
1032 updateFrontPanelAfterGC( N, live );
1036 // ok, GC over: tell the stats department what happened.
1037 stat_endGC(allocated, collected, live, copied, N);
1039 #ifndef mingw32_TARGET_OS
1040 // unblock signals again
1041 unblockUserSignals();
1048 /* -----------------------------------------------------------------------------
1051 traverse_weak_ptr_list is called possibly many times during garbage
1052 collection. It returns a flag indicating whether it did any work
1053 (i.e. called evacuate on any live pointers).
1055 Invariant: traverse_weak_ptr_list is called when the heap is in an
1056 idempotent state. That means that there are no pending
1057 evacuate/scavenge operations. This invariant helps the weak
1058 pointer code decide which weak pointers are dead - if there are no
1059 new live weak pointers, then all the currently unreachable ones are
1062 For generational GC: we just don't try to finalize weak pointers in
1063 older generations than the one we're collecting. This could
1064 probably be optimised by keeping per-generation lists of weak
1065 pointers, but for a few weak pointers this scheme will work.
1067 There are three distinct stages to processing weak pointers:
1069 - weak_stage == WeakPtrs
1071 We process all the weak pointers whos keys are alive (evacuate
1072 their values and finalizers), and repeat until we can find no new
1073 live keys. If no live keys are found in this pass, then we
1074 evacuate the finalizers of all the dead weak pointers in order to
1077 - weak_stage == WeakThreads
1079 Now, we discover which *threads* are still alive. Pointers to
1080 threads from the all_threads and main thread lists are the
1081 weakest of all: a pointers from the finalizer of a dead weak
1082 pointer can keep a thread alive. Any threads found to be unreachable
1083 are evacuated and placed on the resurrected_threads list so we
1084 can send them a signal later.
1086 - weak_stage == WeakDone
1088 No more evacuation is done.
1090 -------------------------------------------------------------------------- */
1093 traverse_weak_ptr_list(void)
1095 StgWeak *w, **last_w, *next_w;
1097 rtsBool flag = rtsFalse;
1099 switch (weak_stage) {
1105 /* doesn't matter where we evacuate values/finalizers to, since
1106 * these pointers are treated as roots (iff the keys are alive).
1110 last_w = &old_weak_ptr_list;
1111 for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1113 /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1114 * called on a live weak pointer object. Just remove it.
1116 if (w->header.info == &stg_DEAD_WEAK_info) {
1117 next_w = ((StgDeadWeak *)w)->link;
1122 switch (get_itbl(w)->type) {
1125 next_w = (StgWeak *)((StgEvacuated *)w)->evacuee;
1130 /* Now, check whether the key is reachable.
1132 new = isAlive(w->key);
1135 // evacuate the value and finalizer
1136 w->value = evacuate(w->value);
1137 w->finalizer = evacuate(w->finalizer);
1138 // remove this weak ptr from the old_weak_ptr list
1140 // and put it on the new weak ptr list
1142 w->link = weak_ptr_list;
1145 IF_DEBUG(weak, belch("Weak pointer still alive at %p -> %p",
1150 last_w = &(w->link);
1156 barf("traverse_weak_ptr_list: not WEAK");
1160 /* If we didn't make any changes, then we can go round and kill all
1161 * the dead weak pointers. The old_weak_ptr list is used as a list
1162 * of pending finalizers later on.
1164 if (flag == rtsFalse) {
1165 for (w = old_weak_ptr_list; w; w = w->link) {
1166 w->finalizer = evacuate(w->finalizer);
1169 // Next, move to the WeakThreads stage after fully
1170 // scavenging the finalizers we've just evacuated.
1171 weak_stage = WeakThreads;
1177 /* Now deal with the all_threads list, which behaves somewhat like
1178 * the weak ptr list. If we discover any threads that are about to
1179 * become garbage, we wake them up and administer an exception.
1182 StgTSO *t, *tmp, *next, **prev;
1184 prev = &old_all_threads;
1185 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1187 (StgClosure *)tmp = isAlive((StgClosure *)t);
1193 ASSERT(get_itbl(t)->type == TSO);
1194 switch (t->what_next) {
1195 case ThreadRelocated:
1200 case ThreadComplete:
1201 // finshed or died. The thread might still be alive, but we
1202 // don't keep it on the all_threads list. Don't forget to
1203 // stub out its global_link field.
1204 next = t->global_link;
1205 t->global_link = END_TSO_QUEUE;
1213 // not alive (yet): leave this thread on the
1214 // old_all_threads list.
1215 prev = &(t->global_link);
1216 next = t->global_link;
1219 // alive: move this thread onto the all_threads list.
1220 next = t->global_link;
1221 t->global_link = all_threads;
1228 /* And resurrect any threads which were about to become garbage.
1231 StgTSO *t, *tmp, *next;
1232 for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1233 next = t->global_link;
1234 (StgClosure *)tmp = evacuate((StgClosure *)t);
1235 tmp->global_link = resurrected_threads;
1236 resurrected_threads = tmp;
1240 weak_stage = WeakDone; // *now* we're done,
1241 return rtsTrue; // but one more round of scavenging, please
1244 barf("traverse_weak_ptr_list");
1249 /* -----------------------------------------------------------------------------
1250 After GC, the live weak pointer list may have forwarding pointers
1251 on it, because a weak pointer object was evacuated after being
1252 moved to the live weak pointer list. We remove those forwarding
1255 Also, we don't consider weak pointer objects to be reachable, but
1256 we must nevertheless consider them to be "live" and retain them.
1257 Therefore any weak pointer objects which haven't as yet been
1258 evacuated need to be evacuated now.
1259 -------------------------------------------------------------------------- */
1263 mark_weak_ptr_list ( StgWeak **list )
1265 StgWeak *w, **last_w;
1268 for (w = *list; w; w = w->link) {
1269 // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
1270 ASSERT(w->header.info == &stg_DEAD_WEAK_info
1271 || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
1272 (StgClosure *)w = evacuate((StgClosure *)w);
1274 last_w = &(w->link);
1278 /* -----------------------------------------------------------------------------
1279 isAlive determines whether the given closure is still alive (after
1280 a garbage collection) or not. It returns the new address of the
1281 closure if it is alive, or NULL otherwise.
1283 NOTE: Use it before compaction only!
1284 -------------------------------------------------------------------------- */
1288 isAlive(StgClosure *p)
1290 const StgInfoTable *info;
1297 /* ToDo: for static closures, check the static link field.
1298 * Problem here is that we sometimes don't set the link field, eg.
1299 * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1305 // ignore closures in generations that we're not collecting.
1306 if (LOOKS_LIKE_STATIC(p) || bd->gen_no > N) {
1310 // if it's a pointer into to-space, then we're done
1311 if (bd->flags & BF_EVACUATED) {
1315 // large objects use the evacuated flag
1316 if (bd->flags & BF_LARGE) {
1320 // check the mark bit for compacted steps
1321 if (bd->step->is_compacted && is_marked((P_)p,bd)) {
1325 switch (info->type) {
1330 case IND_OLDGEN: // rely on compatible layout with StgInd
1331 case IND_OLDGEN_PERM:
1332 // follow indirections
1333 p = ((StgInd *)p)->indirectee;
1338 return ((StgEvacuated *)p)->evacuee;
1341 if (((StgTSO *)p)->what_next == ThreadRelocated) {
1342 p = (StgClosure *)((StgTSO *)p)->link;
1354 mark_root(StgClosure **root)
1356 *root = evacuate(*root);
1362 bdescr *bd = allocBlock();
1363 bd->gen_no = stp->gen_no;
1366 if (stp->gen_no <= N) {
1367 bd->flags = BF_EVACUATED;
1372 stp->hp_bd->free = stp->hp;
1373 stp->hp_bd->link = bd;
1374 stp->hp = bd->start;
1375 stp->hpLim = stp->hp + BLOCK_SIZE_W;
1382 static __inline__ void
1383 upd_evacuee(StgClosure *p, StgClosure *dest)
1385 // Source object must be in from-space:
1386 ASSERT((Bdescr((P_)p)->flags & BF_EVACUATED) == 0);
1387 // not true: (ToDo: perhaps it should be)
1388 // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
1389 p->header.info = &stg_EVACUATED_info;
1390 ((StgEvacuated *)p)->evacuee = dest;
1394 static __inline__ StgClosure *
1395 copy(StgClosure *src, nat size, step *stp)
1400 nat size_org = size;
1403 TICK_GC_WORDS_COPIED(size);
1404 /* Find out where we're going, using the handy "to" pointer in
1405 * the step of the source object. If it turns out we need to
1406 * evacuate to an older generation, adjust it here (see comment
1409 if (stp->gen_no < evac_gen) {
1410 #ifdef NO_EAGER_PROMOTION
1411 failed_to_evac = rtsTrue;
1413 stp = &generations[evac_gen].steps[0];
1417 /* chain a new block onto the to-space for the destination step if
1420 if (stp->hp + size >= stp->hpLim) {
1424 for(to = stp->hp, from = (P_)src; size>0; --size) {
1430 upd_evacuee(src,(StgClosure *)dest);
1432 // We store the size of the just evacuated object in the LDV word so that
1433 // the profiler can guess the position of the next object later.
1434 SET_EVACUAEE_FOR_LDV(src, size_org);
1436 return (StgClosure *)dest;
1439 /* Special version of copy() for when we only want to copy the info
1440 * pointer of an object, but reserve some padding after it. This is
1441 * used to optimise evacuation of BLACKHOLEs.
1446 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1451 nat size_to_copy_org = size_to_copy;
1454 TICK_GC_WORDS_COPIED(size_to_copy);
1455 if (stp->gen_no < evac_gen) {
1456 #ifdef NO_EAGER_PROMOTION
1457 failed_to_evac = rtsTrue;
1459 stp = &generations[evac_gen].steps[0];
1463 if (stp->hp + size_to_reserve >= stp->hpLim) {
1467 for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1472 stp->hp += size_to_reserve;
1473 upd_evacuee(src,(StgClosure *)dest);
1475 // We store the size of the just evacuated object in the LDV word so that
1476 // the profiler can guess the position of the next object later.
1477 // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1479 SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1481 if (size_to_reserve - size_to_copy_org > 0)
1482 FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1484 return (StgClosure *)dest;
1488 /* -----------------------------------------------------------------------------
1489 Evacuate a large object
1491 This just consists of removing the object from the (doubly-linked)
1492 step->large_objects list, and linking it on to the (singly-linked)
1493 step->new_large_objects list, from where it will be scavenged later.
1495 Convention: bd->flags has BF_EVACUATED set for a large object
1496 that has been evacuated, or unset otherwise.
1497 -------------------------------------------------------------------------- */
1501 evacuate_large(StgPtr p)
1503 bdescr *bd = Bdescr(p);
1506 // object must be at the beginning of the block (or be a ByteArray)
1507 ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1508 (((W_)p & BLOCK_MASK) == 0));
1510 // already evacuated?
1511 if (bd->flags & BF_EVACUATED) {
1512 /* Don't forget to set the failed_to_evac flag if we didn't get
1513 * the desired destination (see comments in evacuate()).
1515 if (bd->gen_no < evac_gen) {
1516 failed_to_evac = rtsTrue;
1517 TICK_GC_FAILED_PROMOTION();
1523 // remove from large_object list
1525 bd->u.back->link = bd->link;
1526 } else { // first object in the list
1527 stp->large_objects = bd->link;
1530 bd->link->u.back = bd->u.back;
1533 /* link it on to the evacuated large object list of the destination step
1536 if (stp->gen_no < evac_gen) {
1537 #ifdef NO_EAGER_PROMOTION
1538 failed_to_evac = rtsTrue;
1540 stp = &generations[evac_gen].steps[0];
1545 bd->gen_no = stp->gen_no;
1546 bd->link = stp->new_large_objects;
1547 stp->new_large_objects = bd;
1548 bd->flags |= BF_EVACUATED;
1551 /* -----------------------------------------------------------------------------
1552 Adding a MUT_CONS to an older generation.
1554 This is necessary from time to time when we end up with an
1555 old-to-new generation pointer in a non-mutable object. We defer
1556 the promotion until the next GC.
1557 -------------------------------------------------------------------------- */
1561 mkMutCons(StgClosure *ptr, generation *gen)
1566 stp = &gen->steps[0];
1568 /* chain a new block onto the to-space for the destination step if
1571 if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
1575 q = (StgMutVar *)stp->hp;
1576 stp->hp += sizeofW(StgMutVar);
1578 SET_HDR(q,&stg_MUT_CONS_info,CCS_GC);
1580 recordOldToNewPtrs((StgMutClosure *)q);
1582 return (StgClosure *)q;
1585 /* -----------------------------------------------------------------------------
1588 This is called (eventually) for every live object in the system.
1590 The caller to evacuate specifies a desired generation in the
1591 evac_gen global variable. The following conditions apply to
1592 evacuating an object which resides in generation M when we're
1593 collecting up to generation N
1597 else evac to step->to
1599 if M < evac_gen evac to evac_gen, step 0
1601 if the object is already evacuated, then we check which generation
1604 if M >= evac_gen do nothing
1605 if M < evac_gen set failed_to_evac flag to indicate that we
1606 didn't manage to evacuate this object into evac_gen.
1608 -------------------------------------------------------------------------- */
1611 evacuate(StgClosure *q)
1616 const StgInfoTable *info;
1619 if (HEAP_ALLOCED(q)) {
1622 if (bd->gen_no > N) {
1623 /* Can't evacuate this object, because it's in a generation
1624 * older than the ones we're collecting. Let's hope that it's
1625 * in evac_gen or older, or we will have to arrange to track
1626 * this pointer using the mutable list.
1628 if (bd->gen_no < evac_gen) {
1630 failed_to_evac = rtsTrue;
1631 TICK_GC_FAILED_PROMOTION();
1636 /* evacuate large objects by re-linking them onto a different list.
1638 if (bd->flags & BF_LARGE) {
1640 if (info->type == TSO &&
1641 ((StgTSO *)q)->what_next == ThreadRelocated) {
1642 q = (StgClosure *)((StgTSO *)q)->link;
1645 evacuate_large((P_)q);
1649 /* If the object is in a step that we're compacting, then we
1650 * need to use an alternative evacuate procedure.
1652 if (bd->step->is_compacted) {
1653 if (!is_marked((P_)q,bd)) {
1655 if (mark_stack_full()) {
1656 mark_stack_overflowed = rtsTrue;
1659 push_mark_stack((P_)q);
1667 else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1670 // make sure the info pointer is into text space
1671 ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1672 || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1675 switch (info -> type) {
1679 to = copy(q,sizeW_fromITBL(info),stp);
1684 StgWord w = (StgWord)q->payload[0];
1685 if (q->header.info == Czh_con_info &&
1686 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
1687 (StgChar)w <= MAX_CHARLIKE) {
1688 return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1690 if (q->header.info == Izh_con_info &&
1691 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1692 return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1694 // else, fall through ...
1700 return copy(q,sizeofW(StgHeader)+1,stp);
1702 case THUNK_1_0: // here because of MIN_UPD_SIZE
1707 #ifdef NO_PROMOTE_THUNKS
1708 if (bd->gen_no == 0 &&
1709 bd->step->no != 0 &&
1710 bd->step->no == generations[bd->gen_no].n_steps-1) {
1714 return copy(q,sizeofW(StgHeader)+2,stp);
1722 return copy(q,sizeofW(StgHeader)+2,stp);
1728 case IND_OLDGEN_PERM:
1733 return copy(q,sizeW_fromITBL(info),stp);
1736 case SE_CAF_BLACKHOLE:
1739 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1742 to = copy(q,BLACKHOLE_sizeW(),stp);
1745 case THUNK_SELECTOR:
1749 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
1750 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1753 p = eval_thunk_selector(info->layout.selector_offset,
1757 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1759 // q is still BLACKHOLE'd.
1760 thunk_selector_depth++;
1762 thunk_selector_depth--;
1770 // follow chains of indirections, don't evacuate them
1771 q = ((StgInd*)q)->indirectee;
1775 if (info->srt_len > 0 && major_gc &&
1776 THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1777 THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1778 static_objects = (StgClosure *)q;
1783 if (info->srt_len > 0 && major_gc &&
1784 FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1785 FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1786 static_objects = (StgClosure *)q;
1791 /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1792 * on the CAF list, so don't do anything with it here (we'll
1793 * scavenge it later).
1796 && ((StgIndStatic *)q)->saved_info == NULL
1797 && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1798 IND_STATIC_LINK((StgClosure *)q) = static_objects;
1799 static_objects = (StgClosure *)q;
1804 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1805 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1806 static_objects = (StgClosure *)q;
1810 case CONSTR_INTLIKE:
1811 case CONSTR_CHARLIKE:
1812 case CONSTR_NOCAF_STATIC:
1813 /* no need to put these on the static linked list, they don't need
1828 // shouldn't see these
1829 barf("evacuate: stack frame at %p\n", q);
1833 /* PAPs and AP_UPDs are special - the payload is a copy of a chunk
1834 * of stack, tagging and all.
1836 return copy(q,pap_sizeW((StgPAP*)q),stp);
1839 /* Already evacuated, just return the forwarding address.
1840 * HOWEVER: if the requested destination generation (evac_gen) is
1841 * older than the actual generation (because the object was
1842 * already evacuated to a younger generation) then we have to
1843 * set the failed_to_evac flag to indicate that we couldn't
1844 * manage to promote the object to the desired generation.
1846 if (evac_gen > 0) { // optimisation
1847 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1848 if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
1849 failed_to_evac = rtsTrue;
1850 TICK_GC_FAILED_PROMOTION();
1853 return ((StgEvacuated*)q)->evacuee;
1856 // just copy the block
1857 return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1860 case MUT_ARR_PTRS_FROZEN:
1861 // just copy the block
1862 return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1866 StgTSO *tso = (StgTSO *)q;
1868 /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1870 if (tso->what_next == ThreadRelocated) {
1871 q = (StgClosure *)tso->link;
1875 /* To evacuate a small TSO, we need to relocate the update frame
1879 StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),stp);
1880 move_TSO(tso, new_tso);
1881 return (StgClosure *)new_tso;
1886 case RBH: // cf. BLACKHOLE_BQ
1888 //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1889 to = copy(q,BLACKHOLE_sizeW(),stp);
1890 //ToDo: derive size etc from reverted IP
1891 //to = copy(q,size,stp);
1893 belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1894 q, info_type(q), to, info_type(to)));
1899 ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1900 to = copy(q,sizeofW(StgBlockedFetch),stp);
1902 belch("@@ evacuate: %p (%s) to %p (%s)",
1903 q, info_type(q), to, info_type(to)));
1910 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1911 to = copy(q,sizeofW(StgFetchMe),stp);
1913 belch("@@ evacuate: %p (%s) to %p (%s)",
1914 q, info_type(q), to, info_type(to)));
1918 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1919 to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1921 belch("@@ evacuate: %p (%s) to %p (%s)",
1922 q, info_type(q), to, info_type(to)));
1927 barf("evacuate: strange closure type %d", (int)(info->type));
1933 /* -----------------------------------------------------------------------------
1934 Evaluate a THUNK_SELECTOR if possible.
1936 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
1937 a closure pointer if we evaluated it and this is the result. Note
1938 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
1939 reducing it to HNF, just that we have eliminated the selection.
1940 The result might be another thunk, or even another THUNK_SELECTOR.
1942 If the return value is non-NULL, the original selector thunk has
1943 been BLACKHOLE'd, and should be updated with an indirection or a
1944 forwarding pointer. If the return value is NULL, then the selector
1946 -------------------------------------------------------------------------- */
1949 eval_thunk_selector( nat field, StgSelector * p )
1952 const StgInfoTable *info_ptr;
1953 StgClosure *selectee;
1955 selectee = p->selectee;
1957 // Save the real info pointer (NOTE: not the same as get_itbl()).
1958 info_ptr = p->header.info;
1960 // If the THUNK_SELECTOR is in a generation that we are not
1961 // collecting, then bail out early. We won't be able to save any
1962 // space in any case, and updating with an indirection is trickier
1964 if (Bdescr((StgPtr)p)->gen_no > N) {
1968 // BLACKHOLE the selector thunk, since it is now under evaluation.
1969 // This is important to stop us going into an infinite loop if
1970 // this selector thunk eventually refers to itself.
1971 SET_INFO(p,&stg_BLACKHOLE_info);
1975 info = get_itbl(selectee);
1976 switch (info->type) {
1984 case CONSTR_NOCAF_STATIC:
1985 // check that the size is in range
1986 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
1987 info->layout.payload.nptrs));
1989 return selectee->payload[field];
1994 case IND_OLDGEN_PERM:
1995 selectee = ((StgInd *)selectee)->indirectee;
1999 // We don't follow pointers into to-space; the constructor
2000 // has already been evacuated, so we won't save any space
2001 // leaks by evaluating this selector thunk anyhow.
2005 // We can't easily tell whether the indirectee is into
2006 // from or to-space, so just bail out here.
2009 case THUNK_SELECTOR:
2013 // check that we don't recurse too much, re-using the
2014 // depth bound also used in evacuate().
2015 thunk_selector_depth++;
2016 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2020 val = eval_thunk_selector(info->layout.selector_offset,
2021 (StgSelector *)selectee);
2023 thunk_selector_depth--;
2028 // We evaluated this selector thunk, so update it with
2029 // an indirection. NOTE: we don't use UPD_IND here,
2030 // because we are guaranteed that p is in a generation
2031 // that we are collecting, and we never want to put the
2032 // indirection on a mutable list.
2033 ((StgInd *)selectee)->indirectee = val;
2034 SET_INFO(selectee,&stg_IND_info);
2049 case SE_CAF_BLACKHOLE:
2062 // not evaluated yet
2066 barf("eval_thunk_selector: strange selectee %d",
2070 // We didn't manage to evaluate this thunk; restore the old info pointer
2071 SET_INFO(p, info_ptr);
2075 /* -----------------------------------------------------------------------------
2076 move_TSO is called to update the TSO structure after it has been
2077 moved from one place to another.
2078 -------------------------------------------------------------------------- */
2081 move_TSO(StgTSO *src, StgTSO *dest)
2085 // relocate the stack pointers...
2086 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2087 dest->sp = (StgPtr)dest->sp + diff;
2088 dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
2090 relocate_stack(dest, diff);
2093 /* -----------------------------------------------------------------------------
2094 relocate_stack is called to update the linkage between
2095 UPDATE_FRAMEs (and SEQ_FRAMEs etc.) when a stack is moved from one
2097 -------------------------------------------------------------------------- */
2100 relocate_stack(StgTSO *dest, ptrdiff_t diff)
2108 while ((P_)su < dest->stack + dest->stack_size) {
2109 switch (get_itbl(su)->type) {
2111 // GCC actually manages to common up these three cases!
2114 su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
2119 cf = (StgCatchFrame *)su;
2120 cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
2125 sf = (StgSeqFrame *)su;
2126 sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
2135 barf("relocate_stack %d", (int)(get_itbl(su)->type));
2146 scavenge_srt(const StgInfoTable *info)
2148 StgClosure **srt, **srt_end;
2150 /* evacuate the SRT. If srt_len is zero, then there isn't an
2151 * srt field in the info table. That's ok, because we'll
2152 * never dereference it.
2154 srt = (StgClosure **)(info->srt);
2155 srt_end = srt + info->srt_len;
2156 for (; srt < srt_end; srt++) {
2157 /* Special-case to handle references to closures hiding out in DLLs, since
2158 double indirections required to get at those. The code generator knows
2159 which is which when generating the SRT, so it stores the (indirect)
2160 reference to the DLL closure in the table by first adding one to it.
2161 We check for this here, and undo the addition before evacuating it.
2163 If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2164 closure that's fixed at link-time, and no extra magic is required.
2166 #ifdef ENABLE_WIN32_DLL_SUPPORT
2167 if ( (unsigned long)(*srt) & 0x1 ) {
2168 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2178 /* -----------------------------------------------------------------------------
2180 -------------------------------------------------------------------------- */
2183 scavengeTSO (StgTSO *tso)
2185 // chase the link field for any TSOs on the same queue
2186 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2187 if ( tso->why_blocked == BlockedOnMVar
2188 || tso->why_blocked == BlockedOnBlackHole
2189 || tso->why_blocked == BlockedOnException
2191 || tso->why_blocked == BlockedOnGA
2192 || tso->why_blocked == BlockedOnGA_NoSend
2195 tso->block_info.closure = evacuate(tso->block_info.closure);
2197 if ( tso->blocked_exceptions != NULL ) {
2198 tso->blocked_exceptions =
2199 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2201 // scavenge this thread's stack
2202 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2205 /* -----------------------------------------------------------------------------
2206 Scavenge a given step until there are no more objects in this step
2209 evac_gen is set by the caller to be either zero (for a step in a
2210 generation < N) or G where G is the generation of the step being
2213 We sometimes temporarily change evac_gen back to zero if we're
2214 scavenging a mutable object where early promotion isn't such a good
2216 -------------------------------------------------------------------------- */
2224 nat saved_evac_gen = evac_gen;
2229 failed_to_evac = rtsFalse;
2231 /* scavenge phase - standard breadth-first scavenging of the
2235 while (bd != stp->hp_bd || p < stp->hp) {
2237 // If we're at the end of this block, move on to the next block
2238 if (bd != stp->hp_bd && p == bd->free) {
2244 info = get_itbl((StgClosure *)p);
2245 ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2247 ASSERT(thunk_selector_depth == 0);
2250 switch (info->type) {
2253 /* treat MVars specially, because we don't want to evacuate the
2254 * mut_link field in the middle of the closure.
2257 StgMVar *mvar = ((StgMVar *)p);
2259 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2260 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2261 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2262 evac_gen = saved_evac_gen;
2263 recordMutable((StgMutClosure *)mvar);
2264 failed_to_evac = rtsFalse; // mutable.
2265 p += sizeofW(StgMVar);
2273 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2274 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2275 p += sizeofW(StgHeader) + 2;
2280 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2281 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2287 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2288 p += sizeofW(StgHeader) + 1;
2293 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2299 p += sizeofW(StgHeader) + 1;
2306 p += sizeofW(StgHeader) + 2;
2313 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2314 p += sizeofW(StgHeader) + 2;
2330 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2331 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2332 (StgClosure *)*p = evacuate((StgClosure *)*p);
2334 p += info->layout.payload.nptrs;
2339 if (stp->gen->no != 0) {
2342 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2343 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2344 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2347 // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
2349 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2352 // We pretend that p has just been created.
2353 LDV_recordCreate((StgClosure *)p);
2357 case IND_OLDGEN_PERM:
2358 ((StgIndOldGen *)p)->indirectee =
2359 evacuate(((StgIndOldGen *)p)->indirectee);
2360 if (failed_to_evac) {
2361 failed_to_evac = rtsFalse;
2362 recordOldToNewPtrs((StgMutClosure *)p);
2364 p += sizeofW(StgIndOldGen);
2369 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2370 evac_gen = saved_evac_gen;
2371 recordMutable((StgMutClosure *)p);
2372 failed_to_evac = rtsFalse; // mutable anyhow
2373 p += sizeofW(StgMutVar);
2378 failed_to_evac = rtsFalse; // mutable anyhow
2379 p += sizeofW(StgMutVar);
2383 case SE_CAF_BLACKHOLE:
2386 p += BLACKHOLE_sizeW();
2391 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2392 (StgClosure *)bh->blocking_queue =
2393 evacuate((StgClosure *)bh->blocking_queue);
2394 recordMutable((StgMutClosure *)bh);
2395 failed_to_evac = rtsFalse;
2396 p += BLACKHOLE_sizeW();
2400 case THUNK_SELECTOR:
2402 StgSelector *s = (StgSelector *)p;
2403 s->selectee = evacuate(s->selectee);
2404 p += THUNK_SELECTOR_sizeW();
2408 case AP_UPD: // same as PAPs
2410 /* Treat a PAP just like a section of stack, not forgetting to
2411 * evacuate the function pointer too...
2414 StgPAP* pap = (StgPAP *)p;
2416 pap->fun = evacuate(pap->fun);
2417 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2418 p += pap_sizeW(pap);
2423 // nothing to follow
2424 p += arr_words_sizeW((StgArrWords *)p);
2428 // follow everything
2432 evac_gen = 0; // repeatedly mutable
2433 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2434 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2435 (StgClosure *)*p = evacuate((StgClosure *)*p);
2437 evac_gen = saved_evac_gen;
2438 recordMutable((StgMutClosure *)q);
2439 failed_to_evac = rtsFalse; // mutable anyhow.
2443 case MUT_ARR_PTRS_FROZEN:
2444 // follow everything
2448 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2449 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2450 (StgClosure *)*p = evacuate((StgClosure *)*p);
2452 // it's tempting to recordMutable() if failed_to_evac is
2453 // false, but that breaks some assumptions (eg. every
2454 // closure on the mutable list is supposed to have the MUT
2455 // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2461 StgTSO *tso = (StgTSO *)p;
2464 evac_gen = saved_evac_gen;
2465 recordMutable((StgMutClosure *)tso);
2466 failed_to_evac = rtsFalse; // mutable anyhow.
2467 p += tso_sizeW(tso);
2472 case RBH: // cf. BLACKHOLE_BQ
2475 nat size, ptrs, nonptrs, vhs;
2477 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2479 StgRBH *rbh = (StgRBH *)p;
2480 (StgClosure *)rbh->blocking_queue =
2481 evacuate((StgClosure *)rbh->blocking_queue);
2482 recordMutable((StgMutClosure *)to);
2483 failed_to_evac = rtsFalse; // mutable anyhow.
2485 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2486 p, info_type(p), (StgClosure *)rbh->blocking_queue));
2487 // ToDo: use size of reverted closure here!
2488 p += BLACKHOLE_sizeW();
2494 StgBlockedFetch *bf = (StgBlockedFetch *)p;
2495 // follow the pointer to the node which is being demanded
2496 (StgClosure *)bf->node =
2497 evacuate((StgClosure *)bf->node);
2498 // follow the link to the rest of the blocking queue
2499 (StgClosure *)bf->link =
2500 evacuate((StgClosure *)bf->link);
2501 if (failed_to_evac) {
2502 failed_to_evac = rtsFalse;
2503 recordMutable((StgMutClosure *)bf);
2506 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2507 bf, info_type((StgClosure *)bf),
2508 bf->node, info_type(bf->node)));
2509 p += sizeofW(StgBlockedFetch);
2517 p += sizeofW(StgFetchMe);
2518 break; // nothing to do in this case
2520 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2522 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2523 (StgClosure *)fmbq->blocking_queue =
2524 evacuate((StgClosure *)fmbq->blocking_queue);
2525 if (failed_to_evac) {
2526 failed_to_evac = rtsFalse;
2527 recordMutable((StgMutClosure *)fmbq);
2530 belch("@@ scavenge: %p (%s) exciting, isn't it",
2531 p, info_type((StgClosure *)p)));
2532 p += sizeofW(StgFetchMeBlockingQueue);
2538 barf("scavenge: unimplemented/strange closure type %d @ %p",
2542 /* If we didn't manage to promote all the objects pointed to by
2543 * the current object, then we have to designate this object as
2544 * mutable (because it contains old-to-new generation pointers).
2546 if (failed_to_evac) {
2547 failed_to_evac = rtsFalse;
2548 mkMutCons((StgClosure *)q, &generations[evac_gen]);
2556 /* -----------------------------------------------------------------------------
2557 Scavenge everything on the mark stack.
2559 This is slightly different from scavenge():
2560 - we don't walk linearly through the objects, so the scavenger
2561 doesn't need to advance the pointer on to the next object.
2562 -------------------------------------------------------------------------- */
2565 scavenge_mark_stack(void)
2571 evac_gen = oldest_gen->no;
2572 saved_evac_gen = evac_gen;
2575 while (!mark_stack_empty()) {
2576 p = pop_mark_stack();
2578 info = get_itbl((StgClosure *)p);
2579 ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2582 switch (info->type) {
2585 /* treat MVars specially, because we don't want to evacuate the
2586 * mut_link field in the middle of the closure.
2589 StgMVar *mvar = ((StgMVar *)p);
2591 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2592 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2593 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2594 evac_gen = saved_evac_gen;
2595 failed_to_evac = rtsFalse; // mutable.
2603 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2604 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2614 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2639 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2640 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2641 (StgClosure *)*p = evacuate((StgClosure *)*p);
2647 // don't need to do anything here: the only possible case
2648 // is that we're in a 1-space compacting collector, with
2649 // no "old" generation.
2653 case IND_OLDGEN_PERM:
2654 ((StgIndOldGen *)p)->indirectee =
2655 evacuate(((StgIndOldGen *)p)->indirectee);
2656 if (failed_to_evac) {
2657 recordOldToNewPtrs((StgMutClosure *)p);
2659 failed_to_evac = rtsFalse;
2664 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2665 evac_gen = saved_evac_gen;
2666 failed_to_evac = rtsFalse;
2671 failed_to_evac = rtsFalse;
2675 case SE_CAF_BLACKHOLE:
2683 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2684 (StgClosure *)bh->blocking_queue =
2685 evacuate((StgClosure *)bh->blocking_queue);
2686 failed_to_evac = rtsFalse;
2690 case THUNK_SELECTOR:
2692 StgSelector *s = (StgSelector *)p;
2693 s->selectee = evacuate(s->selectee);
2697 case AP_UPD: // same as PAPs
2699 /* Treat a PAP just like a section of stack, not forgetting to
2700 * evacuate the function pointer too...
2703 StgPAP* pap = (StgPAP *)p;
2705 pap->fun = evacuate(pap->fun);
2706 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2711 // follow everything
2715 evac_gen = 0; // repeatedly mutable
2716 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2717 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2718 (StgClosure *)*p = evacuate((StgClosure *)*p);
2720 evac_gen = saved_evac_gen;
2721 failed_to_evac = rtsFalse; // mutable anyhow.
2725 case MUT_ARR_PTRS_FROZEN:
2726 // follow everything
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);
2739 StgTSO *tso = (StgTSO *)p;
2742 evac_gen = saved_evac_gen;
2743 failed_to_evac = rtsFalse;
2748 case RBH: // cf. BLACKHOLE_BQ
2751 nat size, ptrs, nonptrs, vhs;
2753 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2755 StgRBH *rbh = (StgRBH *)p;
2756 (StgClosure *)rbh->blocking_queue =
2757 evacuate((StgClosure *)rbh->blocking_queue);
2758 recordMutable((StgMutClosure *)rbh);
2759 failed_to_evac = rtsFalse; // mutable anyhow.
2761 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2762 p, info_type(p), (StgClosure *)rbh->blocking_queue));
2768 StgBlockedFetch *bf = (StgBlockedFetch *)p;
2769 // follow the pointer to the node which is being demanded
2770 (StgClosure *)bf->node =
2771 evacuate((StgClosure *)bf->node);
2772 // follow the link to the rest of the blocking queue
2773 (StgClosure *)bf->link =
2774 evacuate((StgClosure *)bf->link);
2775 if (failed_to_evac) {
2776 failed_to_evac = rtsFalse;
2777 recordMutable((StgMutClosure *)bf);
2780 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2781 bf, info_type((StgClosure *)bf),
2782 bf->node, info_type(bf->node)));
2790 break; // nothing to do in this case
2792 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2794 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2795 (StgClosure *)fmbq->blocking_queue =
2796 evacuate((StgClosure *)fmbq->blocking_queue);
2797 if (failed_to_evac) {
2798 failed_to_evac = rtsFalse;
2799 recordMutable((StgMutClosure *)fmbq);
2802 belch("@@ scavenge: %p (%s) exciting, isn't it",
2803 p, info_type((StgClosure *)p)));
2809 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
2813 if (failed_to_evac) {
2814 failed_to_evac = rtsFalse;
2815 mkMutCons((StgClosure *)q, &generations[evac_gen]);
2818 // mark the next bit to indicate "scavenged"
2819 mark(q+1, Bdescr(q));
2821 } // while (!mark_stack_empty())
2823 // start a new linear scan if the mark stack overflowed at some point
2824 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
2825 IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
2826 mark_stack_overflowed = rtsFalse;
2827 oldgen_scan_bd = oldest_gen->steps[0].blocks;
2828 oldgen_scan = oldgen_scan_bd->start;
2831 if (oldgen_scan_bd) {
2832 // push a new thing on the mark stack
2834 // find a closure that is marked but not scavenged, and start
2836 while (oldgen_scan < oldgen_scan_bd->free
2837 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
2841 if (oldgen_scan < oldgen_scan_bd->free) {
2843 // already scavenged?
2844 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
2845 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2848 push_mark_stack(oldgen_scan);
2849 // ToDo: bump the linear scan by the actual size of the object
2850 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2854 oldgen_scan_bd = oldgen_scan_bd->link;
2855 if (oldgen_scan_bd != NULL) {
2856 oldgen_scan = oldgen_scan_bd->start;
2862 /* -----------------------------------------------------------------------------
2863 Scavenge one object.
2865 This is used for objects that are temporarily marked as mutable
2866 because they contain old-to-new generation pointers. Only certain
2867 objects can have this property.
2868 -------------------------------------------------------------------------- */
2871 scavenge_one(StgPtr p)
2873 const StgInfoTable *info;
2874 nat saved_evac_gen = evac_gen;
2877 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
2878 || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
2880 info = get_itbl((StgClosure *)p);
2882 switch (info->type) {
2885 case FUN_1_0: // hardly worth specialising these guys
2905 case IND_OLDGEN_PERM:
2909 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2910 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
2911 (StgClosure *)*q = evacuate((StgClosure *)*q);
2917 case SE_CAF_BLACKHOLE:
2922 case THUNK_SELECTOR:
2924 StgSelector *s = (StgSelector *)p;
2925 s->selectee = evacuate(s->selectee);
2930 // nothing to follow
2935 // follow everything
2938 evac_gen = 0; // repeatedly mutable
2939 recordMutable((StgMutClosure *)p);
2940 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2941 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2942 (StgClosure *)*p = evacuate((StgClosure *)*p);
2944 evac_gen = saved_evac_gen;
2945 failed_to_evac = rtsFalse;
2949 case MUT_ARR_PTRS_FROZEN:
2951 // follow everything
2954 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2955 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2956 (StgClosure *)*p = evacuate((StgClosure *)*p);
2963 StgTSO *tso = (StgTSO *)p;
2965 evac_gen = 0; // repeatedly mutable
2967 recordMutable((StgMutClosure *)tso);
2968 evac_gen = saved_evac_gen;
2969 failed_to_evac = rtsFalse;
2976 StgPAP* pap = (StgPAP *)p;
2977 pap->fun = evacuate(pap->fun);
2978 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2983 // This might happen if for instance a MUT_CONS was pointing to a
2984 // THUNK which has since been updated. The IND_OLDGEN will
2985 // be on the mutable list anyway, so we don't need to do anything
2990 barf("scavenge_one: strange object %d", (int)(info->type));
2993 no_luck = failed_to_evac;
2994 failed_to_evac = rtsFalse;
2998 /* -----------------------------------------------------------------------------
2999 Scavenging mutable lists.
3001 We treat the mutable list of each generation > N (i.e. all the
3002 generations older than the one being collected) as roots. We also
3003 remove non-mutable objects from the mutable list at this point.
3004 -------------------------------------------------------------------------- */
3007 scavenge_mut_once_list(generation *gen)
3009 const StgInfoTable *info;
3010 StgMutClosure *p, *next, *new_list;
3012 p = gen->mut_once_list;
3013 new_list = END_MUT_LIST;
3017 failed_to_evac = rtsFalse;
3019 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3021 // make sure the info pointer is into text space
3022 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3023 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3027 if (info->type==RBH)
3028 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3030 switch(info->type) {
3033 case IND_OLDGEN_PERM:
3035 /* Try to pull the indirectee into this generation, so we can
3036 * remove the indirection from the mutable list.
3038 ((StgIndOldGen *)p)->indirectee =
3039 evacuate(((StgIndOldGen *)p)->indirectee);
3041 #if 0 && defined(DEBUG)
3042 if (RtsFlags.DebugFlags.gc)
3043 /* Debugging code to print out the size of the thing we just
3047 StgPtr start = gen->steps[0].scan;
3048 bdescr *start_bd = gen->steps[0].scan_bd;
3050 scavenge(&gen->steps[0]);
3051 if (start_bd != gen->steps[0].scan_bd) {
3052 size += (P_)BLOCK_ROUND_UP(start) - start;
3053 start_bd = start_bd->link;
3054 while (start_bd != gen->steps[0].scan_bd) {
3055 size += BLOCK_SIZE_W;
3056 start_bd = start_bd->link;
3058 size += gen->steps[0].scan -
3059 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3061 size = gen->steps[0].scan - start;
3063 belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3067 /* failed_to_evac might happen if we've got more than two
3068 * generations, we're collecting only generation 0, the
3069 * indirection resides in generation 2 and the indirectee is
3072 if (failed_to_evac) {
3073 failed_to_evac = rtsFalse;
3074 p->mut_link = new_list;
3077 /* the mut_link field of an IND_STATIC is overloaded as the
3078 * static link field too (it just so happens that we don't need
3079 * both at the same time), so we need to NULL it out when
3080 * removing this object from the mutable list because the static
3081 * link fields are all assumed to be NULL before doing a major
3089 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3090 * it from the mutable list if possible by promoting whatever it
3093 if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3094 /* didn't manage to promote everything, so put the
3095 * MUT_CONS back on the list.
3097 p->mut_link = new_list;
3103 // shouldn't have anything else on the mutables list
3104 barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3108 gen->mut_once_list = new_list;
3113 scavenge_mutable_list(generation *gen)
3115 const StgInfoTable *info;
3116 StgMutClosure *p, *next;
3118 p = gen->saved_mut_list;
3122 failed_to_evac = rtsFalse;
3124 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3126 // make sure the info pointer is into text space
3127 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3128 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3132 if (info->type==RBH)
3133 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3135 switch(info->type) {
3138 // follow everything
3139 p->mut_link = gen->mut_list;
3144 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3145 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3146 (StgClosure *)*q = evacuate((StgClosure *)*q);
3151 // Happens if a MUT_ARR_PTRS in the old generation is frozen
3152 case MUT_ARR_PTRS_FROZEN:
3157 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3158 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3159 (StgClosure *)*q = evacuate((StgClosure *)*q);
3163 if (failed_to_evac) {
3164 failed_to_evac = rtsFalse;
3165 mkMutCons((StgClosure *)p, gen);
3171 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3172 p->mut_link = gen->mut_list;
3178 StgMVar *mvar = (StgMVar *)p;
3179 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3180 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3181 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3182 p->mut_link = gen->mut_list;
3189 StgTSO *tso = (StgTSO *)p;
3193 /* Don't take this TSO off the mutable list - it might still
3194 * point to some younger objects (because we set evac_gen to 0
3197 tso->mut_link = gen->mut_list;
3198 gen->mut_list = (StgMutClosure *)tso;
3204 StgBlockingQueue *bh = (StgBlockingQueue *)p;
3205 (StgClosure *)bh->blocking_queue =
3206 evacuate((StgClosure *)bh->blocking_queue);
3207 p->mut_link = gen->mut_list;
3212 /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3215 case IND_OLDGEN_PERM:
3216 /* Try to pull the indirectee into this generation, so we can
3217 * remove the indirection from the mutable list.
3220 ((StgIndOldGen *)p)->indirectee =
3221 evacuate(((StgIndOldGen *)p)->indirectee);
3224 if (failed_to_evac) {
3225 failed_to_evac = rtsFalse;
3226 p->mut_link = gen->mut_once_list;
3227 gen->mut_once_list = p;
3234 // HWL: check whether all of these are necessary
3236 case RBH: // cf. BLACKHOLE_BQ
3238 // nat size, ptrs, nonptrs, vhs;
3240 // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3241 StgRBH *rbh = (StgRBH *)p;
3242 (StgClosure *)rbh->blocking_queue =
3243 evacuate((StgClosure *)rbh->blocking_queue);
3244 if (failed_to_evac) {
3245 failed_to_evac = rtsFalse;
3246 recordMutable((StgMutClosure *)rbh);
3248 // ToDo: use size of reverted closure here!
3249 p += BLACKHOLE_sizeW();
3255 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3256 // follow the pointer to the node which is being demanded
3257 (StgClosure *)bf->node =
3258 evacuate((StgClosure *)bf->node);
3259 // follow the link to the rest of the blocking queue
3260 (StgClosure *)bf->link =
3261 evacuate((StgClosure *)bf->link);
3262 if (failed_to_evac) {
3263 failed_to_evac = rtsFalse;
3264 recordMutable((StgMutClosure *)bf);
3266 p += sizeofW(StgBlockedFetch);
3272 barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3275 p += sizeofW(StgFetchMe);
3276 break; // nothing to do in this case
3278 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3280 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3281 (StgClosure *)fmbq->blocking_queue =
3282 evacuate((StgClosure *)fmbq->blocking_queue);
3283 if (failed_to_evac) {
3284 failed_to_evac = rtsFalse;
3285 recordMutable((StgMutClosure *)fmbq);
3287 p += sizeofW(StgFetchMeBlockingQueue);
3293 // shouldn't have anything else on the mutables list
3294 barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3301 scavenge_static(void)
3303 StgClosure* p = static_objects;
3304 const StgInfoTable *info;
3306 /* Always evacuate straight to the oldest generation for static
3308 evac_gen = oldest_gen->no;
3310 /* keep going until we've scavenged all the objects on the linked
3312 while (p != END_OF_STATIC_LIST) {
3316 if (info->type==RBH)
3317 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3319 // make sure the info pointer is into text space
3320 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3321 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3323 /* Take this object *off* the static_objects list,
3324 * and put it on the scavenged_static_objects list.
3326 static_objects = STATIC_LINK(info,p);
3327 STATIC_LINK(info,p) = scavenged_static_objects;
3328 scavenged_static_objects = p;
3330 switch (info -> type) {
3334 StgInd *ind = (StgInd *)p;
3335 ind->indirectee = evacuate(ind->indirectee);
3337 /* might fail to evacuate it, in which case we have to pop it
3338 * back on the mutable list (and take it off the
3339 * scavenged_static list because the static link and mut link
3340 * pointers are one and the same).
3342 if (failed_to_evac) {
3343 failed_to_evac = rtsFalse;
3344 scavenged_static_objects = IND_STATIC_LINK(p);
3345 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3346 oldest_gen->mut_once_list = (StgMutClosure *)ind;
3360 next = (P_)p->payload + info->layout.payload.ptrs;
3361 // evacuate the pointers
3362 for (q = (P_)p->payload; q < next; q++) {
3363 (StgClosure *)*q = evacuate((StgClosure *)*q);
3369 barf("scavenge_static: strange closure %d", (int)(info->type));
3372 ASSERT(failed_to_evac == rtsFalse);
3374 /* get the next static object from the list. Remember, there might
3375 * be more stuff on this list now that we've done some evacuating!
3376 * (static_objects is a global)
3382 /* -----------------------------------------------------------------------------
3383 scavenge_stack walks over a section of stack and evacuates all the
3384 objects pointed to by it. We can use the same code for walking
3385 PAPs, since these are just sections of copied stack.
3386 -------------------------------------------------------------------------- */
3389 scavenge_stack(StgPtr p, StgPtr stack_end)
3392 const StgInfoTable* info;
3395 //IF_DEBUG(sanity, belch(" scavenging stack between %p and %p", p, stack_end));
3398 * Each time around this loop, we are looking at a chunk of stack
3399 * that starts with either a pending argument section or an
3400 * activation record.
3403 while (p < stack_end) {
3406 // If we've got a tag, skip over that many words on the stack
3407 if (IS_ARG_TAG((W_)q)) {
3412 /* Is q a pointer to a closure?
3414 if (! LOOKS_LIKE_GHC_INFO(q) ) {
3416 if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) { // Is it a static closure?
3417 ASSERT(closure_STATIC((StgClosure *)q));
3419 // otherwise, must be a pointer into the allocation space.
3422 (StgClosure *)*p = evacuate((StgClosure *)q);
3428 * Otherwise, q must be the info pointer of an activation
3429 * record. All activation records have 'bitmap' style layout
3432 info = get_itbl((StgClosure *)p);
3434 switch (info->type) {
3436 // Dynamic bitmap: the mask is stored on the stack
3438 bitmap = ((StgRetDyn *)p)->liveness;
3439 p = (P_)&((StgRetDyn *)p)->payload[0];
3442 // probably a slow-entry point return address:
3450 belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
3451 old_p, p, old_p+1));
3453 p++; // what if FHS!=1 !? -- HWL
3458 /* Specialised code for update frames, since they're so common.
3459 * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
3460 * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
3464 StgUpdateFrame *frame = (StgUpdateFrame *)p;
3466 p += sizeofW(StgUpdateFrame);
3469 frame->updatee = evacuate(frame->updatee);
3471 #else // specialised code for update frames, not sure if it's worth it.
3473 nat type = get_itbl(frame->updatee)->type;
3475 if (type == EVACUATED) {
3476 frame->updatee = evacuate(frame->updatee);
3479 bdescr *bd = Bdescr((P_)frame->updatee);
3481 if (bd->gen_no > N) {
3482 if (bd->gen_no < evac_gen) {
3483 failed_to_evac = rtsTrue;
3488 // Don't promote blackholes
3490 if (!(stp->gen_no == 0 &&
3492 stp->no == stp->gen->n_steps-1)) {
3499 to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
3500 sizeofW(StgHeader), stp);
3501 frame->updatee = to;
3504 to = copy(frame->updatee, BLACKHOLE_sizeW(), stp);
3505 frame->updatee = to;
3506 recordMutable((StgMutClosure *)to);
3509 /* will never be SE_{,CAF_}BLACKHOLE, since we
3510 don't push an update frame for single-entry thunks. KSW 1999-01. */
3511 barf("scavenge_stack: UPDATE_FRAME updatee");
3517 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3524 bitmap = info->layout.bitmap;
3526 // this assumes that the payload starts immediately after the info-ptr
3528 while (bitmap != 0) {
3529 if ((bitmap & 1) == 0) {
3530 (StgClosure *)*p = evacuate((StgClosure *)*p);
3533 bitmap = bitmap >> 1;
3540 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3545 StgLargeBitmap *large_bitmap;
3548 large_bitmap = info->layout.large_bitmap;
3551 for (i=0; i<large_bitmap->size; i++) {
3552 bitmap = large_bitmap->bitmap[i];
3553 q = p + BITS_IN(W_);
3554 while (bitmap != 0) {
3555 if ((bitmap & 1) == 0) {
3556 (StgClosure *)*p = evacuate((StgClosure *)*p);
3559 bitmap = bitmap >> 1;
3561 if (i+1 < large_bitmap->size) {
3563 (StgClosure *)*p = evacuate((StgClosure *)*p);
3569 // and don't forget to follow the SRT
3574 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->type));
3579 /*-----------------------------------------------------------------------------
3580 scavenge the large object list.
3582 evac_gen set by caller; similar games played with evac_gen as with
3583 scavenge() - see comment at the top of scavenge(). Most large
3584 objects are (repeatedly) mutable, so most of the time evac_gen will
3586 --------------------------------------------------------------------------- */
3589 scavenge_large(step *stp)
3594 bd = stp->new_large_objects;
3596 for (; bd != NULL; bd = stp->new_large_objects) {
3598 /* take this object *off* the large objects list and put it on
3599 * the scavenged large objects list. This is so that we can
3600 * treat new_large_objects as a stack and push new objects on
3601 * the front when evacuating.
3603 stp->new_large_objects = bd->link;
3604 dbl_link_onto(bd, &stp->scavenged_large_objects);
3606 // update the block count in this step.
3607 stp->n_scavenged_large_blocks += bd->blocks;
3610 if (scavenge_one(p)) {
3611 mkMutCons((StgClosure *)p, stp->gen);
3616 /* -----------------------------------------------------------------------------
3617 Initialising the static object & mutable lists
3618 -------------------------------------------------------------------------- */
3621 zero_static_object_list(StgClosure* first_static)
3625 const StgInfoTable *info;
3627 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3629 link = STATIC_LINK(info, p);
3630 STATIC_LINK(info,p) = NULL;
3634 /* This function is only needed because we share the mutable link
3635 * field with the static link field in an IND_STATIC, so we have to
3636 * zero the mut_link field before doing a major GC, which needs the
3637 * static link field.
3639 * It doesn't do any harm to zero all the mutable link fields on the
3644 zero_mutable_list( StgMutClosure *first )
3646 StgMutClosure *next, *c;
3648 for (c = first; c != END_MUT_LIST; c = next) {
3654 /* -----------------------------------------------------------------------------
3656 -------------------------------------------------------------------------- */
3663 for (c = (StgIndStatic *)caf_list; c != NULL;
3664 c = (StgIndStatic *)c->static_link)
3666 c->header.info = c->saved_info;
3667 c->saved_info = NULL;
3668 // could, but not necessary: c->static_link = NULL;
3674 markCAFs( evac_fn evac )
3678 for (c = (StgIndStatic *)caf_list; c != NULL;
3679 c = (StgIndStatic *)c->static_link)
3681 evac(&c->indirectee);
3685 /* -----------------------------------------------------------------------------
3686 Sanity code for CAF garbage collection.
3688 With DEBUG turned on, we manage a CAF list in addition to the SRT
3689 mechanism. After GC, we run down the CAF list and blackhole any
3690 CAFs which have been garbage collected. This means we get an error
3691 whenever the program tries to enter a garbage collected CAF.
3693 Any garbage collected CAFs are taken off the CAF list at the same
3695 -------------------------------------------------------------------------- */
3697 #if 0 && defined(DEBUG)
3704 const StgInfoTable *info;
3715 ASSERT(info->type == IND_STATIC);
3717 if (STATIC_LINK(info,p) == NULL) {
3718 IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3720 SET_INFO(p,&stg_BLACKHOLE_info);
3721 p = STATIC_LINK2(info,p);
3725 pp = &STATIC_LINK2(info,p);
3732 // belch("%d CAFs live", i);
3737 /* -----------------------------------------------------------------------------
3740 Whenever a thread returns to the scheduler after possibly doing
3741 some work, we have to run down the stack and black-hole all the
3742 closures referred to by update frames.
3743 -------------------------------------------------------------------------- */
3746 threadLazyBlackHole(StgTSO *tso)
3748 StgUpdateFrame *update_frame;
3749 StgBlockingQueue *bh;
3752 stack_end = &tso->stack[tso->stack_size];
3753 update_frame = tso->su;
3756 switch (get_itbl(update_frame)->type) {
3759 update_frame = ((StgCatchFrame *)update_frame)->link;
3763 bh = (StgBlockingQueue *)update_frame->updatee;
3765 /* if the thunk is already blackholed, it means we've also
3766 * already blackholed the rest of the thunks on this stack,
3767 * so we can stop early.
3769 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3770 * don't interfere with this optimisation.
3772 if (bh->header.info == &stg_BLACKHOLE_info) {
3776 if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
3777 bh->header.info != &stg_CAF_BLACKHOLE_info) {
3778 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3779 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3783 // We pretend that bh is now dead.
3784 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
3786 SET_INFO(bh,&stg_BLACKHOLE_info);
3789 // We pretend that bh has just been created.
3790 LDV_recordCreate(bh);
3794 update_frame = update_frame->link;
3798 update_frame = ((StgSeqFrame *)update_frame)->link;
3804 barf("threadPaused");
3810 /* -----------------------------------------------------------------------------
3813 * Code largely pinched from old RTS, then hacked to bits. We also do
3814 * lazy black holing here.
3816 * -------------------------------------------------------------------------- */
3819 threadSqueezeStack(StgTSO *tso)
3821 lnat displacement = 0;
3822 StgUpdateFrame *frame;
3823 StgUpdateFrame *next_frame; // Temporally next
3824 StgUpdateFrame *prev_frame; // Temporally previous
3826 rtsBool prev_was_update_frame;
3828 StgUpdateFrame *top_frame;
3829 nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
3831 void printObj( StgClosure *obj ); // from Printer.c
3833 top_frame = tso->su;
3836 bottom = &(tso->stack[tso->stack_size]);
3839 /* There must be at least one frame, namely the STOP_FRAME.
3841 ASSERT((P_)frame < bottom);
3843 /* Walk down the stack, reversing the links between frames so that
3844 * we can walk back up as we squeeze from the bottom. Note that
3845 * next_frame and prev_frame refer to next and previous as they were
3846 * added to the stack, rather than the way we see them in this
3847 * walk. (It makes the next loop less confusing.)
3849 * Stop if we find an update frame pointing to a black hole
3850 * (see comment in threadLazyBlackHole()).
3854 // bottom - sizeof(StgStopFrame) is the STOP_FRAME
3855 while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
3856 prev_frame = frame->link;
3857 frame->link = next_frame;
3862 if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
3863 printObj((StgClosure *)prev_frame);
3864 barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
3867 switch (get_itbl(frame)->type) {
3870 if (frame->updatee->header.info == &stg_BLACKHOLE_info)
3883 barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
3885 printObj((StgClosure *)prev_frame);
3888 if (get_itbl(frame)->type == UPDATE_FRAME
3889 && frame->updatee->header.info == &stg_BLACKHOLE_info) {
3894 /* Now, we're at the bottom. Frame points to the lowest update
3895 * frame on the stack, and its link actually points to the frame
3896 * above. We have to walk back up the stack, squeezing out empty
3897 * update frames and turning the pointers back around on the way
3900 * The bottom-most frame (the STOP_FRAME) has not been altered, and
3901 * we never want to eliminate it anyway. Just walk one step up
3902 * before starting to squeeze. When you get to the topmost frame,
3903 * remember that there are still some words above it that might have
3910 prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
3913 * Loop through all of the frames (everything except the very
3914 * bottom). Things are complicated by the fact that we have
3915 * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
3916 * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
3918 while (frame != NULL) {
3920 StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
3921 rtsBool is_update_frame;
3923 next_frame = frame->link;
3924 is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
3927 * 1. both the previous and current frame are update frames
3928 * 2. the current frame is empty
3930 if (prev_was_update_frame && is_update_frame &&
3931 (P_)prev_frame == frame_bottom + displacement) {
3933 // Now squeeze out the current frame
3934 StgClosure *updatee_keep = prev_frame->updatee;
3935 StgClosure *updatee_bypass = frame->updatee;
3938 IF_DEBUG(gc, belch("@@ squeezing frame at %p", frame));
3942 /* Deal with blocking queues. If both updatees have blocked
3943 * threads, then we should merge the queues into the update
3944 * frame that we're keeping.
3946 * Alternatively, we could just wake them up: they'll just go
3947 * straight to sleep on the proper blackhole! This is less code
3948 * and probably less bug prone, although it's probably much
3951 #if 0 // do it properly...
3952 # if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3953 # error Unimplemented lazy BH warning. (KSW 1999-01)
3955 if (GET_INFO(updatee_bypass) == stg_BLACKHOLE_BQ_info
3956 || GET_INFO(updatee_bypass) == stg_CAF_BLACKHOLE_info
3958 // Sigh. It has one. Don't lose those threads!
3959 if (GET_INFO(updatee_keep) == stg_BLACKHOLE_BQ_info) {
3960 // Urgh. Two queues. Merge them.
3961 P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
3963 while (keep_tso->link != END_TSO_QUEUE) {
3964 keep_tso = keep_tso->link;
3966 keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
3969 // For simplicity, just swap the BQ for the BH
3970 P_ temp = updatee_keep;
3972 updatee_keep = updatee_bypass;
3973 updatee_bypass = temp;
3975 // Record the swap in the kept frame (below)
3976 prev_frame->updatee = updatee_keep;
3981 TICK_UPD_SQUEEZED();
3982 /* wasn't there something about update squeezing and ticky to be
3983 * sorted out? oh yes: we aren't counting each enter properly
3984 * in this case. See the log somewhere. KSW 1999-04-21
3986 * Check two things: that the two update frames don't point to
3987 * the same object, and that the updatee_bypass isn't already an
3988 * indirection. Both of these cases only happen when we're in a
3989 * block hole-style loop (and there are multiple update frames
3990 * on the stack pointing to the same closure), but they can both
3991 * screw us up if we don't check.
3993 if (updatee_bypass != updatee_keep && !closure_IND(updatee_bypass)) {
3994 // this wakes the threads up
3995 UPD_IND_NOLOCK(updatee_bypass, updatee_keep);
3998 sp = (P_)frame - 1; // sp = stuff to slide
3999 displacement += sizeofW(StgUpdateFrame);
4002 // No squeeze for this frame
4003 sp = frame_bottom - 1; // Keep the current frame
4005 /* Do lazy black-holing.
4007 if (is_update_frame) {
4008 StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
4009 if (bh->header.info != &stg_BLACKHOLE_info &&
4010 bh->header.info != &stg_BLACKHOLE_BQ_info &&
4011 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4012 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4013 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4016 /* zero out the slop so that the sanity checker can tell
4017 * where the next closure is.
4020 StgInfoTable *info = get_itbl(bh);
4021 nat np = info->layout.payload.ptrs, nw = info->layout.payload.nptrs, i;
4022 /* don't zero out slop for a THUNK_SELECTOR, because its layout
4023 * info is used for a different purpose, and it's exactly the
4024 * same size as a BLACKHOLE in any case.
4026 if (info->type != THUNK_SELECTOR) {
4027 for (i = np; i < np + nw; i++) {
4028 ((StgClosure *)bh)->payload[i] = 0;
4035 // We pretend that bh is now dead.
4036 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4039 // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
4041 SET_INFO(bh,&stg_BLACKHOLE_info);
4044 // We pretend that bh has just been created.
4045 LDV_recordCreate(bh);
4050 // Fix the link in the current frame (should point to the frame below)
4051 frame->link = prev_frame;
4052 prev_was_update_frame = is_update_frame;
4055 // Now slide all words from sp up to the next frame
4057 if (displacement > 0) {
4058 P_ next_frame_bottom;
4060 if (next_frame != NULL)
4061 next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
4063 next_frame_bottom = tso->sp - 1;
4067 belch("sliding [%p, %p] by %ld", sp, next_frame_bottom,
4071 while (sp >= next_frame_bottom) {
4072 sp[displacement] = *sp;
4076 (P_)prev_frame = (P_)frame + displacement;
4080 tso->sp += displacement;
4081 tso->su = prev_frame;
4084 belch("@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames",
4085 squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
4090 /* -----------------------------------------------------------------------------
4093 * We have to prepare for GC - this means doing lazy black holing
4094 * here. We also take the opportunity to do stack squeezing if it's
4096 * -------------------------------------------------------------------------- */
4098 threadPaused(StgTSO *tso)
4100 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4101 threadSqueezeStack(tso); // does black holing too
4103 threadLazyBlackHole(tso);
4106 /* -----------------------------------------------------------------------------
4108 * -------------------------------------------------------------------------- */
4112 printMutOnceList(generation *gen)
4114 StgMutClosure *p, *next;
4116 p = gen->mut_once_list;
4119 fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4120 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4121 fprintf(stderr, "%p (%s), ",
4122 p, info_type((StgClosure *)p));
4124 fputc('\n', stderr);
4128 printMutableList(generation *gen)
4130 StgMutClosure *p, *next;
4135 fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4136 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4137 fprintf(stderr, "%p (%s), ",
4138 p, info_type((StgClosure *)p));
4140 fputc('\n', stderr);
4143 static inline rtsBool
4144 maybeLarge(StgClosure *closure)
4146 StgInfoTable *info = get_itbl(closure);
4148 /* closure types that may be found on the new_large_objects list;
4149 see scavenge_large */
4150 return (info->type == MUT_ARR_PTRS ||
4151 info->type == MUT_ARR_PTRS_FROZEN ||
4152 info->type == TSO ||
4153 info->type == ARR_WORDS);