1 /* -----------------------------------------------------------------------------
2 * $Id: GC.c,v 1.144 2002/09/25 14:46:34 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 p->header.info = &stg_EVACUATED_info;
1386 ((StgEvacuated *)p)->evacuee = dest;
1390 static __inline__ StgClosure *
1391 copy(StgClosure *src, nat size, step *stp)
1396 nat size_org = size;
1399 TICK_GC_WORDS_COPIED(size);
1400 /* Find out where we're going, using the handy "to" pointer in
1401 * the step of the source object. If it turns out we need to
1402 * evacuate to an older generation, adjust it here (see comment
1405 if (stp->gen_no < evac_gen) {
1406 #ifdef NO_EAGER_PROMOTION
1407 failed_to_evac = rtsTrue;
1409 stp = &generations[evac_gen].steps[0];
1413 /* chain a new block onto the to-space for the destination step if
1416 if (stp->hp + size >= stp->hpLim) {
1420 for(to = stp->hp, from = (P_)src; size>0; --size) {
1426 upd_evacuee(src,(StgClosure *)dest);
1428 // We store the size of the just evacuated object in the LDV word so that
1429 // the profiler can guess the position of the next object later.
1430 SET_EVACUAEE_FOR_LDV(src, size_org);
1432 return (StgClosure *)dest;
1435 /* Special version of copy() for when we only want to copy the info
1436 * pointer of an object, but reserve some padding after it. This is
1437 * used to optimise evacuation of BLACKHOLEs.
1442 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1447 nat size_to_copy_org = size_to_copy;
1450 TICK_GC_WORDS_COPIED(size_to_copy);
1451 if (stp->gen_no < evac_gen) {
1452 #ifdef NO_EAGER_PROMOTION
1453 failed_to_evac = rtsTrue;
1455 stp = &generations[evac_gen].steps[0];
1459 if (stp->hp + size_to_reserve >= stp->hpLim) {
1463 for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1468 stp->hp += size_to_reserve;
1469 upd_evacuee(src,(StgClosure *)dest);
1471 // We store the size of the just evacuated object in the LDV word so that
1472 // the profiler can guess the position of the next object later.
1473 // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1475 SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1477 if (size_to_reserve - size_to_copy_org > 0)
1478 FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1480 return (StgClosure *)dest;
1484 /* -----------------------------------------------------------------------------
1485 Evacuate a large object
1487 This just consists of removing the object from the (doubly-linked)
1488 step->large_objects list, and linking it on to the (singly-linked)
1489 step->new_large_objects list, from where it will be scavenged later.
1491 Convention: bd->flags has BF_EVACUATED set for a large object
1492 that has been evacuated, or unset otherwise.
1493 -------------------------------------------------------------------------- */
1497 evacuate_large(StgPtr p)
1499 bdescr *bd = Bdescr(p);
1502 // object must be at the beginning of the block (or be a ByteArray)
1503 ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1504 (((W_)p & BLOCK_MASK) == 0));
1506 // already evacuated?
1507 if (bd->flags & BF_EVACUATED) {
1508 /* Don't forget to set the failed_to_evac flag if we didn't get
1509 * the desired destination (see comments in evacuate()).
1511 if (bd->gen_no < evac_gen) {
1512 failed_to_evac = rtsTrue;
1513 TICK_GC_FAILED_PROMOTION();
1519 // remove from large_object list
1521 bd->u.back->link = bd->link;
1522 } else { // first object in the list
1523 stp->large_objects = bd->link;
1526 bd->link->u.back = bd->u.back;
1529 /* link it on to the evacuated large object list of the destination step
1532 if (stp->gen_no < evac_gen) {
1533 #ifdef NO_EAGER_PROMOTION
1534 failed_to_evac = rtsTrue;
1536 stp = &generations[evac_gen].steps[0];
1541 bd->gen_no = stp->gen_no;
1542 bd->link = stp->new_large_objects;
1543 stp->new_large_objects = bd;
1544 bd->flags |= BF_EVACUATED;
1547 /* -----------------------------------------------------------------------------
1548 Adding a MUT_CONS to an older generation.
1550 This is necessary from time to time when we end up with an
1551 old-to-new generation pointer in a non-mutable object. We defer
1552 the promotion until the next GC.
1553 -------------------------------------------------------------------------- */
1557 mkMutCons(StgClosure *ptr, generation *gen)
1562 stp = &gen->steps[0];
1564 /* chain a new block onto the to-space for the destination step if
1567 if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
1571 q = (StgMutVar *)stp->hp;
1572 stp->hp += sizeofW(StgMutVar);
1574 SET_HDR(q,&stg_MUT_CONS_info,CCS_GC);
1576 recordOldToNewPtrs((StgMutClosure *)q);
1578 return (StgClosure *)q;
1581 /* -----------------------------------------------------------------------------
1584 This is called (eventually) for every live object in the system.
1586 The caller to evacuate specifies a desired generation in the
1587 evac_gen global variable. The following conditions apply to
1588 evacuating an object which resides in generation M when we're
1589 collecting up to generation N
1593 else evac to step->to
1595 if M < evac_gen evac to evac_gen, step 0
1597 if the object is already evacuated, then we check which generation
1600 if M >= evac_gen do nothing
1601 if M < evac_gen set failed_to_evac flag to indicate that we
1602 didn't manage to evacuate this object into evac_gen.
1604 -------------------------------------------------------------------------- */
1607 evacuate(StgClosure *q)
1612 const StgInfoTable *info;
1615 if (HEAP_ALLOCED(q)) {
1618 if (bd->gen_no > N) {
1619 /* Can't evacuate this object, because it's in a generation
1620 * older than the ones we're collecting. Let's hope that it's
1621 * in evac_gen or older, or we will have to arrange to track
1622 * this pointer using the mutable list.
1624 if (bd->gen_no < evac_gen) {
1626 failed_to_evac = rtsTrue;
1627 TICK_GC_FAILED_PROMOTION();
1632 /* evacuate large objects by re-linking them onto a different list.
1634 if (bd->flags & BF_LARGE) {
1636 if (info->type == TSO &&
1637 ((StgTSO *)q)->what_next == ThreadRelocated) {
1638 q = (StgClosure *)((StgTSO *)q)->link;
1641 evacuate_large((P_)q);
1645 /* If the object is in a step that we're compacting, then we
1646 * need to use an alternative evacuate procedure.
1648 if (bd->step->is_compacted) {
1649 if (!is_marked((P_)q,bd)) {
1651 if (mark_stack_full()) {
1652 mark_stack_overflowed = rtsTrue;
1655 push_mark_stack((P_)q);
1663 else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1666 // make sure the info pointer is into text space
1667 ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1668 || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1671 switch (info -> type) {
1675 to = copy(q,sizeW_fromITBL(info),stp);
1680 StgWord w = (StgWord)q->payload[0];
1681 if (q->header.info == Czh_con_info &&
1682 // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
1683 (StgChar)w <= MAX_CHARLIKE) {
1684 return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1686 if (q->header.info == Izh_con_info &&
1687 (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1688 return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1690 // else, fall through ...
1696 return copy(q,sizeofW(StgHeader)+1,stp);
1698 case THUNK_1_0: // here because of MIN_UPD_SIZE
1703 #ifdef NO_PROMOTE_THUNKS
1704 if (bd->gen_no == 0 &&
1705 bd->step->no != 0 &&
1706 bd->step->no == generations[bd->gen_no].n_steps-1) {
1710 return copy(q,sizeofW(StgHeader)+2,stp);
1718 return copy(q,sizeofW(StgHeader)+2,stp);
1724 case IND_OLDGEN_PERM:
1729 return copy(q,sizeW_fromITBL(info),stp);
1732 case SE_CAF_BLACKHOLE:
1735 return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1738 to = copy(q,BLACKHOLE_sizeW(),stp);
1741 case THUNK_SELECTOR:
1745 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
1746 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1749 p = eval_thunk_selector(info->layout.selector_offset,
1753 return copy(q,THUNK_SELECTOR_sizeW(),stp);
1755 // q is still BLACKHOLE'd.
1756 thunk_selector_depth++;
1758 thunk_selector_depth--;
1766 // follow chains of indirections, don't evacuate them
1767 q = ((StgInd*)q)->indirectee;
1771 if (info->srt_len > 0 && major_gc &&
1772 THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1773 THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1774 static_objects = (StgClosure *)q;
1779 if (info->srt_len > 0 && major_gc &&
1780 FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1781 FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1782 static_objects = (StgClosure *)q;
1787 /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1788 * on the CAF list, so don't do anything with it here (we'll
1789 * scavenge it later).
1792 && ((StgIndStatic *)q)->saved_info == NULL
1793 && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1794 IND_STATIC_LINK((StgClosure *)q) = static_objects;
1795 static_objects = (StgClosure *)q;
1800 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1801 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1802 static_objects = (StgClosure *)q;
1806 case CONSTR_INTLIKE:
1807 case CONSTR_CHARLIKE:
1808 case CONSTR_NOCAF_STATIC:
1809 /* no need to put these on the static linked list, they don't need
1824 // shouldn't see these
1825 barf("evacuate: stack frame at %p\n", q);
1829 /* PAPs and AP_UPDs are special - the payload is a copy of a chunk
1830 * of stack, tagging and all.
1832 return copy(q,pap_sizeW((StgPAP*)q),stp);
1835 /* Already evacuated, just return the forwarding address.
1836 * HOWEVER: if the requested destination generation (evac_gen) is
1837 * older than the actual generation (because the object was
1838 * already evacuated to a younger generation) then we have to
1839 * set the failed_to_evac flag to indicate that we couldn't
1840 * manage to promote the object to the desired generation.
1842 if (evac_gen > 0) { // optimisation
1843 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1844 if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
1845 failed_to_evac = rtsTrue;
1846 TICK_GC_FAILED_PROMOTION();
1849 return ((StgEvacuated*)q)->evacuee;
1852 // just copy the block
1853 return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1856 case MUT_ARR_PTRS_FROZEN:
1857 // just copy the block
1858 return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1862 StgTSO *tso = (StgTSO *)q;
1864 /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1866 if (tso->what_next == ThreadRelocated) {
1867 q = (StgClosure *)tso->link;
1871 /* To evacuate a small TSO, we need to relocate the update frame
1875 StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),stp);
1876 move_TSO(tso, new_tso);
1877 return (StgClosure *)new_tso;
1882 case RBH: // cf. BLACKHOLE_BQ
1884 //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1885 to = copy(q,BLACKHOLE_sizeW(),stp);
1886 //ToDo: derive size etc from reverted IP
1887 //to = copy(q,size,stp);
1889 belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1890 q, info_type(q), to, info_type(to)));
1895 ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1896 to = copy(q,sizeofW(StgBlockedFetch),stp);
1898 belch("@@ evacuate: %p (%s) to %p (%s)",
1899 q, info_type(q), to, info_type(to)));
1906 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1907 to = copy(q,sizeofW(StgFetchMe),stp);
1909 belch("@@ evacuate: %p (%s) to %p (%s)",
1910 q, info_type(q), to, info_type(to)));
1914 ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1915 to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1917 belch("@@ evacuate: %p (%s) to %p (%s)",
1918 q, info_type(q), to, info_type(to)));
1923 barf("evacuate: strange closure type %d", (int)(info->type));
1929 /* -----------------------------------------------------------------------------
1930 Evaluate a THUNK_SELECTOR if possible.
1932 returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
1933 a closure pointer if we evaluated it and this is the result. Note
1934 that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
1935 reducing it to HNF, just that we have eliminated the selection.
1936 The result might be another thunk, or even another THUNK_SELECTOR.
1938 If the return value is non-NULL, the original selector thunk has
1939 been BLACKHOLE'd, and should be updated with an indirection or a
1940 forwarding pointer. If the return value is NULL, then the selector
1942 -------------------------------------------------------------------------- */
1945 eval_thunk_selector( nat field, StgSelector * p )
1948 const StgInfoTable *info_ptr;
1949 StgClosure *selectee;
1951 selectee = p->selectee;
1953 // Save the real info pointer (NOTE: not the same as get_itbl()).
1954 info_ptr = p->header.info;
1956 // If the THUNK_SELECTOR is in a generation that we are not
1957 // collecting, then bail out early. We won't be able to save any
1958 // space in any case, and updating with an indirection is trickier
1960 if (Bdescr((StgPtr)p)->gen_no > N) {
1964 // BLACKHOLE the selector thunk, since it is now under evaluation.
1965 // This is important to stop us going into an infinite loop if
1966 // this selector thunk eventually refers to itself.
1967 SET_INFO(p,&stg_BLACKHOLE_info);
1971 info = get_itbl(selectee);
1972 switch (info->type) {
1980 case CONSTR_NOCAF_STATIC:
1981 // check that the size is in range
1982 ASSERT(field < (StgWord32)(info->layout.payload.ptrs +
1983 info->layout.payload.nptrs));
1985 return selectee->payload[field];
1991 case IND_OLDGEN_PERM:
1992 selectee = ((StgInd *)selectee)->indirectee;
1996 // We don't follow pointers into to-space; the constructor
1997 // has already been evacuated, so we won't save any space
1998 // leaks by evaluating this selector thunk anyhow.
2001 case THUNK_SELECTOR:
2005 // check that we don't recurse too much, re-using the
2006 // depth bound also used in evacuate().
2007 thunk_selector_depth++;
2008 if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2012 val = eval_thunk_selector(info->layout.selector_offset,
2013 (StgSelector *)selectee);
2015 thunk_selector_depth--;
2020 // We evaluated this selector thunk, so update it with
2021 // an indirection. NOTE: we don't use UPD_IND here,
2022 // because we are guaranteed that p is in a generation
2023 // that we are collecting, and we never want to put the
2024 // indirection on a mutable list.
2025 ((StgInd *)selectee)->indirectee = val;
2026 SET_INFO(selectee,&stg_IND_info);
2041 case SE_CAF_BLACKHOLE:
2054 // not evaluated yet
2058 barf("eval_thunk_selector: strange selectee %d",
2062 // We didn't manage to evaluate this thunk; restore the old info pointer
2063 SET_INFO(p, info_ptr);
2067 /* -----------------------------------------------------------------------------
2068 move_TSO is called to update the TSO structure after it has been
2069 moved from one place to another.
2070 -------------------------------------------------------------------------- */
2073 move_TSO(StgTSO *src, StgTSO *dest)
2077 // relocate the stack pointers...
2078 diff = (StgPtr)dest - (StgPtr)src; // In *words*
2079 dest->sp = (StgPtr)dest->sp + diff;
2080 dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
2082 relocate_stack(dest, diff);
2085 /* -----------------------------------------------------------------------------
2086 relocate_stack is called to update the linkage between
2087 UPDATE_FRAMEs (and SEQ_FRAMEs etc.) when a stack is moved from one
2089 -------------------------------------------------------------------------- */
2092 relocate_stack(StgTSO *dest, ptrdiff_t diff)
2100 while ((P_)su < dest->stack + dest->stack_size) {
2101 switch (get_itbl(su)->type) {
2103 // GCC actually manages to common up these three cases!
2106 su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
2111 cf = (StgCatchFrame *)su;
2112 cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
2117 sf = (StgSeqFrame *)su;
2118 sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
2127 barf("relocate_stack %d", (int)(get_itbl(su)->type));
2138 scavenge_srt(const StgInfoTable *info)
2140 StgClosure **srt, **srt_end;
2142 /* evacuate the SRT. If srt_len is zero, then there isn't an
2143 * srt field in the info table. That's ok, because we'll
2144 * never dereference it.
2146 srt = (StgClosure **)(info->srt);
2147 srt_end = srt + info->srt_len;
2148 for (; srt < srt_end; srt++) {
2149 /* Special-case to handle references to closures hiding out in DLLs, since
2150 double indirections required to get at those. The code generator knows
2151 which is which when generating the SRT, so it stores the (indirect)
2152 reference to the DLL closure in the table by first adding one to it.
2153 We check for this here, and undo the addition before evacuating it.
2155 If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2156 closure that's fixed at link-time, and no extra magic is required.
2158 #ifdef ENABLE_WIN32_DLL_SUPPORT
2159 if ( (unsigned long)(*srt) & 0x1 ) {
2160 evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2170 /* -----------------------------------------------------------------------------
2172 -------------------------------------------------------------------------- */
2175 scavengeTSO (StgTSO *tso)
2177 // chase the link field for any TSOs on the same queue
2178 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2179 if ( tso->why_blocked == BlockedOnMVar
2180 || tso->why_blocked == BlockedOnBlackHole
2181 || tso->why_blocked == BlockedOnException
2183 || tso->why_blocked == BlockedOnGA
2184 || tso->why_blocked == BlockedOnGA_NoSend
2187 tso->block_info.closure = evacuate(tso->block_info.closure);
2189 if ( tso->blocked_exceptions != NULL ) {
2190 tso->blocked_exceptions =
2191 (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2193 // scavenge this thread's stack
2194 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2197 /* -----------------------------------------------------------------------------
2198 Scavenge a given step until there are no more objects in this step
2201 evac_gen is set by the caller to be either zero (for a step in a
2202 generation < N) or G where G is the generation of the step being
2205 We sometimes temporarily change evac_gen back to zero if we're
2206 scavenging a mutable object where early promotion isn't such a good
2208 -------------------------------------------------------------------------- */
2216 nat saved_evac_gen = evac_gen;
2221 failed_to_evac = rtsFalse;
2223 /* scavenge phase - standard breadth-first scavenging of the
2227 while (bd != stp->hp_bd || p < stp->hp) {
2229 // If we're at the end of this block, move on to the next block
2230 if (bd != stp->hp_bd && p == bd->free) {
2236 info = get_itbl((StgClosure *)p);
2237 ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2239 ASSERT(thunk_selector_depth == 0);
2242 switch (info->type) {
2245 /* treat MVars specially, because we don't want to evacuate the
2246 * mut_link field in the middle of the closure.
2249 StgMVar *mvar = ((StgMVar *)p);
2251 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2252 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2253 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2254 evac_gen = saved_evac_gen;
2255 recordMutable((StgMutClosure *)mvar);
2256 failed_to_evac = rtsFalse; // mutable.
2257 p += sizeofW(StgMVar);
2265 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2266 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2267 p += sizeofW(StgHeader) + 2;
2272 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2273 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2279 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2280 p += sizeofW(StgHeader) + 1;
2285 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2291 p += sizeofW(StgHeader) + 1;
2298 p += sizeofW(StgHeader) + 2;
2305 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2306 p += sizeofW(StgHeader) + 2;
2322 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2323 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2324 (StgClosure *)*p = evacuate((StgClosure *)*p);
2326 p += info->layout.payload.nptrs;
2331 if (stp->gen->no != 0) {
2334 // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2335 // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2336 LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2339 // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
2341 SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2344 // We pretend that p has just been created.
2345 LDV_recordCreate((StgClosure *)p);
2349 case IND_OLDGEN_PERM:
2350 ((StgIndOldGen *)p)->indirectee =
2351 evacuate(((StgIndOldGen *)p)->indirectee);
2352 if (failed_to_evac) {
2353 failed_to_evac = rtsFalse;
2354 recordOldToNewPtrs((StgMutClosure *)p);
2356 p += sizeofW(StgIndOldGen);
2361 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2362 evac_gen = saved_evac_gen;
2363 recordMutable((StgMutClosure *)p);
2364 failed_to_evac = rtsFalse; // mutable anyhow
2365 p += sizeofW(StgMutVar);
2370 failed_to_evac = rtsFalse; // mutable anyhow
2371 p += sizeofW(StgMutVar);
2375 case SE_CAF_BLACKHOLE:
2378 p += BLACKHOLE_sizeW();
2383 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2384 (StgClosure *)bh->blocking_queue =
2385 evacuate((StgClosure *)bh->blocking_queue);
2386 recordMutable((StgMutClosure *)bh);
2387 failed_to_evac = rtsFalse;
2388 p += BLACKHOLE_sizeW();
2392 case THUNK_SELECTOR:
2394 StgSelector *s = (StgSelector *)p;
2395 s->selectee = evacuate(s->selectee);
2396 p += THUNK_SELECTOR_sizeW();
2400 case AP_UPD: // same as PAPs
2402 /* Treat a PAP just like a section of stack, not forgetting to
2403 * evacuate the function pointer too...
2406 StgPAP* pap = (StgPAP *)p;
2408 pap->fun = evacuate(pap->fun);
2409 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2410 p += pap_sizeW(pap);
2415 // nothing to follow
2416 p += arr_words_sizeW((StgArrWords *)p);
2420 // follow everything
2424 evac_gen = 0; // repeatedly mutable
2425 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2426 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2427 (StgClosure *)*p = evacuate((StgClosure *)*p);
2429 evac_gen = saved_evac_gen;
2430 recordMutable((StgMutClosure *)q);
2431 failed_to_evac = rtsFalse; // mutable anyhow.
2435 case MUT_ARR_PTRS_FROZEN:
2436 // follow everything
2440 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2441 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2442 (StgClosure *)*p = evacuate((StgClosure *)*p);
2444 // it's tempting to recordMutable() if failed_to_evac is
2445 // false, but that breaks some assumptions (eg. every
2446 // closure on the mutable list is supposed to have the MUT
2447 // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2453 StgTSO *tso = (StgTSO *)p;
2456 evac_gen = saved_evac_gen;
2457 recordMutable((StgMutClosure *)tso);
2458 failed_to_evac = rtsFalse; // mutable anyhow.
2459 p += tso_sizeW(tso);
2464 case RBH: // cf. BLACKHOLE_BQ
2467 nat size, ptrs, nonptrs, vhs;
2469 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2471 StgRBH *rbh = (StgRBH *)p;
2472 (StgClosure *)rbh->blocking_queue =
2473 evacuate((StgClosure *)rbh->blocking_queue);
2474 recordMutable((StgMutClosure *)to);
2475 failed_to_evac = rtsFalse; // mutable anyhow.
2477 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2478 p, info_type(p), (StgClosure *)rbh->blocking_queue));
2479 // ToDo: use size of reverted closure here!
2480 p += BLACKHOLE_sizeW();
2486 StgBlockedFetch *bf = (StgBlockedFetch *)p;
2487 // follow the pointer to the node which is being demanded
2488 (StgClosure *)bf->node =
2489 evacuate((StgClosure *)bf->node);
2490 // follow the link to the rest of the blocking queue
2491 (StgClosure *)bf->link =
2492 evacuate((StgClosure *)bf->link);
2493 if (failed_to_evac) {
2494 failed_to_evac = rtsFalse;
2495 recordMutable((StgMutClosure *)bf);
2498 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2499 bf, info_type((StgClosure *)bf),
2500 bf->node, info_type(bf->node)));
2501 p += sizeofW(StgBlockedFetch);
2509 p += sizeofW(StgFetchMe);
2510 break; // nothing to do in this case
2512 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2514 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2515 (StgClosure *)fmbq->blocking_queue =
2516 evacuate((StgClosure *)fmbq->blocking_queue);
2517 if (failed_to_evac) {
2518 failed_to_evac = rtsFalse;
2519 recordMutable((StgMutClosure *)fmbq);
2522 belch("@@ scavenge: %p (%s) exciting, isn't it",
2523 p, info_type((StgClosure *)p)));
2524 p += sizeofW(StgFetchMeBlockingQueue);
2530 barf("scavenge: unimplemented/strange closure type %d @ %p",
2534 /* If we didn't manage to promote all the objects pointed to by
2535 * the current object, then we have to designate this object as
2536 * mutable (because it contains old-to-new generation pointers).
2538 if (failed_to_evac) {
2539 failed_to_evac = rtsFalse;
2540 mkMutCons((StgClosure *)q, &generations[evac_gen]);
2548 /* -----------------------------------------------------------------------------
2549 Scavenge everything on the mark stack.
2551 This is slightly different from scavenge():
2552 - we don't walk linearly through the objects, so the scavenger
2553 doesn't need to advance the pointer on to the next object.
2554 -------------------------------------------------------------------------- */
2557 scavenge_mark_stack(void)
2563 evac_gen = oldest_gen->no;
2564 saved_evac_gen = evac_gen;
2567 while (!mark_stack_empty()) {
2568 p = pop_mark_stack();
2570 info = get_itbl((StgClosure *)p);
2571 ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2574 switch (info->type) {
2577 /* treat MVars specially, because we don't want to evacuate the
2578 * mut_link field in the middle of the closure.
2581 StgMVar *mvar = ((StgMVar *)p);
2583 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2584 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2585 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2586 evac_gen = saved_evac_gen;
2587 failed_to_evac = rtsFalse; // mutable.
2595 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2596 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2606 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2631 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2632 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2633 (StgClosure *)*p = evacuate((StgClosure *)*p);
2639 // don't need to do anything here: the only possible case
2640 // is that we're in a 1-space compacting collector, with
2641 // no "old" generation.
2645 case IND_OLDGEN_PERM:
2646 ((StgIndOldGen *)p)->indirectee =
2647 evacuate(((StgIndOldGen *)p)->indirectee);
2648 if (failed_to_evac) {
2649 recordOldToNewPtrs((StgMutClosure *)p);
2651 failed_to_evac = rtsFalse;
2656 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2657 evac_gen = saved_evac_gen;
2658 failed_to_evac = rtsFalse;
2663 failed_to_evac = rtsFalse;
2667 case SE_CAF_BLACKHOLE:
2675 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2676 (StgClosure *)bh->blocking_queue =
2677 evacuate((StgClosure *)bh->blocking_queue);
2678 failed_to_evac = rtsFalse;
2682 case THUNK_SELECTOR:
2684 StgSelector *s = (StgSelector *)p;
2685 s->selectee = evacuate(s->selectee);
2689 case AP_UPD: // same as PAPs
2691 /* Treat a PAP just like a section of stack, not forgetting to
2692 * evacuate the function pointer too...
2695 StgPAP* pap = (StgPAP *)p;
2697 pap->fun = evacuate(pap->fun);
2698 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2703 // follow everything
2707 evac_gen = 0; // repeatedly mutable
2708 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2709 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2710 (StgClosure *)*p = evacuate((StgClosure *)*p);
2712 evac_gen = saved_evac_gen;
2713 failed_to_evac = rtsFalse; // mutable anyhow.
2717 case MUT_ARR_PTRS_FROZEN:
2718 // follow everything
2722 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2723 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2724 (StgClosure *)*p = evacuate((StgClosure *)*p);
2731 StgTSO *tso = (StgTSO *)p;
2734 evac_gen = saved_evac_gen;
2735 failed_to_evac = rtsFalse;
2740 case RBH: // cf. BLACKHOLE_BQ
2743 nat size, ptrs, nonptrs, vhs;
2745 StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2747 StgRBH *rbh = (StgRBH *)p;
2748 (StgClosure *)rbh->blocking_queue =
2749 evacuate((StgClosure *)rbh->blocking_queue);
2750 recordMutable((StgMutClosure *)rbh);
2751 failed_to_evac = rtsFalse; // mutable anyhow.
2753 belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2754 p, info_type(p), (StgClosure *)rbh->blocking_queue));
2760 StgBlockedFetch *bf = (StgBlockedFetch *)p;
2761 // follow the pointer to the node which is being demanded
2762 (StgClosure *)bf->node =
2763 evacuate((StgClosure *)bf->node);
2764 // follow the link to the rest of the blocking queue
2765 (StgClosure *)bf->link =
2766 evacuate((StgClosure *)bf->link);
2767 if (failed_to_evac) {
2768 failed_to_evac = rtsFalse;
2769 recordMutable((StgMutClosure *)bf);
2772 belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2773 bf, info_type((StgClosure *)bf),
2774 bf->node, info_type(bf->node)));
2782 break; // nothing to do in this case
2784 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2786 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2787 (StgClosure *)fmbq->blocking_queue =
2788 evacuate((StgClosure *)fmbq->blocking_queue);
2789 if (failed_to_evac) {
2790 failed_to_evac = rtsFalse;
2791 recordMutable((StgMutClosure *)fmbq);
2794 belch("@@ scavenge: %p (%s) exciting, isn't it",
2795 p, info_type((StgClosure *)p)));
2801 barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
2805 if (failed_to_evac) {
2806 failed_to_evac = rtsFalse;
2807 mkMutCons((StgClosure *)q, &generations[evac_gen]);
2810 // mark the next bit to indicate "scavenged"
2811 mark(q+1, Bdescr(q));
2813 } // while (!mark_stack_empty())
2815 // start a new linear scan if the mark stack overflowed at some point
2816 if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
2817 IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
2818 mark_stack_overflowed = rtsFalse;
2819 oldgen_scan_bd = oldest_gen->steps[0].blocks;
2820 oldgen_scan = oldgen_scan_bd->start;
2823 if (oldgen_scan_bd) {
2824 // push a new thing on the mark stack
2826 // find a closure that is marked but not scavenged, and start
2828 while (oldgen_scan < oldgen_scan_bd->free
2829 && !is_marked(oldgen_scan,oldgen_scan_bd)) {
2833 if (oldgen_scan < oldgen_scan_bd->free) {
2835 // already scavenged?
2836 if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
2837 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2840 push_mark_stack(oldgen_scan);
2841 // ToDo: bump the linear scan by the actual size of the object
2842 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2846 oldgen_scan_bd = oldgen_scan_bd->link;
2847 if (oldgen_scan_bd != NULL) {
2848 oldgen_scan = oldgen_scan_bd->start;
2854 /* -----------------------------------------------------------------------------
2855 Scavenge one object.
2857 This is used for objects that are temporarily marked as mutable
2858 because they contain old-to-new generation pointers. Only certain
2859 objects can have this property.
2860 -------------------------------------------------------------------------- */
2863 scavenge_one(StgPtr p)
2865 const StgInfoTable *info;
2866 nat saved_evac_gen = evac_gen;
2869 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
2870 || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
2872 info = get_itbl((StgClosure *)p);
2874 switch (info->type) {
2877 case FUN_1_0: // hardly worth specialising these guys
2897 case IND_OLDGEN_PERM:
2901 end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2902 for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
2903 (StgClosure *)*q = evacuate((StgClosure *)*q);
2909 case SE_CAF_BLACKHOLE:
2914 case THUNK_SELECTOR:
2916 StgSelector *s = (StgSelector *)p;
2917 s->selectee = evacuate(s->selectee);
2922 // nothing to follow
2927 // follow everything
2930 evac_gen = 0; // repeatedly mutable
2931 recordMutable((StgMutClosure *)p);
2932 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2933 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2934 (StgClosure *)*p = evacuate((StgClosure *)*p);
2936 evac_gen = saved_evac_gen;
2937 failed_to_evac = rtsFalse;
2941 case MUT_ARR_PTRS_FROZEN:
2943 // follow everything
2946 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2947 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2948 (StgClosure *)*p = evacuate((StgClosure *)*p);
2955 StgTSO *tso = (StgTSO *)p;
2957 evac_gen = 0; // repeatedly mutable
2959 recordMutable((StgMutClosure *)tso);
2960 evac_gen = saved_evac_gen;
2961 failed_to_evac = rtsFalse;
2968 StgPAP* pap = (StgPAP *)p;
2969 pap->fun = evacuate(pap->fun);
2970 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2975 // This might happen if for instance a MUT_CONS was pointing to a
2976 // THUNK which has since been updated. The IND_OLDGEN will
2977 // be on the mutable list anyway, so we don't need to do anything
2982 barf("scavenge_one: strange object %d", (int)(info->type));
2985 no_luck = failed_to_evac;
2986 failed_to_evac = rtsFalse;
2990 /* -----------------------------------------------------------------------------
2991 Scavenging mutable lists.
2993 We treat the mutable list of each generation > N (i.e. all the
2994 generations older than the one being collected) as roots. We also
2995 remove non-mutable objects from the mutable list at this point.
2996 -------------------------------------------------------------------------- */
2999 scavenge_mut_once_list(generation *gen)
3001 const StgInfoTable *info;
3002 StgMutClosure *p, *next, *new_list;
3004 p = gen->mut_once_list;
3005 new_list = END_MUT_LIST;
3009 failed_to_evac = rtsFalse;
3011 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3013 // make sure the info pointer is into text space
3014 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3015 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3019 if (info->type==RBH)
3020 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3022 switch(info->type) {
3025 case IND_OLDGEN_PERM:
3027 /* Try to pull the indirectee into this generation, so we can
3028 * remove the indirection from the mutable list.
3030 ((StgIndOldGen *)p)->indirectee =
3031 evacuate(((StgIndOldGen *)p)->indirectee);
3033 #if 0 && defined(DEBUG)
3034 if (RtsFlags.DebugFlags.gc)
3035 /* Debugging code to print out the size of the thing we just
3039 StgPtr start = gen->steps[0].scan;
3040 bdescr *start_bd = gen->steps[0].scan_bd;
3042 scavenge(&gen->steps[0]);
3043 if (start_bd != gen->steps[0].scan_bd) {
3044 size += (P_)BLOCK_ROUND_UP(start) - start;
3045 start_bd = start_bd->link;
3046 while (start_bd != gen->steps[0].scan_bd) {
3047 size += BLOCK_SIZE_W;
3048 start_bd = start_bd->link;
3050 size += gen->steps[0].scan -
3051 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3053 size = gen->steps[0].scan - start;
3055 belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3059 /* failed_to_evac might happen if we've got more than two
3060 * generations, we're collecting only generation 0, the
3061 * indirection resides in generation 2 and the indirectee is
3064 if (failed_to_evac) {
3065 failed_to_evac = rtsFalse;
3066 p->mut_link = new_list;
3069 /* the mut_link field of an IND_STATIC is overloaded as the
3070 * static link field too (it just so happens that we don't need
3071 * both at the same time), so we need to NULL it out when
3072 * removing this object from the mutable list because the static
3073 * link fields are all assumed to be NULL before doing a major
3081 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3082 * it from the mutable list if possible by promoting whatever it
3085 if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3086 /* didn't manage to promote everything, so put the
3087 * MUT_CONS back on the list.
3089 p->mut_link = new_list;
3095 // shouldn't have anything else on the mutables list
3096 barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3100 gen->mut_once_list = new_list;
3105 scavenge_mutable_list(generation *gen)
3107 const StgInfoTable *info;
3108 StgMutClosure *p, *next;
3110 p = gen->saved_mut_list;
3114 failed_to_evac = rtsFalse;
3116 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3118 // make sure the info pointer is into text space
3119 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3120 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3124 if (info->type==RBH)
3125 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3127 switch(info->type) {
3130 // follow everything
3131 p->mut_link = gen->mut_list;
3136 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3137 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3138 (StgClosure *)*q = evacuate((StgClosure *)*q);
3143 // Happens if a MUT_ARR_PTRS in the old generation is frozen
3144 case MUT_ARR_PTRS_FROZEN:
3149 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3150 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3151 (StgClosure *)*q = evacuate((StgClosure *)*q);
3155 if (failed_to_evac) {
3156 failed_to_evac = rtsFalse;
3157 mkMutCons((StgClosure *)p, gen);
3163 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3164 p->mut_link = gen->mut_list;
3170 StgMVar *mvar = (StgMVar *)p;
3171 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3172 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3173 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3174 p->mut_link = gen->mut_list;
3181 StgTSO *tso = (StgTSO *)p;
3185 /* Don't take this TSO off the mutable list - it might still
3186 * point to some younger objects (because we set evac_gen to 0
3189 tso->mut_link = gen->mut_list;
3190 gen->mut_list = (StgMutClosure *)tso;
3196 StgBlockingQueue *bh = (StgBlockingQueue *)p;
3197 (StgClosure *)bh->blocking_queue =
3198 evacuate((StgClosure *)bh->blocking_queue);
3199 p->mut_link = gen->mut_list;
3204 /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3207 case IND_OLDGEN_PERM:
3208 /* Try to pull the indirectee into this generation, so we can
3209 * remove the indirection from the mutable list.
3212 ((StgIndOldGen *)p)->indirectee =
3213 evacuate(((StgIndOldGen *)p)->indirectee);
3216 if (failed_to_evac) {
3217 failed_to_evac = rtsFalse;
3218 p->mut_link = gen->mut_once_list;
3219 gen->mut_once_list = p;
3226 // HWL: check whether all of these are necessary
3228 case RBH: // cf. BLACKHOLE_BQ
3230 // nat size, ptrs, nonptrs, vhs;
3232 // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3233 StgRBH *rbh = (StgRBH *)p;
3234 (StgClosure *)rbh->blocking_queue =
3235 evacuate((StgClosure *)rbh->blocking_queue);
3236 if (failed_to_evac) {
3237 failed_to_evac = rtsFalse;
3238 recordMutable((StgMutClosure *)rbh);
3240 // ToDo: use size of reverted closure here!
3241 p += BLACKHOLE_sizeW();
3247 StgBlockedFetch *bf = (StgBlockedFetch *)p;
3248 // follow the pointer to the node which is being demanded
3249 (StgClosure *)bf->node =
3250 evacuate((StgClosure *)bf->node);
3251 // follow the link to the rest of the blocking queue
3252 (StgClosure *)bf->link =
3253 evacuate((StgClosure *)bf->link);
3254 if (failed_to_evac) {
3255 failed_to_evac = rtsFalse;
3256 recordMutable((StgMutClosure *)bf);
3258 p += sizeofW(StgBlockedFetch);
3264 barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3267 p += sizeofW(StgFetchMe);
3268 break; // nothing to do in this case
3270 case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3272 StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3273 (StgClosure *)fmbq->blocking_queue =
3274 evacuate((StgClosure *)fmbq->blocking_queue);
3275 if (failed_to_evac) {
3276 failed_to_evac = rtsFalse;
3277 recordMutable((StgMutClosure *)fmbq);
3279 p += sizeofW(StgFetchMeBlockingQueue);
3285 // shouldn't have anything else on the mutables list
3286 barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3293 scavenge_static(void)
3295 StgClosure* p = static_objects;
3296 const StgInfoTable *info;
3298 /* Always evacuate straight to the oldest generation for static
3300 evac_gen = oldest_gen->no;
3302 /* keep going until we've scavenged all the objects on the linked
3304 while (p != END_OF_STATIC_LIST) {
3308 if (info->type==RBH)
3309 info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3311 // make sure the info pointer is into text space
3312 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3313 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3315 /* Take this object *off* the static_objects list,
3316 * and put it on the scavenged_static_objects list.
3318 static_objects = STATIC_LINK(info,p);
3319 STATIC_LINK(info,p) = scavenged_static_objects;
3320 scavenged_static_objects = p;
3322 switch (info -> type) {
3326 StgInd *ind = (StgInd *)p;
3327 ind->indirectee = evacuate(ind->indirectee);
3329 /* might fail to evacuate it, in which case we have to pop it
3330 * back on the mutable list (and take it off the
3331 * scavenged_static list because the static link and mut link
3332 * pointers are one and the same).
3334 if (failed_to_evac) {
3335 failed_to_evac = rtsFalse;
3336 scavenged_static_objects = IND_STATIC_LINK(p);
3337 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3338 oldest_gen->mut_once_list = (StgMutClosure *)ind;
3352 next = (P_)p->payload + info->layout.payload.ptrs;
3353 // evacuate the pointers
3354 for (q = (P_)p->payload; q < next; q++) {
3355 (StgClosure *)*q = evacuate((StgClosure *)*q);
3361 barf("scavenge_static: strange closure %d", (int)(info->type));
3364 ASSERT(failed_to_evac == rtsFalse);
3366 /* get the next static object from the list. Remember, there might
3367 * be more stuff on this list now that we've done some evacuating!
3368 * (static_objects is a global)
3374 /* -----------------------------------------------------------------------------
3375 scavenge_stack walks over a section of stack and evacuates all the
3376 objects pointed to by it. We can use the same code for walking
3377 PAPs, since these are just sections of copied stack.
3378 -------------------------------------------------------------------------- */
3381 scavenge_stack(StgPtr p, StgPtr stack_end)
3384 const StgInfoTable* info;
3387 //IF_DEBUG(sanity, belch(" scavenging stack between %p and %p", p, stack_end));
3390 * Each time around this loop, we are looking at a chunk of stack
3391 * that starts with either a pending argument section or an
3392 * activation record.
3395 while (p < stack_end) {
3398 // If we've got a tag, skip over that many words on the stack
3399 if (IS_ARG_TAG((W_)q)) {
3404 /* Is q a pointer to a closure?
3406 if (! LOOKS_LIKE_GHC_INFO(q) ) {
3408 if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) { // Is it a static closure?
3409 ASSERT(closure_STATIC((StgClosure *)q));
3411 // otherwise, must be a pointer into the allocation space.
3414 (StgClosure *)*p = evacuate((StgClosure *)q);
3420 * Otherwise, q must be the info pointer of an activation
3421 * record. All activation records have 'bitmap' style layout
3424 info = get_itbl((StgClosure *)p);
3426 switch (info->type) {
3428 // Dynamic bitmap: the mask is stored on the stack
3430 bitmap = ((StgRetDyn *)p)->liveness;
3431 p = (P_)&((StgRetDyn *)p)->payload[0];
3434 // probably a slow-entry point return address:
3442 belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
3443 old_p, p, old_p+1));
3445 p++; // what if FHS!=1 !? -- HWL
3450 /* Specialised code for update frames, since they're so common.
3451 * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
3452 * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
3456 StgUpdateFrame *frame = (StgUpdateFrame *)p;
3458 p += sizeofW(StgUpdateFrame);
3461 frame->updatee = evacuate(frame->updatee);
3463 #else // specialised code for update frames, not sure if it's worth it.
3465 nat type = get_itbl(frame->updatee)->type;
3467 if (type == EVACUATED) {
3468 frame->updatee = evacuate(frame->updatee);
3471 bdescr *bd = Bdescr((P_)frame->updatee);
3473 if (bd->gen_no > N) {
3474 if (bd->gen_no < evac_gen) {
3475 failed_to_evac = rtsTrue;
3480 // Don't promote blackholes
3482 if (!(stp->gen_no == 0 &&
3484 stp->no == stp->gen->n_steps-1)) {
3491 to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
3492 sizeofW(StgHeader), stp);
3493 frame->updatee = to;
3496 to = copy(frame->updatee, BLACKHOLE_sizeW(), stp);
3497 frame->updatee = to;
3498 recordMutable((StgMutClosure *)to);
3501 /* will never be SE_{,CAF_}BLACKHOLE, since we
3502 don't push an update frame for single-entry thunks. KSW 1999-01. */
3503 barf("scavenge_stack: UPDATE_FRAME updatee");
3509 // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3516 bitmap = info->layout.bitmap;
3518 // this assumes that the payload starts immediately after the info-ptr
3520 while (bitmap != 0) {
3521 if ((bitmap & 1) == 0) {
3522 (StgClosure *)*p = evacuate((StgClosure *)*p);
3525 bitmap = bitmap >> 1;
3532 // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3537 StgLargeBitmap *large_bitmap;
3540 large_bitmap = info->layout.large_bitmap;
3543 for (i=0; i<large_bitmap->size; i++) {
3544 bitmap = large_bitmap->bitmap[i];
3545 q = p + BITS_IN(W_);
3546 while (bitmap != 0) {
3547 if ((bitmap & 1) == 0) {
3548 (StgClosure *)*p = evacuate((StgClosure *)*p);
3551 bitmap = bitmap >> 1;
3553 if (i+1 < large_bitmap->size) {
3555 (StgClosure *)*p = evacuate((StgClosure *)*p);
3561 // and don't forget to follow the SRT
3566 barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->type));
3571 /*-----------------------------------------------------------------------------
3572 scavenge the large object list.
3574 evac_gen set by caller; similar games played with evac_gen as with
3575 scavenge() - see comment at the top of scavenge(). Most large
3576 objects are (repeatedly) mutable, so most of the time evac_gen will
3578 --------------------------------------------------------------------------- */
3581 scavenge_large(step *stp)
3586 bd = stp->new_large_objects;
3588 for (; bd != NULL; bd = stp->new_large_objects) {
3590 /* take this object *off* the large objects list and put it on
3591 * the scavenged large objects list. This is so that we can
3592 * treat new_large_objects as a stack and push new objects on
3593 * the front when evacuating.
3595 stp->new_large_objects = bd->link;
3596 dbl_link_onto(bd, &stp->scavenged_large_objects);
3598 // update the block count in this step.
3599 stp->n_scavenged_large_blocks += bd->blocks;
3602 if (scavenge_one(p)) {
3603 mkMutCons((StgClosure *)p, stp->gen);
3608 /* -----------------------------------------------------------------------------
3609 Initialising the static object & mutable lists
3610 -------------------------------------------------------------------------- */
3613 zero_static_object_list(StgClosure* first_static)
3617 const StgInfoTable *info;
3619 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3621 link = STATIC_LINK(info, p);
3622 STATIC_LINK(info,p) = NULL;
3626 /* This function is only needed because we share the mutable link
3627 * field with the static link field in an IND_STATIC, so we have to
3628 * zero the mut_link field before doing a major GC, which needs the
3629 * static link field.
3631 * It doesn't do any harm to zero all the mutable link fields on the
3636 zero_mutable_list( StgMutClosure *first )
3638 StgMutClosure *next, *c;
3640 for (c = first; c != END_MUT_LIST; c = next) {
3646 /* -----------------------------------------------------------------------------
3648 -------------------------------------------------------------------------- */
3655 for (c = (StgIndStatic *)caf_list; c != NULL;
3656 c = (StgIndStatic *)c->static_link)
3658 c->header.info = c->saved_info;
3659 c->saved_info = NULL;
3660 // could, but not necessary: c->static_link = NULL;
3666 markCAFs( evac_fn evac )
3670 for (c = (StgIndStatic *)caf_list; c != NULL;
3671 c = (StgIndStatic *)c->static_link)
3673 evac(&c->indirectee);
3677 /* -----------------------------------------------------------------------------
3678 Sanity code for CAF garbage collection.
3680 With DEBUG turned on, we manage a CAF list in addition to the SRT
3681 mechanism. After GC, we run down the CAF list and blackhole any
3682 CAFs which have been garbage collected. This means we get an error
3683 whenever the program tries to enter a garbage collected CAF.
3685 Any garbage collected CAFs are taken off the CAF list at the same
3687 -------------------------------------------------------------------------- */
3689 #if 0 && defined(DEBUG)
3696 const StgInfoTable *info;
3707 ASSERT(info->type == IND_STATIC);
3709 if (STATIC_LINK(info,p) == NULL) {
3710 IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3712 SET_INFO(p,&stg_BLACKHOLE_info);
3713 p = STATIC_LINK2(info,p);
3717 pp = &STATIC_LINK2(info,p);
3724 // belch("%d CAFs live", i);
3729 /* -----------------------------------------------------------------------------
3732 Whenever a thread returns to the scheduler after possibly doing
3733 some work, we have to run down the stack and black-hole all the
3734 closures referred to by update frames.
3735 -------------------------------------------------------------------------- */
3738 threadLazyBlackHole(StgTSO *tso)
3740 StgUpdateFrame *update_frame;
3741 StgBlockingQueue *bh;
3744 stack_end = &tso->stack[tso->stack_size];
3745 update_frame = tso->su;
3748 switch (get_itbl(update_frame)->type) {
3751 update_frame = ((StgCatchFrame *)update_frame)->link;
3755 bh = (StgBlockingQueue *)update_frame->updatee;
3757 /* if the thunk is already blackholed, it means we've also
3758 * already blackholed the rest of the thunks on this stack,
3759 * so we can stop early.
3761 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3762 * don't interfere with this optimisation.
3764 if (bh->header.info == &stg_BLACKHOLE_info) {
3768 if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
3769 bh->header.info != &stg_CAF_BLACKHOLE_info) {
3770 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3771 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3775 // We pretend that bh is now dead.
3776 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
3778 SET_INFO(bh,&stg_BLACKHOLE_info);
3781 // We pretend that bh has just been created.
3782 LDV_recordCreate(bh);
3786 update_frame = update_frame->link;
3790 update_frame = ((StgSeqFrame *)update_frame)->link;
3796 barf("threadPaused");
3802 /* -----------------------------------------------------------------------------
3805 * Code largely pinched from old RTS, then hacked to bits. We also do
3806 * lazy black holing here.
3808 * -------------------------------------------------------------------------- */
3811 threadSqueezeStack(StgTSO *tso)
3813 lnat displacement = 0;
3814 StgUpdateFrame *frame;
3815 StgUpdateFrame *next_frame; // Temporally next
3816 StgUpdateFrame *prev_frame; // Temporally previous
3818 rtsBool prev_was_update_frame;
3820 StgUpdateFrame *top_frame;
3821 nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
3823 void printObj( StgClosure *obj ); // from Printer.c
3825 top_frame = tso->su;
3828 bottom = &(tso->stack[tso->stack_size]);
3831 /* There must be at least one frame, namely the STOP_FRAME.
3833 ASSERT((P_)frame < bottom);
3835 /* Walk down the stack, reversing the links between frames so that
3836 * we can walk back up as we squeeze from the bottom. Note that
3837 * next_frame and prev_frame refer to next and previous as they were
3838 * added to the stack, rather than the way we see them in this
3839 * walk. (It makes the next loop less confusing.)
3841 * Stop if we find an update frame pointing to a black hole
3842 * (see comment in threadLazyBlackHole()).
3846 // bottom - sizeof(StgStopFrame) is the STOP_FRAME
3847 while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
3848 prev_frame = frame->link;
3849 frame->link = next_frame;
3854 if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
3855 printObj((StgClosure *)prev_frame);
3856 barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
3859 switch (get_itbl(frame)->type) {
3862 if (frame->updatee->header.info == &stg_BLACKHOLE_info)
3875 barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
3877 printObj((StgClosure *)prev_frame);
3880 if (get_itbl(frame)->type == UPDATE_FRAME
3881 && frame->updatee->header.info == &stg_BLACKHOLE_info) {
3886 /* Now, we're at the bottom. Frame points to the lowest update
3887 * frame on the stack, and its link actually points to the frame
3888 * above. We have to walk back up the stack, squeezing out empty
3889 * update frames and turning the pointers back around on the way
3892 * The bottom-most frame (the STOP_FRAME) has not been altered, and
3893 * we never want to eliminate it anyway. Just walk one step up
3894 * before starting to squeeze. When you get to the topmost frame,
3895 * remember that there are still some words above it that might have
3902 prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
3905 * Loop through all of the frames (everything except the very
3906 * bottom). Things are complicated by the fact that we have
3907 * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
3908 * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
3910 while (frame != NULL) {
3912 StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
3913 rtsBool is_update_frame;
3915 next_frame = frame->link;
3916 is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
3919 * 1. both the previous and current frame are update frames
3920 * 2. the current frame is empty
3922 if (prev_was_update_frame && is_update_frame &&
3923 (P_)prev_frame == frame_bottom + displacement) {
3925 // Now squeeze out the current frame
3926 StgClosure *updatee_keep = prev_frame->updatee;
3927 StgClosure *updatee_bypass = frame->updatee;
3930 IF_DEBUG(gc, belch("@@ squeezing frame at %p", frame));
3934 /* Deal with blocking queues. If both updatees have blocked
3935 * threads, then we should merge the queues into the update
3936 * frame that we're keeping.
3938 * Alternatively, we could just wake them up: they'll just go
3939 * straight to sleep on the proper blackhole! This is less code
3940 * and probably less bug prone, although it's probably much
3943 #if 0 // do it properly...
3944 # if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3945 # error Unimplemented lazy BH warning. (KSW 1999-01)
3947 if (GET_INFO(updatee_bypass) == stg_BLACKHOLE_BQ_info
3948 || GET_INFO(updatee_bypass) == stg_CAF_BLACKHOLE_info
3950 // Sigh. It has one. Don't lose those threads!
3951 if (GET_INFO(updatee_keep) == stg_BLACKHOLE_BQ_info) {
3952 // Urgh. Two queues. Merge them.
3953 P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
3955 while (keep_tso->link != END_TSO_QUEUE) {
3956 keep_tso = keep_tso->link;
3958 keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
3961 // For simplicity, just swap the BQ for the BH
3962 P_ temp = updatee_keep;
3964 updatee_keep = updatee_bypass;
3965 updatee_bypass = temp;
3967 // Record the swap in the kept frame (below)
3968 prev_frame->updatee = updatee_keep;
3973 TICK_UPD_SQUEEZED();
3974 /* wasn't there something about update squeezing and ticky to be
3975 * sorted out? oh yes: we aren't counting each enter properly
3976 * in this case. See the log somewhere. KSW 1999-04-21
3978 * Check two things: that the two update frames don't point to
3979 * the same object, and that the updatee_bypass isn't already an
3980 * indirection. Both of these cases only happen when we're in a
3981 * block hole-style loop (and there are multiple update frames
3982 * on the stack pointing to the same closure), but they can both
3983 * screw us up if we don't check.
3985 if (updatee_bypass != updatee_keep && !closure_IND(updatee_bypass)) {
3986 // this wakes the threads up
3987 UPD_IND_NOLOCK(updatee_bypass, updatee_keep);
3990 sp = (P_)frame - 1; // sp = stuff to slide
3991 displacement += sizeofW(StgUpdateFrame);
3994 // No squeeze for this frame
3995 sp = frame_bottom - 1; // Keep the current frame
3997 /* Do lazy black-holing.
3999 if (is_update_frame) {
4000 StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
4001 if (bh->header.info != &stg_BLACKHOLE_info &&
4002 bh->header.info != &stg_BLACKHOLE_BQ_info &&
4003 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4004 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4005 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4008 /* zero out the slop so that the sanity checker can tell
4009 * where the next closure is.
4012 StgInfoTable *info = get_itbl(bh);
4013 nat np = info->layout.payload.ptrs, nw = info->layout.payload.nptrs, i;
4014 /* don't zero out slop for a THUNK_SELECTOR, because its layout
4015 * info is used for a different purpose, and it's exactly the
4016 * same size as a BLACKHOLE in any case.
4018 if (info->type != THUNK_SELECTOR) {
4019 for (i = np; i < np + nw; i++) {
4020 ((StgClosure *)bh)->payload[i] = 0;
4027 // We pretend that bh is now dead.
4028 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4031 // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
4033 SET_INFO(bh,&stg_BLACKHOLE_info);
4036 // We pretend that bh has just been created.
4037 LDV_recordCreate(bh);
4042 // Fix the link in the current frame (should point to the frame below)
4043 frame->link = prev_frame;
4044 prev_was_update_frame = is_update_frame;
4047 // Now slide all words from sp up to the next frame
4049 if (displacement > 0) {
4050 P_ next_frame_bottom;
4052 if (next_frame != NULL)
4053 next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
4055 next_frame_bottom = tso->sp - 1;
4059 belch("sliding [%p, %p] by %ld", sp, next_frame_bottom,
4063 while (sp >= next_frame_bottom) {
4064 sp[displacement] = *sp;
4068 (P_)prev_frame = (P_)frame + displacement;
4072 tso->sp += displacement;
4073 tso->su = prev_frame;
4076 belch("@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames",
4077 squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
4082 /* -----------------------------------------------------------------------------
4085 * We have to prepare for GC - this means doing lazy black holing
4086 * here. We also take the opportunity to do stack squeezing if it's
4088 * -------------------------------------------------------------------------- */
4090 threadPaused(StgTSO *tso)
4092 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4093 threadSqueezeStack(tso); // does black holing too
4095 threadLazyBlackHole(tso);
4098 /* -----------------------------------------------------------------------------
4100 * -------------------------------------------------------------------------- */
4104 printMutOnceList(generation *gen)
4106 StgMutClosure *p, *next;
4108 p = gen->mut_once_list;
4111 fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4112 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4113 fprintf(stderr, "%p (%s), ",
4114 p, info_type((StgClosure *)p));
4116 fputc('\n', stderr);
4120 printMutableList(generation *gen)
4122 StgMutClosure *p, *next;
4127 fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4128 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4129 fprintf(stderr, "%p (%s), ",
4130 p, info_type((StgClosure *)p));
4132 fputc('\n', stderr);
4135 static inline rtsBool
4136 maybeLarge(StgClosure *closure)
4138 StgInfoTable *info = get_itbl(closure);
4140 /* closure types that may be found on the new_large_objects list;
4141 see scavenge_large */
4142 return (info->type == MUT_ARR_PTRS ||
4143 info->type == MUT_ARR_PTRS_FROZEN ||
4144 info->type == TSO ||
4145 info->type == ARR_WORDS);