1 /* -----------------------------------------------------------------------------
2 * $Id: GC.c,v 1.38 1999/02/23 15:45:06 simonm Exp $
4 * (c) The GHC Team 1998-1999
6 * Generational garbage collector
8 * ---------------------------------------------------------------------------*/
14 #include "StoragePriv.h"
17 #include "SchedAPI.h" /* for ReverCAFs prototype */
20 #include "BlockAlloc.h"
22 #include "DebugProf.h"
25 #include "StablePriv.h"
29 /* STATIC OBJECT LIST.
32 * We maintain a linked list of static objects that are still live.
33 * The requirements for this list are:
35 * - we need to scan the list while adding to it, in order to
36 * scavenge all the static objects (in the same way that
37 * breadth-first scavenging works for dynamic objects).
39 * - we need to be able to tell whether an object is already on
40 * the list, to break loops.
42 * Each static object has a "static link field", which we use for
43 * linking objects on to the list. We use a stack-type list, consing
44 * objects on the front as they are added (this means that the
45 * scavenge phase is depth-first, not breadth-first, but that
48 * A separate list is kept for objects that have been scavenged
49 * already - this is so that we can zero all the marks afterwards.
51 * An object is on the list if its static link field is non-zero; this
52 * means that we have to mark the end of the list with '1', not NULL.
54 * Extra notes for generational GC:
56 * Each generation has a static object list associated with it. When
57 * collecting generations up to N, we treat the static object lists
58 * from generations > N as roots.
60 * We build up a static object list while collecting generations 0..N,
61 * which is then appended to the static object list of generation N+1.
63 StgClosure* static_objects; /* live static objects */
64 StgClosure* scavenged_static_objects; /* static objects scavenged so far */
66 /* N is the oldest generation being collected, where the generations
67 * are numbered starting at 0. A major GC (indicated by the major_gc
68 * flag) is when we're collecting all generations. We only attempt to
69 * deal with static objects and GC CAFs when doing a major GC.
72 static rtsBool major_gc;
74 /* Youngest generation that objects should be evacuated to in
75 * evacuate(). (Logically an argument to evacuate, but it's static
76 * a lot of the time so we optimise it into a global variable).
82 static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
83 static rtsBool weak_done; /* all done for this pass */
85 /* Flag indicating failure to evacuate an object to the desired
88 static rtsBool failed_to_evac;
90 /* Old to-space (used for two-space collector only)
94 /* Data used for allocation area sizing.
96 lnat new_blocks; /* blocks allocated during this GC */
97 lnat g0s0_pcnt_kept = 30; /* percentage of g0s0 live at last minor GC */
99 /* -----------------------------------------------------------------------------
100 Static function declarations
101 -------------------------------------------------------------------------- */
103 static StgClosure *evacuate(StgClosure *q);
104 static void zeroStaticObjectList(StgClosure* first_static);
105 static rtsBool traverse_weak_ptr_list(void);
106 static void zeroMutableList(StgMutClosure *first);
107 static void revertDeadCAFs(void);
109 static void scavenge_stack(StgPtr p, StgPtr stack_end);
110 static void scavenge_large(step *step);
111 static void scavenge(step *step);
112 static void scavenge_static(void);
113 static void scavenge_mutable_list(generation *g);
114 static void scavenge_mut_once_list(generation *g);
117 static void gcCAFs(void);
120 /* -----------------------------------------------------------------------------
123 For garbage collecting generation N (and all younger generations):
125 - follow all pointers in the root set. the root set includes all
126 mutable objects in all steps in all generations.
128 - for each pointer, evacuate the object it points to into either
129 + to-space in the next higher step in that generation, if one exists,
130 + if the object's generation == N, then evacuate it to the next
131 generation if one exists, or else to-space in the current
133 + if the object's generation < N, then evacuate it to to-space
134 in the next generation.
136 - repeatedly scavenge to-space from each step in each generation
137 being collected until no more objects can be evacuated.
139 - free from-space in each step, and set from-space = to-space.
141 -------------------------------------------------------------------------- */
143 void GarbageCollect(void (*get_roots)(void))
147 lnat live, allocated, collected = 0, copied = 0;
151 CostCentreStack *prev_CCS;
154 /* tell the stats department that we've started a GC */
157 /* attribute any costs to CCS_GC */
163 /* We might have been called from Haskell land by _ccall_GC, in
164 * which case we need to call threadPaused() because the scheduler
165 * won't have done it.
167 if (CurrentTSO) { threadPaused(CurrentTSO); }
169 /* Approximate how much we allocated: number of blocks in the
170 * nursery + blocks allocated via allocate() - unused nusery blocks.
171 * This leaves a little slop at the end of each block, and doesn't
172 * take into account large objects (ToDo).
174 allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
175 for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
176 allocated -= BLOCK_SIZE_W;
179 /* Figure out which generation to collect
182 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
183 if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
187 major_gc = (N == RtsFlags.GcFlags.generations-1);
189 /* check stack sanity *before* GC (ToDo: check all threads) */
190 /*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
191 IF_DEBUG(sanity, checkFreeListSanity());
193 /* Initialise the static object lists
195 static_objects = END_OF_STATIC_LIST;
196 scavenged_static_objects = END_OF_STATIC_LIST;
198 /* zero the mutable list for the oldest generation (see comment by
199 * zeroMutableList below).
202 zeroMutableList(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
205 /* Save the old to-space if we're doing a two-space collection
207 if (RtsFlags.GcFlags.generations == 1) {
208 old_to_space = g0s0->to_space;
209 g0s0->to_space = NULL;
212 /* Keep a count of how many new blocks we allocated during this GC
213 * (used for resizing the allocation area, later).
217 /* Initialise to-space in all the generations/steps that we're
220 for (g = 0; g <= N; g++) {
221 generations[g].mut_once_list = END_MUT_LIST;
222 generations[g].mut_list = END_MUT_LIST;
224 for (s = 0; s < generations[g].n_steps; s++) {
226 /* generation 0, step 0 doesn't need to-space */
227 if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
231 /* Get a free block for to-space. Extra blocks will be chained on
235 step = &generations[g].steps[s];
236 ASSERT(step->gen->no == g);
237 ASSERT(step->hp ? Bdescr(step->hp)->step == step : rtsTrue);
238 bd->gen = &generations[g];
241 bd->evacuated = 1; /* it's a to-space block */
242 step->hp = bd->start;
243 step->hpLim = step->hp + BLOCK_SIZE_W;
247 step->scan = bd->start;
249 step->new_large_objects = NULL;
250 step->scavenged_large_objects = NULL;
252 /* mark the large objects as not evacuated yet */
253 for (bd = step->large_objects; bd; bd = bd->link) {
259 /* make sure the older generations have at least one block to
260 * allocate into (this makes things easier for copy(), see below.
262 for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
263 for (s = 0; s < generations[g].n_steps; s++) {
264 step = &generations[g].steps[s];
265 if (step->hp_bd == NULL) {
267 bd->gen = &generations[g];
270 bd->evacuated = 0; /* *not* a to-space block */
271 step->hp = bd->start;
272 step->hpLim = step->hp + BLOCK_SIZE_W;
278 /* Set the scan pointer for older generations: remember we
279 * still have to scavenge objects that have been promoted. */
280 step->scan = step->hp;
281 step->scan_bd = step->hp_bd;
282 step->to_space = NULL;
284 step->new_large_objects = NULL;
285 step->scavenged_large_objects = NULL;
289 /* -----------------------------------------------------------------------
290 * follow all the roots that we know about:
291 * - mutable lists from each generation > N
292 * we want to *scavenge* these roots, not evacuate them: they're not
293 * going to move in this GC.
294 * Also: do them in reverse generation order. This is because we
295 * often want to promote objects that are pointed to by older
296 * generations early, so we don't have to repeatedly copy them.
297 * Doing the generations in reverse order ensures that we don't end
298 * up in the situation where we want to evac an object to gen 3 and
299 * it has already been evaced to gen 2.
303 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
304 generations[g].saved_mut_list = generations[g].mut_list;
305 generations[g].mut_list = END_MUT_LIST;
308 /* Do the mut-once lists first */
309 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
310 scavenge_mut_once_list(&generations[g]);
312 for (st = generations[g].n_steps-1; st >= 0; st--) {
313 scavenge(&generations[g].steps[st]);
317 for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
318 scavenge_mutable_list(&generations[g]);
320 for (st = generations[g].n_steps-1; st >= 0; st--) {
321 scavenge(&generations[g].steps[st]);
326 /* follow all the roots that the application knows about.
331 /* And don't forget to mark the TSO if we got here direct from
334 CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
337 /* Mark the weak pointer list, and prepare to detect dead weak
341 old_weak_ptr_list = weak_ptr_list;
342 weak_ptr_list = NULL;
343 weak_done = rtsFalse;
345 /* Mark the stable pointer table.
347 markStablePtrTable(major_gc);
351 /* ToDo: To fix the caf leak, we need to make the commented out
352 * parts of this code do something sensible - as described in
355 extern void markHugsObjects(void);
357 /* ToDo: This (undefined) function should contain the scavenge
358 * loop immediately below this block of code - but I'm not sure
359 * enough of the details to do this myself.
361 scavengeEverything();
362 /* revert dead CAFs and update enteredCAFs list */
367 /* This will keep the CAFs and the attached BCOs alive
368 * but the values will have been reverted
370 scavengeEverything();
375 /* -------------------------------------------------------------------------
376 * Repeatedly scavenge all the areas we know about until there's no
377 * more scavenging to be done.
384 /* scavenge static objects */
385 if (major_gc && static_objects != END_OF_STATIC_LIST) {
389 /* When scavenging the older generations: Objects may have been
390 * evacuated from generations <= N into older generations, and we
391 * need to scavenge these objects. We're going to try to ensure that
392 * any evacuations that occur move the objects into at least the
393 * same generation as the object being scavenged, otherwise we
394 * have to create new entries on the mutable list for the older
398 /* scavenge each step in generations 0..maxgen */
402 for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
403 for (st = generations[gen].n_steps-1; st >= 0 ; st--) {
404 if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
407 step = &generations[gen].steps[st];
409 if (step->hp_bd != step->scan_bd || step->scan < step->hp) {
414 if (step->new_large_objects != NULL) {
415 scavenge_large(step);
422 if (flag) { goto loop; }
424 /* must be last... */
425 if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
430 /* Now see which stable names are still alive
432 gcStablePtrTable(major_gc);
434 /* Set the maximum blocks for the oldest generation, based on twice
435 * the amount of live data now, adjusted to fit the maximum heap
438 * This is an approximation, since in the worst case we'll need
439 * twice the amount of live data plus whatever space the other
442 if (RtsFlags.GcFlags.generations > 1) {
444 oldest_gen->max_blocks =
445 stg_max(oldest_gen->steps[0].to_blocks * RtsFlags.GcFlags.oldGenFactor,
446 RtsFlags.GcFlags.minOldGenSize);
447 if (oldest_gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
448 oldest_gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
449 if (((int)oldest_gen->max_blocks -
450 (int)oldest_gen->steps[0].to_blocks) <
451 (RtsFlags.GcFlags.pcFreeHeap *
452 RtsFlags.GcFlags.maxHeapSize / 200)) {
459 /* run through all the generations/steps and tidy up
461 copied = new_blocks * BLOCK_SIZE_W;
462 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
465 generations[g].collections++; /* for stats */
468 for (s = 0; s < generations[g].n_steps; s++) {
470 step = &generations[g].steps[s];
472 if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
473 /* Tidy the end of the to-space chains */
474 step->hp_bd->free = step->hp;
475 step->hp_bd->link = NULL;
476 /* stats information: how much we copied */
478 copied -= step->hp_bd->start + BLOCK_SIZE_W -
483 /* for generations we collected... */
486 collected += step->n_blocks * BLOCK_SIZE_W; /* for stats */
488 /* free old memory and shift to-space into from-space for all
489 * the collected steps (except the allocation area). These
490 * freed blocks will probaby be quickly recycled.
492 if (!(g == 0 && s == 0)) {
493 freeChain(step->blocks);
494 step->blocks = step->to_space;
495 step->n_blocks = step->to_blocks;
496 step->to_space = NULL;
498 for (bd = step->blocks; bd != NULL; bd = bd->link) {
499 bd->evacuated = 0; /* now from-space */
503 /* LARGE OBJECTS. The current live large objects are chained on
504 * scavenged_large, having been moved during garbage
505 * collection from large_objects. Any objects left on
506 * large_objects list are therefore dead, so we free them here.
508 for (bd = step->large_objects; bd != NULL; bd = next) {
513 for (bd = step->scavenged_large_objects; bd != NULL; bd = bd->link) {
516 step->large_objects = step->scavenged_large_objects;
518 /* Set the maximum blocks for this generation, interpolating
519 * between the maximum size of the oldest and youngest
522 * max_blocks = oldgen_max_blocks * G
523 * ----------------------
528 generations[g].max_blocks = (oldest_gen->max_blocks * g)
529 / (RtsFlags.GcFlags.generations-1);
531 generations[g].max_blocks = oldest_gen->max_blocks;
534 /* for older generations... */
537 /* For older generations, we need to append the
538 * scavenged_large_object list (i.e. large objects that have been
539 * promoted during this GC) to the large_object list for that step.
541 for (bd = step->scavenged_large_objects; bd; bd = next) {
544 dbl_link_onto(bd, &step->large_objects);
547 /* add the new blocks we promoted during this GC */
548 step->n_blocks += step->to_blocks;
553 /* Guess the amount of live data for stats. */
556 /* Free the small objects allocated via allocate(), since this will
557 * all have been copied into G0S1 now.
559 if (small_alloc_list != NULL) {
560 freeChain(small_alloc_list);
562 small_alloc_list = NULL;
564 alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
566 /* Two-space collector:
567 * Free the old to-space, and estimate the amount of live data.
569 if (RtsFlags.GcFlags.generations == 1) {
572 if (old_to_space != NULL) {
573 freeChain(old_to_space);
575 for (bd = g0s0->to_space; bd != NULL; bd = bd->link) {
576 bd->evacuated = 0; /* now from-space */
579 /* For a two-space collector, we need to resize the nursery. */
581 /* set up a new nursery. Allocate a nursery size based on a
582 * function of the amount of live data (currently a factor of 2,
583 * should be configurable (ToDo)). Use the blocks from the old
584 * nursery if possible, freeing up any left over blocks.
586 * If we get near the maximum heap size, then adjust our nursery
587 * size accordingly. If the nursery is the same size as the live
588 * data (L), then we need 3L bytes. We can reduce the size of the
589 * nursery to bring the required memory down near 2L bytes.
591 * A normal 2-space collector would need 4L bytes to give the same
592 * performance we get from 3L bytes, reducing to the same
593 * performance at 2L bytes.
595 blocks = g0s0->to_blocks;
597 if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
598 RtsFlags.GcFlags.maxHeapSize ) {
599 int adjusted_blocks; /* signed on purpose */
602 adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
603 IF_DEBUG(gc, fprintf(stderr, "Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %d\n", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
604 pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
605 if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
608 blocks = adjusted_blocks;
611 blocks *= RtsFlags.GcFlags.oldGenFactor;
612 if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
613 blocks = RtsFlags.GcFlags.minAllocAreaSize;
616 resizeNursery(blocks);
619 /* Generational collector:
620 * If the user has given us a suggested heap size, adjust our
621 * allocation area to make best use of the memory available.
624 if (RtsFlags.GcFlags.heapSizeSuggestion) {
626 nat needed = calcNeeded(); /* approx blocks needed at next GC */
628 /* Guess how much will be live in generation 0 step 0 next time.
629 * A good approximation is the obtained by finding the
630 * percentage of g0s0 that was live at the last minor GC.
633 g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
636 /* Estimate a size for the allocation area based on the
637 * information available. We might end up going slightly under
638 * or over the suggested heap size, but we should be pretty
641 * Formula: suggested - needed
642 * ----------------------------
643 * 1 + g0s0_pcnt_kept/100
645 * where 'needed' is the amount of memory needed at the next
646 * collection for collecting all steps except g0s0.
649 (((int)RtsFlags.GcFlags.heapSizeSuggestion - (int)needed) * 100) /
650 (100 + (int)g0s0_pcnt_kept);
652 if (blocks < (int)RtsFlags.GcFlags.minAllocAreaSize) {
653 blocks = RtsFlags.GcFlags.minAllocAreaSize;
656 resizeNursery((nat)blocks);
660 /* revert dead CAFs and update enteredCAFs list */
663 /* mark the garbage collected CAFs as dead */
665 if (major_gc) { gcCAFs(); }
668 /* zero the scavenged static object list */
670 zeroStaticObjectList(scavenged_static_objects);
675 for (bd = g0s0->blocks; bd; bd = bd->link) {
676 bd->free = bd->start;
677 ASSERT(bd->gen == g0);
678 ASSERT(bd->step == g0s0);
680 current_nursery = g0s0->blocks;
682 /* start any pending finalizers */
683 scheduleFinalizers(old_weak_ptr_list);
685 /* check sanity after GC */
686 IF_DEBUG(sanity, checkSanity(N));
688 /* extra GC trace info */
689 IF_DEBUG(gc, stat_describe_gens());
692 /* symbol-table based profiling */
693 /* heapCensus(to_space); */ /* ToDo */
696 /* restore enclosing cost centre */
701 /* check for memory leaks if sanity checking is on */
702 IF_DEBUG(sanity, memInventory());
704 /* ok, GC over: tell the stats department what happened. */
705 stat_endGC(allocated, collected, live, copied, N);
708 /* -----------------------------------------------------------------------------
711 traverse_weak_ptr_list is called possibly many times during garbage
712 collection. It returns a flag indicating whether it did any work
713 (i.e. called evacuate on any live pointers).
715 Invariant: traverse_weak_ptr_list is called when the heap is in an
716 idempotent state. That means that there are no pending
717 evacuate/scavenge operations. This invariant helps the weak
718 pointer code decide which weak pointers are dead - if there are no
719 new live weak pointers, then all the currently unreachable ones are
722 For generational GC: we just don't try to finalize weak pointers in
723 older generations than the one we're collecting. This could
724 probably be optimised by keeping per-generation lists of weak
725 pointers, but for a few weak pointers this scheme will work.
726 -------------------------------------------------------------------------- */
729 traverse_weak_ptr_list(void)
731 StgWeak *w, **last_w, *next_w;
733 rtsBool flag = rtsFalse;
735 if (weak_done) { return rtsFalse; }
737 /* doesn't matter where we evacuate values/finalizers to, since
738 * these pointers are treated as roots (iff the keys are alive).
742 last_w = &old_weak_ptr_list;
743 for (w = old_weak_ptr_list; w; w = next_w) {
745 if ((new = isAlive(w->key))) {
747 /* evacuate the value and finalizer */
748 w->value = evacuate(w->value);
749 w->finalizer = evacuate(w->finalizer);
750 /* remove this weak ptr from the old_weak_ptr list */
752 /* and put it on the new weak ptr list */
754 w->link = weak_ptr_list;
757 IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
767 /* If we didn't make any changes, then we can go round and kill all
768 * the dead weak pointers. The old_weak_ptr list is used as a list
769 * of pending finalizers later on.
771 if (flag == rtsFalse) {
772 for (w = old_weak_ptr_list; w; w = w->link) {
773 w->value = evacuate(w->value);
774 w->finalizer = evacuate(w->finalizer);
782 /* -----------------------------------------------------------------------------
783 isAlive determines whether the given closure is still alive (after
784 a garbage collection) or not. It returns the new address of the
785 closure if it is alive, or NULL otherwise.
786 -------------------------------------------------------------------------- */
789 isAlive(StgClosure *p)
797 /* ToDo: for static closures, check the static link field.
798 * Problem here is that we sometimes don't set the link field, eg.
799 * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
802 /* ignore closures in generations that we're not collecting. */
803 if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
807 switch (info->type) {
812 case IND_OLDGEN: /* rely on compatible layout with StgInd */
813 case IND_OLDGEN_PERM:
814 /* follow indirections */
815 p = ((StgInd *)p)->indirectee;
820 return ((StgEvacuated *)p)->evacuee;
830 MarkRoot(StgClosure *root)
832 return evacuate(root);
835 static void addBlock(step *step)
837 bdescr *bd = allocBlock();
841 if (step->gen->no <= N) {
847 step->hp_bd->free = step->hp;
848 step->hp_bd->link = bd;
849 step->hp = bd->start;
850 step->hpLim = step->hp + BLOCK_SIZE_W;
856 static __inline__ StgClosure *
857 copy(StgClosure *src, nat size, step *step)
861 TICK_GC_WORDS_COPIED(size);
862 /* Find out where we're going, using the handy "to" pointer in
863 * the step of the source object. If it turns out we need to
864 * evacuate to an older generation, adjust it here (see comment
867 if (step->gen->no < evac_gen) {
868 step = &generations[evac_gen].steps[0];
871 /* chain a new block onto the to-space for the destination step if
874 if (step->hp + size >= step->hpLim) {
878 for(to = step->hp, from = (P_)src; size>0; --size) {
884 return (StgClosure *)dest;
887 /* Special version of copy() for when we only want to copy the info
888 * pointer of an object, but reserve some padding after it. This is
889 * used to optimise evacuation of BLACKHOLEs.
892 static __inline__ StgClosure *
893 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
897 TICK_GC_WORDS_COPIED(size_to_copy);
898 if (step->gen->no < evac_gen) {
899 step = &generations[evac_gen].steps[0];
902 if (step->hp + size_to_reserve >= step->hpLim) {
906 for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
911 step->hp += size_to_reserve;
912 return (StgClosure *)dest;
915 static __inline__ void
916 upd_evacuee(StgClosure *p, StgClosure *dest)
918 StgEvacuated *q = (StgEvacuated *)p;
920 SET_INFO(q,&EVACUATED_info);
924 /* -----------------------------------------------------------------------------
925 Evacuate a large object
927 This just consists of removing the object from the (doubly-linked)
928 large_alloc_list, and linking it on to the (singly-linked)
929 new_large_objects list, from where it will be scavenged later.
931 Convention: bd->evacuated is /= 0 for a large object that has been
932 evacuated, or 0 otherwise.
933 -------------------------------------------------------------------------- */
936 evacuate_large(StgPtr p, rtsBool mutable)
938 bdescr *bd = Bdescr(p);
941 /* should point to the beginning of the block */
942 ASSERT(((W_)p & BLOCK_MASK) == 0);
944 /* already evacuated? */
946 /* Don't forget to set the failed_to_evac flag if we didn't get
947 * the desired destination (see comments in evacuate()).
949 if (bd->gen->no < evac_gen) {
950 failed_to_evac = rtsTrue;
951 TICK_GC_FAILED_PROMOTION();
957 /* remove from large_object list */
959 bd->back->link = bd->link;
960 } else { /* first object in the list */
961 step->large_objects = bd->link;
964 bd->link->back = bd->back;
967 /* link it on to the evacuated large object list of the destination step
970 if (step->gen->no < evac_gen) {
971 step = &generations[evac_gen].steps[0];
976 bd->link = step->new_large_objects;
977 step->new_large_objects = bd;
981 recordMutable((StgMutClosure *)p);
985 /* -----------------------------------------------------------------------------
986 Adding a MUT_CONS to an older generation.
988 This is necessary from time to time when we end up with an
989 old-to-new generation pointer in a non-mutable object. We defer
990 the promotion until the next GC.
991 -------------------------------------------------------------------------- */
994 mkMutCons(StgClosure *ptr, generation *gen)
999 step = &gen->steps[0];
1001 /* chain a new block onto the to-space for the destination step if
1004 if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
1008 q = (StgMutVar *)step->hp;
1009 step->hp += sizeofW(StgMutVar);
1011 SET_HDR(q,&MUT_CONS_info,CCS_GC);
1013 recordOldToNewPtrs((StgMutClosure *)q);
1015 return (StgClosure *)q;
1018 /* -----------------------------------------------------------------------------
1021 This is called (eventually) for every live object in the system.
1023 The caller to evacuate specifies a desired generation in the
1024 evac_gen global variable. The following conditions apply to
1025 evacuating an object which resides in generation M when we're
1026 collecting up to generation N
1030 else evac to step->to
1032 if M < evac_gen evac to evac_gen, step 0
1034 if the object is already evacuated, then we check which generation
1037 if M >= evac_gen do nothing
1038 if M < evac_gen set failed_to_evac flag to indicate that we
1039 didn't manage to evacuate this object into evac_gen.
1041 -------------------------------------------------------------------------- */
1045 evacuate(StgClosure *q)
1050 const StgInfoTable *info;
1053 if (!LOOKS_LIKE_STATIC(q)) {
1055 if (bd->gen->no > N) {
1056 /* Can't evacuate this object, because it's in a generation
1057 * older than the ones we're collecting. Let's hope that it's
1058 * in evac_gen or older, or we will have to make an IND_OLDGEN object.
1060 if (bd->gen->no < evac_gen) {
1062 failed_to_evac = rtsTrue;
1063 TICK_GC_FAILED_PROMOTION();
1067 step = bd->step->to;
1070 /* make sure the info pointer is into text space */
1071 ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1072 || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1075 switch (info -> type) {
1078 to = copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
1083 ASSERT(q->header.info != &MUT_CONS_info);
1085 to = copy(q,sizeW_fromITBL(info),step);
1087 recordMutable((StgMutClosure *)to);
1091 stable_ptr_table[((StgStableName *)q)->sn].keep = rtsTrue;
1092 to = copy(q,sizeofW(StgStableName),step);
1100 to = copy(q,sizeofW(StgHeader)+1,step);
1104 case THUNK_1_0: /* here because of MIN_UPD_SIZE */
1115 to = copy(q,sizeofW(StgHeader)+2,step);
1123 case IND_OLDGEN_PERM:
1128 to = copy(q,sizeW_fromITBL(info),step);
1134 to = copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1139 to = copy(q,BLACKHOLE_sizeW(),step);
1141 recordMutable((StgMutClosure *)to);
1144 case THUNK_SELECTOR:
1146 const StgInfoTable* selectee_info;
1147 StgClosure* selectee = ((StgSelector*)q)->selectee;
1150 selectee_info = get_itbl(selectee);
1151 switch (selectee_info->type) {
1160 StgNat32 offset = info->layout.selector_offset;
1162 /* check that the size is in range */
1164 (StgNat32)(selectee_info->layout.payload.ptrs +
1165 selectee_info->layout.payload.nptrs));
1167 /* perform the selection! */
1168 q = selectee->payload[offset];
1170 /* if we're already in to-space, there's no need to continue
1171 * with the evacuation, just update the source address with
1172 * a pointer to the (evacuated) constructor field.
1174 if (IS_USER_PTR(q)) {
1175 bdescr *bd = Bdescr((P_)q);
1176 if (bd->evacuated) {
1177 if (bd->gen->no < evac_gen) {
1178 failed_to_evac = rtsTrue;
1179 TICK_GC_FAILED_PROMOTION();
1185 /* otherwise, carry on and evacuate this constructor field,
1186 * (but not the constructor itself)
1195 case IND_OLDGEN_PERM:
1196 selectee = stgCast(StgInd *,selectee)->indirectee;
1200 selectee = stgCast(StgCAF *,selectee)->value;
1204 selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1214 case THUNK_SELECTOR:
1215 /* aargh - do recursively???? */
1220 /* not evaluated yet */
1224 barf("evacuate: THUNK_SELECTOR: strange selectee");
1227 to = copy(q,THUNK_SELECTOR_sizeW(),step);
1233 /* follow chains of indirections, don't evacuate them */
1234 q = ((StgInd*)q)->indirectee;
1237 /* ToDo: optimise STATIC_LINK for known cases.
1238 - FUN_STATIC : payload[0]
1239 - THUNK_STATIC : payload[1]
1240 - IND_STATIC : payload[1]
1244 if (info->srt_len == 0) { /* small optimisation */
1250 /* don't want to evacuate these, but we do want to follow pointers
1251 * from SRTs - see scavenge_static.
1254 /* put the object on the static list, if necessary.
1256 if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1257 STATIC_LINK(info,(StgClosure *)q) = static_objects;
1258 static_objects = (StgClosure *)q;
1262 case CONSTR_INTLIKE:
1263 case CONSTR_CHARLIKE:
1264 case CONSTR_NOCAF_STATIC:
1265 /* no need to put these on the static linked list, they don't need
1280 /* shouldn't see these */
1281 barf("evacuate: stack frame\n");
1285 /* these are special - the payload is a copy of a chunk of stack,
1287 to = copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1292 /* Already evacuated, just return the forwarding address.
1293 * HOWEVER: if the requested destination generation (evac_gen) is
1294 * older than the actual generation (because the object was
1295 * already evacuated to a younger generation) then we have to
1296 * set the failed_to_evac flag to indicate that we couldn't
1297 * manage to promote the object to the desired generation.
1299 if (evac_gen > 0) { /* optimisation */
1300 StgClosure *p = ((StgEvacuated*)q)->evacuee;
1301 if (Bdescr((P_)p)->gen->no < evac_gen) {
1302 /* fprintf(stderr,"evac failed!\n");*/
1303 failed_to_evac = rtsTrue;
1304 TICK_GC_FAILED_PROMOTION();
1307 return ((StgEvacuated*)q)->evacuee;
1311 nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1313 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1314 evacuate_large((P_)q, rtsFalse);
1317 /* just copy the block */
1318 to = copy(q,size,step);
1325 case MUT_ARR_PTRS_FROZEN:
1327 nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1329 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1330 evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1333 /* just copy the block */
1334 to = copy(q,size,step);
1336 if (info->type == MUT_ARR_PTRS) {
1337 recordMutable((StgMutClosure *)to);
1345 StgTSO *tso = stgCast(StgTSO *,q);
1346 nat size = tso_sizeW(tso);
1349 /* Large TSOs don't get moved, so no relocation is required.
1351 if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1352 evacuate_large((P_)q, rtsTrue);
1355 /* To evacuate a small TSO, we need to relocate the update frame
1359 StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1361 diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1363 /* relocate the stack pointers... */
1364 new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1365 new_tso->sp = (StgPtr)new_tso->sp + diff;
1366 new_tso->splim = (StgPtr)new_tso->splim + diff;
1368 relocate_TSO(tso, new_tso);
1369 upd_evacuee(q,(StgClosure *)new_tso);
1371 recordMutable((StgMutClosure *)new_tso);
1372 return (StgClosure *)new_tso;
1378 fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1382 barf("evacuate: strange closure type");
1388 /* -----------------------------------------------------------------------------
1389 relocate_TSO is called just after a TSO has been copied from src to
1390 dest. It adjusts the update frame list for the new location.
1391 -------------------------------------------------------------------------- */
1394 relocate_TSO(StgTSO *src, StgTSO *dest)
1401 diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1405 while ((P_)su < dest->stack + dest->stack_size) {
1406 switch (get_itbl(su)->type) {
1408 /* GCC actually manages to common up these three cases! */
1411 su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1416 cf = (StgCatchFrame *)su;
1417 cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1422 sf = (StgSeqFrame *)su;
1423 sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1432 barf("relocate_TSO");
1441 scavenge_srt(const StgInfoTable *info)
1443 StgClosure **srt, **srt_end;
1445 /* evacuate the SRT. If srt_len is zero, then there isn't an
1446 * srt field in the info table. That's ok, because we'll
1447 * never dereference it.
1449 srt = stgCast(StgClosure **,info->srt);
1450 srt_end = srt + info->srt_len;
1451 for (; srt < srt_end; srt++) {
1456 /* -----------------------------------------------------------------------------
1457 Scavenge a given step until there are no more objects in this step
1460 evac_gen is set by the caller to be either zero (for a step in a
1461 generation < N) or G where G is the generation of the step being
1464 We sometimes temporarily change evac_gen back to zero if we're
1465 scavenging a mutable object where early promotion isn't such a good
1467 -------------------------------------------------------------------------- */
1471 scavenge(step *step)
1474 const StgInfoTable *info;
1476 nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1481 failed_to_evac = rtsFalse;
1483 /* scavenge phase - standard breadth-first scavenging of the
1487 while (bd != step->hp_bd || p < step->hp) {
1489 /* If we're at the end of this block, move on to the next block */
1490 if (bd != step->hp_bd && p == bd->free) {
1496 q = p; /* save ptr to object */
1498 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1499 || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1501 info = get_itbl((StgClosure *)p);
1502 switch (info -> type) {
1506 StgBCO* bco = stgCast(StgBCO*,p);
1508 for (i = 0; i < bco->n_ptrs; i++) {
1509 bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1511 p += bco_sizeW(bco);
1516 /* treat MVars specially, because we don't want to evacuate the
1517 * mut_link field in the middle of the closure.
1520 StgMVar *mvar = ((StgMVar *)p);
1522 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1523 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1524 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1525 p += sizeofW(StgMVar);
1526 evac_gen = saved_evac_gen;
1534 ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1535 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1536 p += sizeofW(StgHeader) + 2;
1541 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1542 p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1548 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1549 p += sizeofW(StgHeader) + 1;
1554 p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1560 p += sizeofW(StgHeader) + 1;
1567 p += sizeofW(StgHeader) + 2;
1574 ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1575 p += sizeofW(StgHeader) + 2;
1588 case IND_OLDGEN_PERM:
1594 end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1595 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1596 (StgClosure *)*p = evacuate((StgClosure *)*p);
1598 p += info->layout.payload.nptrs;
1603 /* ignore MUT_CONSs */
1604 if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1606 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1607 evac_gen = saved_evac_gen;
1609 p += sizeofW(StgMutVar);
1614 p += BLACKHOLE_sizeW();
1619 StgBlockingQueue *bh = (StgBlockingQueue *)p;
1620 (StgClosure *)bh->blocking_queue =
1621 evacuate((StgClosure *)bh->blocking_queue);
1622 if (failed_to_evac) {
1623 failed_to_evac = rtsFalse;
1624 recordMutable((StgMutClosure *)bh);
1626 p += BLACKHOLE_sizeW();
1630 case THUNK_SELECTOR:
1632 StgSelector *s = (StgSelector *)p;
1633 s->selectee = evacuate(s->selectee);
1634 p += THUNK_SELECTOR_sizeW();
1640 barf("scavenge:IND???\n");
1642 case CONSTR_INTLIKE:
1643 case CONSTR_CHARLIKE:
1645 case CONSTR_NOCAF_STATIC:
1649 /* Shouldn't see a static object here. */
1650 barf("scavenge: STATIC object\n");
1662 /* Shouldn't see stack frames here. */
1663 barf("scavenge: stack frame\n");
1665 case AP_UPD: /* same as PAPs */
1667 /* Treat a PAP just like a section of stack, not forgetting to
1668 * evacuate the function pointer too...
1671 StgPAP* pap = stgCast(StgPAP*,p);
1673 pap->fun = evacuate(pap->fun);
1674 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1675 p += pap_sizeW(pap);
1680 /* nothing to follow */
1681 p += arr_words_sizeW(stgCast(StgArrWords*,p));
1685 /* follow everything */
1689 evac_gen = 0; /* repeatedly mutable */
1690 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1691 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1692 (StgClosure *)*p = evacuate((StgClosure *)*p);
1694 evac_gen = saved_evac_gen;
1698 case MUT_ARR_PTRS_FROZEN:
1699 /* follow everything */
1701 StgPtr start = p, next;
1703 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1704 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1705 (StgClosure *)*p = evacuate((StgClosure *)*p);
1707 if (failed_to_evac) {
1708 /* we can do this easier... */
1709 recordMutable((StgMutClosure *)start);
1710 failed_to_evac = rtsFalse;
1721 /* chase the link field for any TSOs on the same queue */
1722 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1723 /* scavenge this thread's stack */
1724 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1725 evac_gen = saved_evac_gen;
1726 p += tso_sizeW(tso);
1733 barf("scavenge: unimplemented/strange closure type\n");
1739 /* If we didn't manage to promote all the objects pointed to by
1740 * the current object, then we have to designate this object as
1741 * mutable (because it contains old-to-new generation pointers).
1743 if (failed_to_evac) {
1744 mkMutCons((StgClosure *)q, &generations[evac_gen]);
1745 failed_to_evac = rtsFalse;
1753 /* -----------------------------------------------------------------------------
1754 Scavenge one object.
1756 This is used for objects that are temporarily marked as mutable
1757 because they contain old-to-new generation pointers. Only certain
1758 objects can have this property.
1759 -------------------------------------------------------------------------- */
1761 scavenge_one(StgClosure *p)
1766 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1767 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1771 switch (info -> type) {
1774 case FUN_1_0: /* hardly worth specialising these guys */
1794 case IND_OLDGEN_PERM:
1800 end = (P_)p->payload + info->layout.payload.ptrs;
1801 for (q = (P_)p->payload; q < end; q++) {
1802 (StgClosure *)*q = evacuate((StgClosure *)*q);
1811 case THUNK_SELECTOR:
1813 StgSelector *s = (StgSelector *)p;
1814 s->selectee = evacuate(s->selectee);
1818 case AP_UPD: /* same as PAPs */
1820 /* Treat a PAP just like a section of stack, not forgetting to
1821 * evacuate the function pointer too...
1824 StgPAP* pap = (StgPAP *)p;
1826 pap->fun = evacuate(pap->fun);
1827 scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1832 /* This might happen if for instance a MUT_CONS was pointing to a
1833 * THUNK which has since been updated. The IND_OLDGEN will
1834 * be on the mutable list anyway, so we don't need to do anything
1840 barf("scavenge_one: strange object");
1843 no_luck = failed_to_evac;
1844 failed_to_evac = rtsFalse;
1849 /* -----------------------------------------------------------------------------
1850 Scavenging mutable lists.
1852 We treat the mutable list of each generation > N (i.e. all the
1853 generations older than the one being collected) as roots. We also
1854 remove non-mutable objects from the mutable list at this point.
1855 -------------------------------------------------------------------------- */
1858 scavenge_mut_once_list(generation *gen)
1861 StgMutClosure *p, *next, *new_list;
1863 p = gen->mut_once_list;
1864 new_list = END_MUT_LIST;
1868 failed_to_evac = rtsFalse;
1870 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1872 /* make sure the info pointer is into text space */
1873 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1874 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1877 switch(info->type) {
1880 case IND_OLDGEN_PERM:
1882 /* Try to pull the indirectee into this generation, so we can
1883 * remove the indirection from the mutable list.
1885 ((StgIndOldGen *)p)->indirectee =
1886 evacuate(((StgIndOldGen *)p)->indirectee);
1889 /* Debugging code to print out the size of the thing we just
1893 StgPtr start = gen->steps[0].scan;
1894 bdescr *start_bd = gen->steps[0].scan_bd;
1896 scavenge(&gen->steps[0]);
1897 if (start_bd != gen->steps[0].scan_bd) {
1898 size += (P_)BLOCK_ROUND_UP(start) - start;
1899 start_bd = start_bd->link;
1900 while (start_bd != gen->steps[0].scan_bd) {
1901 size += BLOCK_SIZE_W;
1902 start_bd = start_bd->link;
1904 size += gen->steps[0].scan -
1905 (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
1907 size = gen->steps[0].scan - start;
1909 fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
1913 /* failed_to_evac might happen if we've got more than two
1914 * generations, we're collecting only generation 0, the
1915 * indirection resides in generation 2 and the indirectee is
1918 if (failed_to_evac) {
1919 failed_to_evac = rtsFalse;
1920 p->mut_link = new_list;
1923 /* the mut_link field of an IND_STATIC is overloaded as the
1924 * static link field too (it just so happens that we don't need
1925 * both at the same time), so we need to NULL it out when
1926 * removing this object from the mutable list because the static
1927 * link fields are all assumed to be NULL before doing a major
1935 /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
1936 * it from the mutable list if possible by promoting whatever it
1939 ASSERT(p->header.info == &MUT_CONS_info);
1940 if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
1941 /* didn't manage to promote everything, so put the
1942 * MUT_CONS back on the list.
1944 p->mut_link = new_list;
1950 /* shouldn't have anything else on the mutables list */
1951 barf("scavenge_mut_once_list: strange object?");
1955 gen->mut_once_list = new_list;
1960 scavenge_mutable_list(generation *gen)
1963 StgMutClosure *p, *next;
1965 p = gen->saved_mut_list;
1969 failed_to_evac = rtsFalse;
1971 for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1973 /* make sure the info pointer is into text space */
1974 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1975 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1978 switch(info->type) {
1980 case MUT_ARR_PTRS_FROZEN:
1981 /* remove this guy from the mutable list, but follow the ptrs
1982 * anyway (and make sure they get promoted to this gen).
1987 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1989 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1990 (StgClosure *)*q = evacuate((StgClosure *)*q);
1994 if (failed_to_evac) {
1995 failed_to_evac = rtsFalse;
1996 p->mut_link = gen->mut_list;
2003 /* follow everything */
2004 p->mut_link = gen->mut_list;
2009 end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2010 for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2011 (StgClosure *)*q = evacuate((StgClosure *)*q);
2017 /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2018 * it from the mutable list if possible by promoting whatever it
2021 ASSERT(p->header.info != &MUT_CONS_info);
2022 ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2023 p->mut_link = gen->mut_list;
2029 StgMVar *mvar = (StgMVar *)p;
2030 (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2031 (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2032 (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2033 p->mut_link = gen->mut_list;
2039 /* follow ptrs and remove this from the mutable list */
2041 StgTSO *tso = (StgTSO *)p;
2043 /* Don't bother scavenging if this thread is dead
2045 if (!(tso->whatNext == ThreadComplete ||
2046 tso->whatNext == ThreadKilled)) {
2047 /* Don't need to chase the link field for any TSOs on the
2048 * same queue. Just scavenge this thread's stack
2050 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2053 /* Don't take this TSO off the mutable list - it might still
2054 * point to some younger objects (because we set evac_gen to 0
2057 tso->mut_link = gen->mut_list;
2058 gen->mut_list = (StgMutClosure *)tso;
2064 StgBlockingQueue *bh = (StgBlockingQueue *)p;
2065 (StgClosure *)bh->blocking_queue =
2066 evacuate((StgClosure *)bh->blocking_queue);
2067 p->mut_link = gen->mut_list;
2073 /* shouldn't have anything else on the mutables list */
2074 barf("scavenge_mut_list: strange object?");
2080 scavenge_static(void)
2082 StgClosure* p = static_objects;
2083 const StgInfoTable *info;
2085 /* Always evacuate straight to the oldest generation for static
2087 evac_gen = oldest_gen->no;
2089 /* keep going until we've scavenged all the objects on the linked
2091 while (p != END_OF_STATIC_LIST) {
2095 /* make sure the info pointer is into text space */
2096 ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2097 || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2099 /* Take this object *off* the static_objects list,
2100 * and put it on the scavenged_static_objects list.
2102 static_objects = STATIC_LINK(info,p);
2103 STATIC_LINK(info,p) = scavenged_static_objects;
2104 scavenged_static_objects = p;
2106 switch (info -> type) {
2110 StgInd *ind = (StgInd *)p;
2111 ind->indirectee = evacuate(ind->indirectee);
2113 /* might fail to evacuate it, in which case we have to pop it
2114 * back on the mutable list (and take it off the
2115 * scavenged_static list because the static link and mut link
2116 * pointers are one and the same).
2118 if (failed_to_evac) {
2119 failed_to_evac = rtsFalse;
2120 scavenged_static_objects = STATIC_LINK(info,p);
2121 ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2122 oldest_gen->mut_once_list = (StgMutClosure *)ind;
2136 next = (P_)p->payload + info->layout.payload.ptrs;
2137 /* evacuate the pointers */
2138 for (q = (P_)p->payload; q < next; q++) {
2139 (StgClosure *)*q = evacuate((StgClosure *)*q);
2145 barf("scavenge_static");
2148 ASSERT(failed_to_evac == rtsFalse);
2150 /* get the next static object from the list. Remeber, there might
2151 * be more stuff on this list now that we've done some evacuating!
2152 * (static_objects is a global)
2158 /* -----------------------------------------------------------------------------
2159 scavenge_stack walks over a section of stack and evacuates all the
2160 objects pointed to by it. We can use the same code for walking
2161 PAPs, since these are just sections of copied stack.
2162 -------------------------------------------------------------------------- */
2165 scavenge_stack(StgPtr p, StgPtr stack_end)
2168 const StgInfoTable* info;
2172 * Each time around this loop, we are looking at a chunk of stack
2173 * that starts with either a pending argument section or an
2174 * activation record.
2177 while (p < stack_end) {
2178 q = *stgCast(StgPtr*,p);
2180 /* If we've got a tag, skip over that many words on the stack */
2181 if (IS_ARG_TAG(stgCast(StgWord,q))) {
2186 /* Is q a pointer to a closure?
2188 if (! LOOKS_LIKE_GHC_INFO(q)) {
2191 if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
2192 ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2194 /* otherwise, must be a pointer into the allocation space.
2198 (StgClosure *)*p = evacuate((StgClosure *)q);
2204 * Otherwise, q must be the info pointer of an activation
2205 * record. All activation records have 'bitmap' style layout
2208 info = get_itbl(stgCast(StgClosure*,p));
2210 switch (info->type) {
2212 /* Dynamic bitmap: the mask is stored on the stack */
2214 bitmap = stgCast(StgRetDyn*,p)->liveness;
2215 p = &payloadWord(stgCast(StgRetDyn*,p),0);
2218 /* probably a slow-entry point return address: */
2224 /* Specialised code for update frames, since they're so common.
2225 * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2226 * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2230 StgUpdateFrame *frame = (StgUpdateFrame *)p;
2232 StgClosureType type = get_itbl(frame->updatee)->type;
2234 p += sizeofW(StgUpdateFrame);
2235 if (type == EVACUATED) {
2236 frame->updatee = evacuate(frame->updatee);
2239 bdescr *bd = Bdescr((P_)frame->updatee);
2241 if (bd->gen->no > N) {
2242 if (bd->gen->no < evac_gen) {
2243 failed_to_evac = rtsTrue;
2247 step = bd->step->to;
2251 to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2252 sizeofW(StgHeader), step);
2253 upd_evacuee(frame->updatee,to);
2254 frame->updatee = to;
2257 to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2258 upd_evacuee(frame->updatee,to);
2259 frame->updatee = to;
2260 recordMutable((StgMutClosure *)to);
2263 barf("scavenge_stack: UPDATE_FRAME updatee");
2268 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2275 bitmap = info->layout.bitmap;
2278 while (bitmap != 0) {
2279 if ((bitmap & 1) == 0) {
2280 (StgClosure *)*p = evacuate((StgClosure *)*p);
2283 bitmap = bitmap >> 1;
2290 /* large bitmap (> 32 entries) */
2295 StgLargeBitmap *large_bitmap;
2298 large_bitmap = info->layout.large_bitmap;
2301 for (i=0; i<large_bitmap->size; i++) {
2302 bitmap = large_bitmap->bitmap[i];
2303 q = p + sizeof(W_) * 8;
2304 while (bitmap != 0) {
2305 if ((bitmap & 1) == 0) {
2306 (StgClosure *)*p = evacuate((StgClosure *)*p);
2309 bitmap = bitmap >> 1;
2311 if (i+1 < large_bitmap->size) {
2313 (StgClosure *)*p = evacuate((StgClosure *)*p);
2319 /* and don't forget to follow the SRT */
2324 barf("scavenge_stack: weird activation record found on stack.\n");
2329 /*-----------------------------------------------------------------------------
2330 scavenge the large object list.
2332 evac_gen set by caller; similar games played with evac_gen as with
2333 scavenge() - see comment at the top of scavenge(). Most large
2334 objects are (repeatedly) mutable, so most of the time evac_gen will
2336 --------------------------------------------------------------------------- */
2339 scavenge_large(step *step)
2343 const StgInfoTable* info;
2344 nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2346 evac_gen = 0; /* most objects are mutable */
2347 bd = step->new_large_objects;
2349 for (; bd != NULL; bd = step->new_large_objects) {
2351 /* take this object *off* the large objects list and put it on
2352 * the scavenged large objects list. This is so that we can
2353 * treat new_large_objects as a stack and push new objects on
2354 * the front when evacuating.
2356 step->new_large_objects = bd->link;
2357 dbl_link_onto(bd, &step->scavenged_large_objects);
2360 info = get_itbl(stgCast(StgClosure*,p));
2362 switch (info->type) {
2364 /* only certain objects can be "large"... */
2367 /* nothing to follow */
2371 /* follow everything */
2375 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2376 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2377 (StgClosure *)*p = evacuate((StgClosure *)*p);
2382 case MUT_ARR_PTRS_FROZEN:
2383 /* follow everything */
2385 StgPtr start = p, next;
2387 evac_gen = saved_evac_gen; /* not really mutable */
2388 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2389 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2390 (StgClosure *)*p = evacuate((StgClosure *)*p);
2393 if (failed_to_evac) {
2394 recordMutable((StgMutClosure *)start);
2401 StgBCO* bco = stgCast(StgBCO*,p);
2403 evac_gen = saved_evac_gen;
2404 for (i = 0; i < bco->n_ptrs; i++) {
2405 bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2416 /* chase the link field for any TSOs on the same queue */
2417 (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2418 /* scavenge this thread's stack */
2419 scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2424 barf("scavenge_large: unknown/strange object");
2430 zeroStaticObjectList(StgClosure* first_static)
2434 const StgInfoTable *info;
2436 for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2438 link = STATIC_LINK(info, p);
2439 STATIC_LINK(info,p) = NULL;
2443 /* This function is only needed because we share the mutable link
2444 * field with the static link field in an IND_STATIC, so we have to
2445 * zero the mut_link field before doing a major GC, which needs the
2446 * static link field.
2448 * It doesn't do any harm to zero all the mutable link fields on the
2452 zeroMutableList(StgMutClosure *first)
2454 StgMutClosure *next, *c;
2456 for (c = first; c != END_MUT_LIST; c = next) {
2462 /* -----------------------------------------------------------------------------
2464 -------------------------------------------------------------------------- */
2466 void RevertCAFs(void)
2468 while (enteredCAFs != END_CAF_LIST) {
2469 StgCAF* caf = enteredCAFs;
2471 enteredCAFs = caf->link;
2472 ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2473 SET_INFO(caf,&CAF_UNENTERED_info);
2474 caf->value = stgCast(StgClosure*,0xdeadbeef);
2475 caf->link = stgCast(StgCAF*,0xdeadbeef);
2479 void revertDeadCAFs(void)
2481 StgCAF* caf = enteredCAFs;
2482 enteredCAFs = END_CAF_LIST;
2483 while (caf != END_CAF_LIST) {
2484 StgCAF* next = caf->link;
2486 switch(GET_INFO(caf)->type) {
2489 /* This object has been evacuated, it must be live. */
2490 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2491 new->link = enteredCAFs;
2497 SET_INFO(caf,&CAF_UNENTERED_info);
2498 caf->value = stgCast(StgClosure*,0xdeadbeef);
2499 caf->link = stgCast(StgCAF*,0xdeadbeef);
2503 barf("revertDeadCAFs: enteredCAFs list corrupted");
2509 /* -----------------------------------------------------------------------------
2510 Sanity code for CAF garbage collection.
2512 With DEBUG turned on, we manage a CAF list in addition to the SRT
2513 mechanism. After GC, we run down the CAF list and blackhole any
2514 CAFs which have been garbage collected. This means we get an error
2515 whenever the program tries to enter a garbage collected CAF.
2517 Any garbage collected CAFs are taken off the CAF list at the same
2519 -------------------------------------------------------------------------- */
2527 const StgInfoTable *info;
2538 ASSERT(info->type == IND_STATIC);
2540 if (STATIC_LINK(info,p) == NULL) {
2541 IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2543 SET_INFO(p,&BLACKHOLE_info);
2544 p = STATIC_LINK2(info,p);
2548 pp = &STATIC_LINK2(info,p);
2555 /* fprintf(stderr, "%d CAFs live\n", i); */
2559 /* -----------------------------------------------------------------------------
2562 Whenever a thread returns to the scheduler after possibly doing
2563 some work, we have to run down the stack and black-hole all the
2564 closures referred to by update frames.
2565 -------------------------------------------------------------------------- */
2568 threadLazyBlackHole(StgTSO *tso)
2570 StgUpdateFrame *update_frame;
2571 StgBlockingQueue *bh;
2574 stack_end = &tso->stack[tso->stack_size];
2575 update_frame = tso->su;
2578 switch (get_itbl(update_frame)->type) {
2581 update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2585 bh = (StgBlockingQueue *)update_frame->updatee;
2587 /* if the thunk is already blackholed, it means we've also
2588 * already blackholed the rest of the thunks on this stack,
2589 * so we can stop early.
2591 * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2592 * don't interfere with this optimisation.
2594 if (bh->header.info == &BLACKHOLE_info) {
2598 if (bh->header.info != &BLACKHOLE_BQ_info &&
2599 bh->header.info != &CAF_BLACKHOLE_info) {
2600 SET_INFO(bh,&BLACKHOLE_info);
2603 update_frame = update_frame->link;
2607 update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2613 barf("threadPaused");
2618 /* -----------------------------------------------------------------------------
2621 * Code largely pinched from old RTS, then hacked to bits. We also do
2622 * lazy black holing here.
2624 * -------------------------------------------------------------------------- */
2627 threadSqueezeStack(StgTSO *tso)
2629 lnat displacement = 0;
2630 StgUpdateFrame *frame;
2631 StgUpdateFrame *next_frame; /* Temporally next */
2632 StgUpdateFrame *prev_frame; /* Temporally previous */
2634 rtsBool prev_was_update_frame;
2636 bottom = &(tso->stack[tso->stack_size]);
2639 /* There must be at least one frame, namely the STOP_FRAME.
2641 ASSERT((P_)frame < bottom);
2643 /* Walk down the stack, reversing the links between frames so that
2644 * we can walk back up as we squeeze from the bottom. Note that
2645 * next_frame and prev_frame refer to next and previous as they were
2646 * added to the stack, rather than the way we see them in this
2647 * walk. (It makes the next loop less confusing.)
2649 * Stop if we find an update frame pointing to a black hole
2650 * (see comment in threadLazyBlackHole()).
2654 while ((P_)frame < bottom - 1) { /* bottom - 1 is the STOP_FRAME */
2655 prev_frame = frame->link;
2656 frame->link = next_frame;
2659 if (get_itbl(frame)->type == UPDATE_FRAME
2660 && frame->updatee->header.info == &BLACKHOLE_info) {
2665 /* Now, we're at the bottom. Frame points to the lowest update
2666 * frame on the stack, and its link actually points to the frame
2667 * above. We have to walk back up the stack, squeezing out empty
2668 * update frames and turning the pointers back around on the way
2671 * The bottom-most frame (the STOP_FRAME) has not been altered, and
2672 * we never want to eliminate it anyway. Just walk one step up
2673 * before starting to squeeze. When you get to the topmost frame,
2674 * remember that there are still some words above it that might have
2681 prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2684 * Loop through all of the frames (everything except the very
2685 * bottom). Things are complicated by the fact that we have
2686 * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2687 * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2689 while (frame != NULL) {
2691 StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2692 rtsBool is_update_frame;
2694 next_frame = frame->link;
2695 is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2698 * 1. both the previous and current frame are update frames
2699 * 2. the current frame is empty
2701 if (prev_was_update_frame && is_update_frame &&
2702 (P_)prev_frame == frame_bottom + displacement) {
2704 /* Now squeeze out the current frame */
2705 StgClosure *updatee_keep = prev_frame->updatee;
2706 StgClosure *updatee_bypass = frame->updatee;
2709 fprintf(stderr, "squeezing frame at %p\n", frame);
2712 /* Deal with blocking queues. If both updatees have blocked
2713 * threads, then we should merge the queues into the update
2714 * frame that we're keeping.
2716 * Alternatively, we could just wake them up: they'll just go
2717 * straight to sleep on the proper blackhole! This is less code
2718 * and probably less bug prone, although it's probably much
2721 #if 0 /* do it properly... */
2722 if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
2723 /* Sigh. It has one. Don't lose those threads! */
2724 if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2725 /* Urgh. Two queues. Merge them. */
2726 P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2728 while (keep_tso->link != END_TSO_QUEUE) {
2729 keep_tso = keep_tso->link;
2731 keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2734 /* For simplicity, just swap the BQ for the BH */
2735 P_ temp = updatee_keep;
2737 updatee_keep = updatee_bypass;
2738 updatee_bypass = temp;
2740 /* Record the swap in the kept frame (below) */
2741 prev_frame->updatee = updatee_keep;
2746 TICK_UPD_SQUEEZED();
2747 UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2749 sp = (P_)frame - 1; /* sp = stuff to slide */
2750 displacement += sizeofW(StgUpdateFrame);
2753 /* No squeeze for this frame */
2754 sp = frame_bottom - 1; /* Keep the current frame */
2756 /* Do lazy black-holing.
2758 if (is_update_frame) {
2759 StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2760 if (bh->header.info != &BLACKHOLE_BQ_info &&
2761 bh->header.info != &CAF_BLACKHOLE_info) {
2762 SET_INFO(bh,&BLACKHOLE_info);
2766 /* Fix the link in the current frame (should point to the frame below) */
2767 frame->link = prev_frame;
2768 prev_was_update_frame = is_update_frame;
2771 /* Now slide all words from sp up to the next frame */
2773 if (displacement > 0) {
2774 P_ next_frame_bottom;
2776 if (next_frame != NULL)
2777 next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2779 next_frame_bottom = tso->sp - 1;
2782 fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2786 while (sp >= next_frame_bottom) {
2787 sp[displacement] = *sp;
2791 (P_)prev_frame = (P_)frame + displacement;
2795 tso->sp += displacement;
2796 tso->su = prev_frame;
2799 /* -----------------------------------------------------------------------------
2802 * We have to prepare for GC - this means doing lazy black holing
2803 * here. We also take the opportunity to do stack squeezing if it's
2805 * -------------------------------------------------------------------------- */
2808 threadPaused(StgTSO *tso)
2810 if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2811 threadSqueezeStack(tso); /* does black holing too */
2813 threadLazyBlackHole(tso);