Remove CONSTR_CHARLIKE and CONSTR_INTLIKE closure types
[ghc-hetmet.git] / rts / GC.c
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team 1998-2003
4  *
5  * Generational garbage collector
6  *
7  * ---------------------------------------------------------------------------*/
8
9 #include "PosixSource.h"
10 #include "Rts.h"
11 #include "RtsFlags.h"
12 #include "RtsUtils.h"
13 #include "Apply.h"
14 #include "OSThreads.h"
15 #include "Storage.h"
16 #include "LdvProfile.h"
17 #include "Updates.h"
18 #include "Stats.h"
19 #include "Schedule.h"
20 #include "Sanity.h"
21 #include "BlockAlloc.h"
22 #include "MBlock.h"
23 #include "ProfHeap.h"
24 #include "SchedAPI.h"
25 #include "Weak.h"
26 #include "Prelude.h"
27 #include "ParTicky.h"           // ToDo: move into Rts.h
28 #include "GCCompact.h"
29 #include "RtsSignals.h"
30 #include "STM.h"
31 #if defined(GRAN) || defined(PAR)
32 # include "GranSimRts.h"
33 # include "ParallelRts.h"
34 # include "FetchMe.h"
35 # if defined(DEBUG)
36 #  include "Printer.h"
37 #  include "ParallelDebug.h"
38 # endif
39 #endif
40 #include "HsFFI.h"
41 #include "Linker.h"
42 #if defined(RTS_GTK_FRONTPANEL)
43 #include "FrontPanel.h"
44 #endif
45 #include "Trace.h"
46 #include "RetainerProfile.h"
47 #include "RaiseAsync.h"
48
49 #include <string.h>
50
51 // Turn off inlining when debugging - it obfuscates things
52 #ifdef DEBUG
53 # undef  STATIC_INLINE
54 # define STATIC_INLINE static
55 #endif
56
57 /* STATIC OBJECT LIST.
58  *
59  * During GC:
60  * We maintain a linked list of static objects that are still live.
61  * The requirements for this list are:
62  *
63  *  - we need to scan the list while adding to it, in order to
64  *    scavenge all the static objects (in the same way that
65  *    breadth-first scavenging works for dynamic objects).
66  *
67  *  - we need to be able to tell whether an object is already on
68  *    the list, to break loops.
69  *
70  * Each static object has a "static link field", which we use for
71  * linking objects on to the list.  We use a stack-type list, consing
72  * objects on the front as they are added (this means that the
73  * scavenge phase is depth-first, not breadth-first, but that
74  * shouldn't matter).  
75  *
76  * A separate list is kept for objects that have been scavenged
77  * already - this is so that we can zero all the marks afterwards.
78  *
79  * An object is on the list if its static link field is non-zero; this
80  * means that we have to mark the end of the list with '1', not NULL.  
81  *
82  * Extra notes for generational GC:
83  *
84  * Each generation has a static object list associated with it.  When
85  * collecting generations up to N, we treat the static object lists
86  * from generations > N as roots.
87  *
88  * We build up a static object list while collecting generations 0..N,
89  * which is then appended to the static object list of generation N+1.
90  */
91 static StgClosure* static_objects;      // live static objects
92 StgClosure* scavenged_static_objects;   // static objects scavenged so far
93
94 /* N is the oldest generation being collected, where the generations
95  * are numbered starting at 0.  A major GC (indicated by the major_gc
96  * flag) is when we're collecting all generations.  We only attempt to
97  * deal with static objects and GC CAFs when doing a major GC.
98  */
99 static nat N;
100 static rtsBool major_gc;
101
102 /* Youngest generation that objects should be evacuated to in
103  * evacuate().  (Logically an argument to evacuate, but it's static
104  * a lot of the time so we optimise it into a global variable).
105  */
106 static nat evac_gen;
107
108 /* Whether to do eager promotion or not.
109  */
110 static rtsBool eager_promotion;
111
112 /* Weak pointers
113  */
114 StgWeak *old_weak_ptr_list; // also pending finaliser list
115
116 /* Which stage of processing various kinds of weak pointer are we at?
117  * (see traverse_weak_ptr_list() below for discussion).
118  */
119 typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage;
120 static WeakStage weak_stage;
121
122 /* List of all threads during GC
123  */
124 static StgTSO *old_all_threads;
125 StgTSO *resurrected_threads;
126
127 /* Flag indicating failure to evacuate an object to the desired
128  * generation.
129  */
130 static rtsBool failed_to_evac;
131
132 /* Saved nursery (used for 2-space collector only)
133  */
134 static bdescr *saved_nursery;
135 static nat saved_n_blocks;
136   
137 /* Data used for allocation area sizing.
138  */
139 static lnat new_blocks;          // blocks allocated during this GC 
140 static lnat new_scavd_blocks;    // ditto, but depth-first blocks
141 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC 
142
143 /* Used to avoid long recursion due to selector thunks
144  */
145 static lnat thunk_selector_depth = 0;
146 #define MAX_THUNK_SELECTOR_DEPTH 8
147
148 /* Mut-list stats */
149 #ifdef DEBUG
150 static nat 
151     mutlist_MUTVARS,
152     mutlist_MUTARRS,
153     mutlist_OTHERS;
154 #endif
155
156 /* -----------------------------------------------------------------------------
157    Static function declarations
158    -------------------------------------------------------------------------- */
159
160 static bdescr *     gc_alloc_block          ( step *stp );
161 static void         mark_root               ( StgClosure **root );
162
163 // Use a register argument for evacuate, if available.
164 #if __GNUC__ >= 2
165 #define REGPARM1 __attribute__((regparm(1)))
166 #else
167 #define REGPARM1
168 #endif
169
170 REGPARM1 static StgClosure * evacuate (StgClosure *q);
171
172 static void         zero_static_object_list ( StgClosure* first_static );
173
174 static rtsBool      traverse_weak_ptr_list  ( void );
175 static void         mark_weak_ptr_list      ( StgWeak **list );
176 static rtsBool      traverse_blackhole_queue ( void );
177
178 static StgClosure * eval_thunk_selector     ( nat field, StgSelector * p );
179
180
181 static void    scavenge                ( step * );
182 static void    scavenge_mark_stack     ( void );
183 static void    scavenge_stack          ( StgPtr p, StgPtr stack_end );
184 static rtsBool scavenge_one            ( StgPtr p );
185 static void    scavenge_large          ( step * );
186 static void    scavenge_static         ( void );
187 static void    scavenge_mutable_list   ( generation *g );
188
189 static void    scavenge_large_bitmap   ( StgPtr p, 
190                                          StgLargeBitmap *large_bitmap, 
191                                          nat size );
192
193 #if 0 && defined(DEBUG)
194 static void         gcCAFs                  ( void );
195 #endif
196
197 /* -----------------------------------------------------------------------------
198    inline functions etc. for dealing with the mark bitmap & stack.
199    -------------------------------------------------------------------------- */
200
201 #define MARK_STACK_BLOCKS 4
202
203 static bdescr *mark_stack_bdescr;
204 static StgPtr *mark_stack;
205 static StgPtr *mark_sp;
206 static StgPtr *mark_splim;
207
208 // Flag and pointers used for falling back to a linear scan when the
209 // mark stack overflows.
210 static rtsBool mark_stack_overflowed;
211 static bdescr *oldgen_scan_bd;
212 static StgPtr  oldgen_scan;
213
214 STATIC_INLINE rtsBool
215 mark_stack_empty(void)
216 {
217     return mark_sp == mark_stack;
218 }
219
220 STATIC_INLINE rtsBool
221 mark_stack_full(void)
222 {
223     return mark_sp >= mark_splim;
224 }
225
226 STATIC_INLINE void
227 reset_mark_stack(void)
228 {
229     mark_sp = mark_stack;
230 }
231
232 STATIC_INLINE void
233 push_mark_stack(StgPtr p)
234 {
235     *mark_sp++ = p;
236 }
237
238 STATIC_INLINE StgPtr
239 pop_mark_stack(void)
240 {
241     return *--mark_sp;
242 }
243
244 /* -----------------------------------------------------------------------------
245    Allocate a new to-space block in the given step.
246    -------------------------------------------------------------------------- */
247
248 static bdescr *
249 gc_alloc_block(step *stp)
250 {
251     bdescr *bd = allocBlock();
252     bd->gen_no = stp->gen_no;
253     bd->step = stp;
254     bd->link = NULL;
255
256     // blocks in to-space in generations up to and including N
257     // get the BF_EVACUATED flag.
258     if (stp->gen_no <= N) {
259         bd->flags = BF_EVACUATED;
260     } else {
261         bd->flags = 0;
262     }
263
264     // Start a new to-space block, chain it on after the previous one.
265     if (stp->hp_bd != NULL) {
266         stp->hp_bd->free = stp->hp;
267         stp->hp_bd->link = bd;
268     }
269
270     stp->hp_bd = bd;
271     stp->hp    = bd->start;
272     stp->hpLim = stp->hp + BLOCK_SIZE_W;
273
274     stp->n_blocks++;
275     new_blocks++;
276
277     return bd;
278 }
279
280 static bdescr *
281 gc_alloc_scavd_block(step *stp)
282 {
283     bdescr *bd = allocBlock();
284     bd->gen_no = stp->gen_no;
285     bd->step = stp;
286
287     // blocks in to-space in generations up to and including N
288     // get the BF_EVACUATED flag.
289     if (stp->gen_no <= N) {
290         bd->flags = BF_EVACUATED;
291     } else {
292         bd->flags = 0;
293     }
294
295     bd->link = stp->blocks;
296     stp->blocks = bd;
297
298     if (stp->scavd_hp != NULL) {
299         Bdescr(stp->scavd_hp)->free = stp->scavd_hp;
300     }
301     stp->scavd_hp    = bd->start;
302     stp->scavd_hpLim = stp->scavd_hp + BLOCK_SIZE_W;
303
304     stp->n_blocks++;
305     new_scavd_blocks++;
306
307     return bd;
308 }
309
310 /* -----------------------------------------------------------------------------
311    GarbageCollect
312
313    Rough outline of the algorithm: for garbage collecting generation N
314    (and all younger generations):
315
316      - follow all pointers in the root set.  the root set includes all 
317        mutable objects in all generations (mutable_list).
318
319      - for each pointer, evacuate the object it points to into either
320
321        + to-space of the step given by step->to, which is the next
322          highest step in this generation or the first step in the next
323          generation if this is the last step.
324
325        + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
326          When we evacuate an object we attempt to evacuate
327          everything it points to into the same generation - this is
328          achieved by setting evac_gen to the desired generation.  If
329          we can't do this, then an entry in the mut list has to
330          be made for the cross-generation pointer.
331
332        + if the object is already in a generation > N, then leave
333          it alone.
334
335      - repeatedly scavenge to-space from each step in each generation
336        being collected until no more objects can be evacuated.
337       
338      - free from-space in each step, and set from-space = to-space.
339
340    Locks held: all capabilities are held throughout GarbageCollect().
341
342    -------------------------------------------------------------------------- */
343
344 void
345 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
346 {
347   bdescr *bd;
348   step *stp;
349   lnat live, allocated, copied = 0, scavd_copied = 0;
350   lnat oldgen_saved_blocks = 0;
351   nat g, s, i;
352
353   ACQUIRE_SM_LOCK;
354
355 #ifdef PROFILING
356   CostCentreStack *prev_CCS;
357 #endif
358
359   debugTrace(DEBUG_gc, "starting GC");
360
361 #if defined(RTS_USER_SIGNALS)
362   // block signals
363   blockUserSignals();
364 #endif
365
366   // tell the STM to discard any cached closures its hoping to re-use
367   stmPreGCHook();
368
369   // tell the stats department that we've started a GC 
370   stat_startGC();
371
372 #ifdef DEBUG
373   // check for memory leaks if DEBUG is on 
374   memInventory();
375 #endif
376
377 #ifdef DEBUG
378   mutlist_MUTVARS = 0;
379   mutlist_MUTARRS = 0;
380   mutlist_OTHERS = 0;
381 #endif
382
383   // Init stats and print par specific (timing) info 
384   PAR_TICKY_PAR_START();
385
386   // attribute any costs to CCS_GC 
387 #ifdef PROFILING
388   prev_CCS = CCCS;
389   CCCS = CCS_GC;
390 #endif
391
392   /* Approximate how much we allocated.  
393    * Todo: only when generating stats? 
394    */
395   allocated = calcAllocated();
396
397   /* Figure out which generation to collect
398    */
399   if (force_major_gc) {
400     N = RtsFlags.GcFlags.generations - 1;
401     major_gc = rtsTrue;
402   } else {
403     N = 0;
404     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
405       if (generations[g].steps[0].n_blocks +
406           generations[g].steps[0].n_large_blocks
407           >= generations[g].max_blocks) {
408         N = g;
409       }
410     }
411     major_gc = (N == RtsFlags.GcFlags.generations-1);
412   }
413
414 #ifdef RTS_GTK_FRONTPANEL
415   if (RtsFlags.GcFlags.frontpanel) {
416       updateFrontPanelBeforeGC(N);
417   }
418 #endif
419
420   // check stack sanity *before* GC (ToDo: check all threads) 
421 #if defined(GRAN)
422   // ToDo!: check sanity  IF_DEBUG(sanity, checkTSOsSanity());
423 #endif
424   IF_DEBUG(sanity, checkFreeListSanity());
425
426   /* Initialise the static object lists
427    */
428   static_objects = END_OF_STATIC_LIST;
429   scavenged_static_objects = END_OF_STATIC_LIST;
430
431   /* Save the nursery if we're doing a two-space collection.
432    * g0s0->blocks will be used for to-space, so we need to get the
433    * nursery out of the way.
434    */
435   if (RtsFlags.GcFlags.generations == 1) {
436       saved_nursery = g0s0->blocks;
437       saved_n_blocks = g0s0->n_blocks;
438       g0s0->blocks = NULL;
439       g0s0->n_blocks = 0;
440   }
441
442   /* Keep a count of how many new blocks we allocated during this GC
443    * (used for resizing the allocation area, later).
444    */
445   new_blocks = 0;
446   new_scavd_blocks = 0;
447
448   // Initialise to-space in all the generations/steps that we're
449   // collecting.
450   //
451   for (g = 0; g <= N; g++) {
452
453     // throw away the mutable list.  Invariant: the mutable list
454     // always has at least one block; this means we can avoid a check for
455     // NULL in recordMutable().
456     if (g != 0) {
457         freeChain(generations[g].mut_list);
458         generations[g].mut_list = allocBlock();
459         for (i = 0; i < n_capabilities; i++) {
460             freeChain(capabilities[i].mut_lists[g]);
461             capabilities[i].mut_lists[g] = allocBlock();
462         }
463     }
464
465     for (s = 0; s < generations[g].n_steps; s++) {
466
467       // generation 0, step 0 doesn't need to-space 
468       if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) { 
469         continue; 
470       }
471
472       stp = &generations[g].steps[s];
473       ASSERT(stp->gen_no == g);
474
475       // start a new to-space for this step.
476       stp->old_blocks   = stp->blocks;
477       stp->n_old_blocks = stp->n_blocks;
478
479       // allocate the first to-space block; extra blocks will be
480       // chained on as necessary.
481       stp->hp_bd     = NULL;
482       bd = gc_alloc_block(stp);
483       stp->blocks      = bd;
484       stp->n_blocks    = 1;
485       stp->scan        = bd->start;
486       stp->scan_bd     = bd;
487
488       // allocate a block for "already scavenged" objects.  This goes
489       // on the front of the stp->blocks list, so it won't be
490       // traversed by the scavenging sweep.
491       gc_alloc_scavd_block(stp);
492
493       // initialise the large object queues.
494       stp->new_large_objects = NULL;
495       stp->scavenged_large_objects = NULL;
496       stp->n_scavenged_large_blocks = 0;
497
498       // mark the large objects as not evacuated yet 
499       for (bd = stp->large_objects; bd; bd = bd->link) {
500         bd->flags &= ~BF_EVACUATED;
501       }
502
503       // for a compacted step, we need to allocate the bitmap
504       if (stp->is_compacted) {
505           nat bitmap_size; // in bytes
506           bdescr *bitmap_bdescr;
507           StgWord *bitmap;
508
509           bitmap_size = stp->n_old_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
510
511           if (bitmap_size > 0) {
512               bitmap_bdescr = allocGroup((lnat)BLOCK_ROUND_UP(bitmap_size) 
513                                          / BLOCK_SIZE);
514               stp->bitmap = bitmap_bdescr;
515               bitmap = bitmap_bdescr->start;
516               
517               debugTrace(DEBUG_gc, "bitmap_size: %d, bitmap: %p",
518                          bitmap_size, bitmap);
519               
520               // don't forget to fill it with zeros!
521               memset(bitmap, 0, bitmap_size);
522               
523               // For each block in this step, point to its bitmap from the
524               // block descriptor.
525               for (bd=stp->old_blocks; bd != NULL; bd = bd->link) {
526                   bd->u.bitmap = bitmap;
527                   bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
528
529                   // Also at this point we set the BF_COMPACTED flag
530                   // for this block.  The invariant is that
531                   // BF_COMPACTED is always unset, except during GC
532                   // when it is set on those blocks which will be
533                   // compacted.
534                   bd->flags |= BF_COMPACTED;
535               }
536           }
537       }
538     }
539   }
540
541   /* make sure the older generations have at least one block to
542    * allocate into (this makes things easier for copy(), see below).
543    */
544   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
545     for (s = 0; s < generations[g].n_steps; s++) {
546       stp = &generations[g].steps[s];
547       if (stp->hp_bd == NULL) {
548           ASSERT(stp->blocks == NULL);
549           bd = gc_alloc_block(stp);
550           stp->blocks = bd;
551           stp->n_blocks = 1;
552       }
553       if (stp->scavd_hp == NULL) {
554           gc_alloc_scavd_block(stp);
555           stp->n_blocks++;
556       }
557       /* Set the scan pointer for older generations: remember we
558        * still have to scavenge objects that have been promoted. */
559       stp->scan = stp->hp;
560       stp->scan_bd = stp->hp_bd;
561       stp->new_large_objects = NULL;
562       stp->scavenged_large_objects = NULL;
563       stp->n_scavenged_large_blocks = 0;
564     }
565
566     /* Move the private mutable lists from each capability onto the
567      * main mutable list for the generation.
568      */
569     for (i = 0; i < n_capabilities; i++) {
570         for (bd = capabilities[i].mut_lists[g]; 
571              bd->link != NULL; bd = bd->link) {
572             /* nothing */
573         }
574         bd->link = generations[g].mut_list;
575         generations[g].mut_list = capabilities[i].mut_lists[g];
576         capabilities[i].mut_lists[g] = allocBlock();
577     }
578   }
579
580   /* Allocate a mark stack if we're doing a major collection.
581    */
582   if (major_gc) {
583       mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
584       mark_stack = (StgPtr *)mark_stack_bdescr->start;
585       mark_sp    = mark_stack;
586       mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
587   } else {
588       mark_stack_bdescr = NULL;
589   }
590
591   eager_promotion = rtsTrue; // for now
592
593   /* -----------------------------------------------------------------------
594    * follow all the roots that we know about:
595    *   - mutable lists from each generation > N
596    * we want to *scavenge* these roots, not evacuate them: they're not
597    * going to move in this GC.
598    * Also: do them in reverse generation order.  This is because we
599    * often want to promote objects that are pointed to by older
600    * generations early, so we don't have to repeatedly copy them.
601    * Doing the generations in reverse order ensures that we don't end
602    * up in the situation where we want to evac an object to gen 3 and
603    * it has already been evaced to gen 2.
604    */
605   { 
606     int st;
607     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
608       generations[g].saved_mut_list = generations[g].mut_list;
609       generations[g].mut_list = allocBlock(); 
610         // mut_list always has at least one block.
611     }
612
613     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
614       IF_PAR_DEBUG(verbose, printMutableList(&generations[g]));
615       scavenge_mutable_list(&generations[g]);
616       evac_gen = g;
617       for (st = generations[g].n_steps-1; st >= 0; st--) {
618         scavenge(&generations[g].steps[st]);
619       }
620     }
621   }
622
623   /* follow roots from the CAF list (used by GHCi)
624    */
625   evac_gen = 0;
626   markCAFs(mark_root);
627
628   /* follow all the roots that the application knows about.
629    */
630   evac_gen = 0;
631   get_roots(mark_root);
632
633 #if defined(PAR)
634   /* And don't forget to mark the TSO if we got here direct from
635    * Haskell! */
636   /* Not needed in a seq version?
637   if (CurrentTSO) {
638     CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
639   }
640   */
641
642   // Mark the entries in the GALA table of the parallel system 
643   markLocalGAs(major_gc);
644   // Mark all entries on the list of pending fetches 
645   markPendingFetches(major_gc);
646 #endif
647
648   /* Mark the weak pointer list, and prepare to detect dead weak
649    * pointers.
650    */
651   mark_weak_ptr_list(&weak_ptr_list);
652   old_weak_ptr_list = weak_ptr_list;
653   weak_ptr_list = NULL;
654   weak_stage = WeakPtrs;
655
656   /* The all_threads list is like the weak_ptr_list.  
657    * See traverse_weak_ptr_list() for the details.
658    */
659   old_all_threads = all_threads;
660   all_threads = END_TSO_QUEUE;
661   resurrected_threads = END_TSO_QUEUE;
662
663   /* Mark the stable pointer table.
664    */
665   markStablePtrTable(mark_root);
666
667   /* Mark the root pointer table.
668    */
669   markRootPtrTable(mark_root);
670
671   /* -------------------------------------------------------------------------
672    * Repeatedly scavenge all the areas we know about until there's no
673    * more scavenging to be done.
674    */
675   { 
676     rtsBool flag;
677   loop:
678     flag = rtsFalse;
679
680     // scavenge static objects 
681     if (major_gc && static_objects != END_OF_STATIC_LIST) {
682         IF_DEBUG(sanity, checkStaticObjects(static_objects));
683         scavenge_static();
684     }
685
686     /* When scavenging the older generations:  Objects may have been
687      * evacuated from generations <= N into older generations, and we
688      * need to scavenge these objects.  We're going to try to ensure that
689      * any evacuations that occur move the objects into at least the
690      * same generation as the object being scavenged, otherwise we
691      * have to create new entries on the mutable list for the older
692      * generation.
693      */
694
695     // scavenge each step in generations 0..maxgen 
696     { 
697       long gen;
698       int st; 
699
700     loop2:
701       // scavenge objects in compacted generation
702       if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
703           (mark_stack_bdescr != NULL && !mark_stack_empty())) {
704           scavenge_mark_stack();
705           flag = rtsTrue;
706       }
707
708       for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
709         for (st = generations[gen].n_steps; --st >= 0; ) {
710           if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) { 
711             continue; 
712           }
713           stp = &generations[gen].steps[st];
714           evac_gen = gen;
715           if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
716             scavenge(stp);
717             flag = rtsTrue;
718             goto loop2;
719           }
720           if (stp->new_large_objects != NULL) {
721             scavenge_large(stp);
722             flag = rtsTrue;
723             goto loop2;
724           }
725         }
726       }
727     }
728
729     // if any blackholes are alive, make the threads that wait on
730     // them alive too.
731     if (traverse_blackhole_queue())
732         flag = rtsTrue;
733
734     if (flag) { goto loop; }
735
736     // must be last...  invariant is that everything is fully
737     // scavenged at this point.
738     if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something 
739       goto loop;
740     }
741   }
742
743   /* Update the pointers from the task list - these are
744    * treated as weak pointers because we want to allow a main thread
745    * to get a BlockedOnDeadMVar exception in the same way as any other
746    * thread.  Note that the threads should all have been retained by
747    * GC by virtue of being on the all_threads list, we're just
748    * updating pointers here.
749    */
750   {
751       Task *task;
752       StgTSO *tso;
753       for (task = all_tasks; task != NULL; task = task->all_link) {
754           if (!task->stopped && task->tso) {
755               ASSERT(task->tso->bound == task);
756               tso = (StgTSO *) isAlive((StgClosure *)task->tso);
757               if (tso == NULL) {
758                   barf("task %p: main thread %d has been GC'd", 
759 #ifdef THREADED_RTS
760                        (void *)task->id, 
761 #else
762                        (void *)task,
763 #endif
764                        task->tso->id);
765               }
766               task->tso = tso;
767           }
768       }
769   }
770
771 #if defined(PAR)
772   // Reconstruct the Global Address tables used in GUM 
773   rebuildGAtables(major_gc);
774   IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
775 #endif
776
777   // Now see which stable names are still alive.
778   gcStablePtrTable();
779
780   // Tidy the end of the to-space chains 
781   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
782       for (s = 0; s < generations[g].n_steps; s++) {
783           stp = &generations[g].steps[s];
784           if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
785               ASSERT(Bdescr(stp->hp) == stp->hp_bd);
786               stp->hp_bd->free = stp->hp;
787               Bdescr(stp->scavd_hp)->free = stp->scavd_hp;
788           }
789       }
790   }
791
792 #ifdef PROFILING
793   // We call processHeapClosureForDead() on every closure destroyed during
794   // the current garbage collection, so we invoke LdvCensusForDead().
795   if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV
796       || RtsFlags.ProfFlags.bioSelector != NULL)
797     LdvCensusForDead(N);
798 #endif
799
800   // NO MORE EVACUATION AFTER THIS POINT!
801   // Finally: compaction of the oldest generation.
802   if (major_gc && oldest_gen->steps[0].is_compacted) {
803       // save number of blocks for stats
804       oldgen_saved_blocks = oldest_gen->steps[0].n_old_blocks;
805       compact(get_roots);
806   }
807
808   IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
809
810   /* run through all the generations/steps and tidy up 
811    */
812   copied = new_blocks * BLOCK_SIZE_W;
813   scavd_copied =  new_scavd_blocks * BLOCK_SIZE_W;
814   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
815
816     if (g <= N) {
817       generations[g].collections++; // for stats 
818     }
819
820     // Count the mutable list as bytes "copied" for the purposes of
821     // stats.  Every mutable list is copied during every GC.
822     if (g > 0) {
823         nat mut_list_size = 0;
824         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
825             mut_list_size += bd->free - bd->start;
826         }
827         copied +=  mut_list_size;
828
829         debugTrace(DEBUG_gc,
830                    "mut_list_size: %lu (%d vars, %d arrays, %d others)",
831                    (unsigned long)(mut_list_size * sizeof(W_)),
832                    mutlist_MUTVARS, mutlist_MUTARRS, mutlist_OTHERS);
833     }
834
835     for (s = 0; s < generations[g].n_steps; s++) {
836       bdescr *next;
837       stp = &generations[g].steps[s];
838
839       if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
840         // stats information: how much we copied 
841         if (g <= N) {
842           copied -= stp->hp_bd->start + BLOCK_SIZE_W -
843             stp->hp_bd->free;
844           scavd_copied -= (P_)(BLOCK_ROUND_UP(stp->scavd_hp)) - stp->scavd_hp;
845         }
846       }
847
848       // for generations we collected... 
849       if (g <= N) {
850
851         /* free old memory and shift to-space into from-space for all
852          * the collected steps (except the allocation area).  These
853          * freed blocks will probaby be quickly recycled.
854          */
855         if (!(g == 0 && s == 0)) {
856             if (stp->is_compacted) {
857                 // for a compacted step, just shift the new to-space
858                 // onto the front of the now-compacted existing blocks.
859                 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
860                     bd->flags &= ~BF_EVACUATED;  // now from-space 
861                 }
862                 // tack the new blocks on the end of the existing blocks
863                 if (stp->old_blocks != NULL) {
864                     for (bd = stp->old_blocks; bd != NULL; bd = next) {
865                         // NB. this step might not be compacted next
866                         // time, so reset the BF_COMPACTED flags.
867                         // They are set before GC if we're going to
868                         // compact.  (search for BF_COMPACTED above).
869                         bd->flags &= ~BF_COMPACTED;
870                         next = bd->link;
871                         if (next == NULL) {
872                             bd->link = stp->blocks;
873                         }
874                     }
875                     stp->blocks = stp->old_blocks;
876                 }
877                 // add the new blocks to the block tally
878                 stp->n_blocks += stp->n_old_blocks;
879                 ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
880             } else {
881                 freeChain(stp->old_blocks);
882                 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
883                     bd->flags &= ~BF_EVACUATED;  // now from-space 
884                 }
885             }
886             stp->old_blocks = NULL;
887             stp->n_old_blocks = 0;
888         }
889
890         /* LARGE OBJECTS.  The current live large objects are chained on
891          * scavenged_large, having been moved during garbage
892          * collection from large_objects.  Any objects left on
893          * large_objects list are therefore dead, so we free them here.
894          */
895         for (bd = stp->large_objects; bd != NULL; bd = next) {
896           next = bd->link;
897           freeGroup(bd);
898           bd = next;
899         }
900
901         // update the count of blocks used by large objects
902         for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
903           bd->flags &= ~BF_EVACUATED;
904         }
905         stp->large_objects  = stp->scavenged_large_objects;
906         stp->n_large_blocks = stp->n_scavenged_large_blocks;
907
908       } else {
909         // for older generations... 
910         
911         /* For older generations, we need to append the
912          * scavenged_large_object list (i.e. large objects that have been
913          * promoted during this GC) to the large_object list for that step.
914          */
915         for (bd = stp->scavenged_large_objects; bd; bd = next) {
916           next = bd->link;
917           bd->flags &= ~BF_EVACUATED;
918           dbl_link_onto(bd, &stp->large_objects);
919         }
920
921         // add the new blocks we promoted during this GC 
922         stp->n_large_blocks += stp->n_scavenged_large_blocks;
923       }
924     }
925   }
926
927   /* Reset the sizes of the older generations when we do a major
928    * collection.
929    *
930    * CURRENT STRATEGY: make all generations except zero the same size.
931    * We have to stay within the maximum heap size, and leave a certain
932    * percentage of the maximum heap size available to allocate into.
933    */
934   if (major_gc && RtsFlags.GcFlags.generations > 1) {
935       nat live, size, min_alloc;
936       nat max  = RtsFlags.GcFlags.maxHeapSize;
937       nat gens = RtsFlags.GcFlags.generations;
938
939       // live in the oldest generations
940       live = oldest_gen->steps[0].n_blocks +
941              oldest_gen->steps[0].n_large_blocks;
942
943       // default max size for all generations except zero
944       size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
945                      RtsFlags.GcFlags.minOldGenSize);
946
947       // minimum size for generation zero
948       min_alloc = stg_max((RtsFlags.GcFlags.pcFreeHeap * max) / 200,
949                           RtsFlags.GcFlags.minAllocAreaSize);
950
951       // Auto-enable compaction when the residency reaches a
952       // certain percentage of the maximum heap size (default: 30%).
953       if (RtsFlags.GcFlags.generations > 1 &&
954           (RtsFlags.GcFlags.compact ||
955            (max > 0 &&
956             oldest_gen->steps[0].n_blocks > 
957             (RtsFlags.GcFlags.compactThreshold * max) / 100))) {
958           oldest_gen->steps[0].is_compacted = 1;
959 //        debugBelch("compaction: on\n", live);
960       } else {
961           oldest_gen->steps[0].is_compacted = 0;
962 //        debugBelch("compaction: off\n", live);
963       }
964
965       // if we're going to go over the maximum heap size, reduce the
966       // size of the generations accordingly.  The calculation is
967       // different if compaction is turned on, because we don't need
968       // to double the space required to collect the old generation.
969       if (max != 0) {
970
971           // this test is necessary to ensure that the calculations
972           // below don't have any negative results - we're working
973           // with unsigned values here.
974           if (max < min_alloc) {
975               heapOverflow();
976           }
977
978           if (oldest_gen->steps[0].is_compacted) {
979               if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
980                   size = (max - min_alloc) / ((gens - 1) * 2 - 1);
981               }
982           } else {
983               if ( (size * (gens - 1) * 2) + min_alloc > max ) {
984                   size = (max - min_alloc) / ((gens - 1) * 2);
985               }
986           }
987
988           if (size < live) {
989               heapOverflow();
990           }
991       }
992
993 #if 0
994       debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live,
995               min_alloc, size, max);
996 #endif
997
998       for (g = 0; g < gens; g++) {
999           generations[g].max_blocks = size;
1000       }
1001   }
1002
1003   // Guess the amount of live data for stats.
1004   live = calcLive();
1005
1006   /* Free the small objects allocated via allocate(), since this will
1007    * all have been copied into G0S1 now.  
1008    */
1009   if (small_alloc_list != NULL) {
1010     freeChain(small_alloc_list);
1011   }
1012   small_alloc_list = NULL;
1013   alloc_blocks = 0;
1014   alloc_Hp = NULL;
1015   alloc_HpLim = NULL;
1016   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
1017
1018   // Start a new pinned_object_block
1019   pinned_object_block = NULL;
1020
1021   /* Free the mark stack.
1022    */
1023   if (mark_stack_bdescr != NULL) {
1024       freeGroup(mark_stack_bdescr);
1025   }
1026
1027   /* Free any bitmaps.
1028    */
1029   for (g = 0; g <= N; g++) {
1030       for (s = 0; s < generations[g].n_steps; s++) {
1031           stp = &generations[g].steps[s];
1032           if (stp->bitmap != NULL) {
1033               freeGroup(stp->bitmap);
1034               stp->bitmap = NULL;
1035           }
1036       }
1037   }
1038
1039   /* Two-space collector:
1040    * Free the old to-space, and estimate the amount of live data.
1041    */
1042   if (RtsFlags.GcFlags.generations == 1) {
1043     nat blocks;
1044     
1045     if (g0s0->old_blocks != NULL) {
1046       freeChain(g0s0->old_blocks);
1047     }
1048     for (bd = g0s0->blocks; bd != NULL; bd = bd->link) {
1049       bd->flags = 0;    // now from-space 
1050     }
1051     g0s0->old_blocks = g0s0->blocks;
1052     g0s0->n_old_blocks = g0s0->n_blocks;
1053     g0s0->blocks = saved_nursery;
1054     g0s0->n_blocks = saved_n_blocks;
1055
1056     /* For a two-space collector, we need to resize the nursery. */
1057     
1058     /* set up a new nursery.  Allocate a nursery size based on a
1059      * function of the amount of live data (by default a factor of 2)
1060      * Use the blocks from the old nursery if possible, freeing up any
1061      * left over blocks.
1062      *
1063      * If we get near the maximum heap size, then adjust our nursery
1064      * size accordingly.  If the nursery is the same size as the live
1065      * data (L), then we need 3L bytes.  We can reduce the size of the
1066      * nursery to bring the required memory down near 2L bytes.
1067      * 
1068      * A normal 2-space collector would need 4L bytes to give the same
1069      * performance we get from 3L bytes, reducing to the same
1070      * performance at 2L bytes.
1071      */
1072     blocks = g0s0->n_old_blocks;
1073
1074     if ( RtsFlags.GcFlags.maxHeapSize != 0 &&
1075          blocks * RtsFlags.GcFlags.oldGenFactor * 2 > 
1076            RtsFlags.GcFlags.maxHeapSize ) {
1077       long adjusted_blocks;  // signed on purpose 
1078       int pc_free; 
1079       
1080       adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
1081
1082       debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", 
1083                  RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks);
1084
1085       pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
1086       if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
1087         heapOverflow();
1088       }
1089       blocks = adjusted_blocks;
1090       
1091     } else {
1092       blocks *= RtsFlags.GcFlags.oldGenFactor;
1093       if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
1094         blocks = RtsFlags.GcFlags.minAllocAreaSize;
1095       }
1096     }
1097     resizeNurseries(blocks);
1098     
1099   } else {
1100     /* Generational collector:
1101      * If the user has given us a suggested heap size, adjust our
1102      * allocation area to make best use of the memory available.
1103      */
1104
1105     if (RtsFlags.GcFlags.heapSizeSuggestion) {
1106       long blocks;
1107       nat needed = calcNeeded();        // approx blocks needed at next GC 
1108
1109       /* Guess how much will be live in generation 0 step 0 next time.
1110        * A good approximation is obtained by finding the
1111        * percentage of g0s0 that was live at the last minor GC.
1112        */
1113       if (N == 0) {
1114         g0s0_pcnt_kept = (new_blocks * 100) / countNurseryBlocks();
1115       }
1116
1117       /* Estimate a size for the allocation area based on the
1118        * information available.  We might end up going slightly under
1119        * or over the suggested heap size, but we should be pretty
1120        * close on average.
1121        *
1122        * Formula:            suggested - needed
1123        *                ----------------------------
1124        *                    1 + g0s0_pcnt_kept/100
1125        *
1126        * where 'needed' is the amount of memory needed at the next
1127        * collection for collecting all steps except g0s0.
1128        */
1129       blocks = 
1130         (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
1131         (100 + (long)g0s0_pcnt_kept);
1132       
1133       if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
1134         blocks = RtsFlags.GcFlags.minAllocAreaSize;
1135       }
1136       
1137       resizeNurseries((nat)blocks);
1138
1139     } else {
1140       // we might have added extra large blocks to the nursery, so
1141       // resize back to minAllocAreaSize again.
1142       resizeNurseriesFixed(RtsFlags.GcFlags.minAllocAreaSize);
1143     }
1144   }
1145
1146  // mark the garbage collected CAFs as dead 
1147 #if 0 && defined(DEBUG) // doesn't work at the moment 
1148   if (major_gc) { gcCAFs(); }
1149 #endif
1150   
1151 #ifdef PROFILING
1152   // resetStaticObjectForRetainerProfiling() must be called before
1153   // zeroing below.
1154   resetStaticObjectForRetainerProfiling();
1155 #endif
1156
1157   // zero the scavenged static object list 
1158   if (major_gc) {
1159     zero_static_object_list(scavenged_static_objects);
1160   }
1161
1162   // Reset the nursery
1163   resetNurseries();
1164
1165   // start any pending finalizers 
1166   RELEASE_SM_LOCK;
1167   scheduleFinalizers(last_free_capability, old_weak_ptr_list);
1168   ACQUIRE_SM_LOCK;
1169   
1170   // send exceptions to any threads which were about to die 
1171   RELEASE_SM_LOCK;
1172   resurrectThreads(resurrected_threads);
1173   ACQUIRE_SM_LOCK;
1174
1175   // Update the stable pointer hash table.
1176   updateStablePtrTable(major_gc);
1177
1178   // check sanity after GC 
1179   IF_DEBUG(sanity, checkSanity());
1180
1181   // extra GC trace info 
1182   IF_DEBUG(gc, statDescribeGens());
1183
1184 #ifdef DEBUG
1185   // symbol-table based profiling 
1186   /*  heapCensus(to_blocks); */ /* ToDo */
1187 #endif
1188
1189   // restore enclosing cost centre 
1190 #ifdef PROFILING
1191   CCCS = prev_CCS;
1192 #endif
1193
1194 #ifdef DEBUG
1195   // check for memory leaks if DEBUG is on 
1196   memInventory();
1197 #endif
1198
1199 #ifdef RTS_GTK_FRONTPANEL
1200   if (RtsFlags.GcFlags.frontpanel) {
1201       updateFrontPanelAfterGC( N, live );
1202   }
1203 #endif
1204
1205   // ok, GC over: tell the stats department what happened. 
1206   stat_endGC(allocated, live, copied, scavd_copied, N);
1207
1208 #if defined(RTS_USER_SIGNALS)
1209   // unblock signals again
1210   unblockUserSignals();
1211 #endif
1212
1213   RELEASE_SM_LOCK;
1214
1215   //PAR_TICKY_TP();
1216 }
1217
1218
1219 /* -----------------------------------------------------------------------------
1220    Weak Pointers
1221
1222    traverse_weak_ptr_list is called possibly many times during garbage
1223    collection.  It returns a flag indicating whether it did any work
1224    (i.e. called evacuate on any live pointers).
1225
1226    Invariant: traverse_weak_ptr_list is called when the heap is in an
1227    idempotent state.  That means that there are no pending
1228    evacuate/scavenge operations.  This invariant helps the weak
1229    pointer code decide which weak pointers are dead - if there are no
1230    new live weak pointers, then all the currently unreachable ones are
1231    dead.
1232
1233    For generational GC: we just don't try to finalize weak pointers in
1234    older generations than the one we're collecting.  This could
1235    probably be optimised by keeping per-generation lists of weak
1236    pointers, but for a few weak pointers this scheme will work.
1237
1238    There are three distinct stages to processing weak pointers:
1239
1240    - weak_stage == WeakPtrs
1241
1242      We process all the weak pointers whos keys are alive (evacuate
1243      their values and finalizers), and repeat until we can find no new
1244      live keys.  If no live keys are found in this pass, then we
1245      evacuate the finalizers of all the dead weak pointers in order to
1246      run them.
1247
1248    - weak_stage == WeakThreads
1249
1250      Now, we discover which *threads* are still alive.  Pointers to
1251      threads from the all_threads and main thread lists are the
1252      weakest of all: a pointers from the finalizer of a dead weak
1253      pointer can keep a thread alive.  Any threads found to be unreachable
1254      are evacuated and placed on the resurrected_threads list so we 
1255      can send them a signal later.
1256
1257    - weak_stage == WeakDone
1258
1259      No more evacuation is done.
1260
1261    -------------------------------------------------------------------------- */
1262
1263 static rtsBool 
1264 traverse_weak_ptr_list(void)
1265 {
1266   StgWeak *w, **last_w, *next_w;
1267   StgClosure *new;
1268   rtsBool flag = rtsFalse;
1269
1270   switch (weak_stage) {
1271
1272   case WeakDone:
1273       return rtsFalse;
1274
1275   case WeakPtrs:
1276       /* doesn't matter where we evacuate values/finalizers to, since
1277        * these pointers are treated as roots (iff the keys are alive).
1278        */
1279       evac_gen = 0;
1280       
1281       last_w = &old_weak_ptr_list;
1282       for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1283           
1284           /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1285            * called on a live weak pointer object.  Just remove it.
1286            */
1287           if (w->header.info == &stg_DEAD_WEAK_info) {
1288               next_w = ((StgDeadWeak *)w)->link;
1289               *last_w = next_w;
1290               continue;
1291           }
1292           
1293           switch (get_itbl(w)->type) {
1294
1295           case EVACUATED:
1296               next_w = (StgWeak *)((StgEvacuated *)w)->evacuee;
1297               *last_w = next_w;
1298               continue;
1299
1300           case WEAK:
1301               /* Now, check whether the key is reachable.
1302                */
1303               new = isAlive(w->key);
1304               if (new != NULL) {
1305                   w->key = new;
1306                   // evacuate the value and finalizer 
1307                   w->value = evacuate(w->value);
1308                   w->finalizer = evacuate(w->finalizer);
1309                   // remove this weak ptr from the old_weak_ptr list 
1310                   *last_w = w->link;
1311                   // and put it on the new weak ptr list 
1312                   next_w  = w->link;
1313                   w->link = weak_ptr_list;
1314                   weak_ptr_list = w;
1315                   flag = rtsTrue;
1316
1317                   debugTrace(DEBUG_weak, 
1318                              "weak pointer still alive at %p -> %p",
1319                              w, w->key);
1320                   continue;
1321               }
1322               else {
1323                   last_w = &(w->link);
1324                   next_w = w->link;
1325                   continue;
1326               }
1327
1328           default:
1329               barf("traverse_weak_ptr_list: not WEAK");
1330           }
1331       }
1332       
1333       /* If we didn't make any changes, then we can go round and kill all
1334        * the dead weak pointers.  The old_weak_ptr list is used as a list
1335        * of pending finalizers later on.
1336        */
1337       if (flag == rtsFalse) {
1338           for (w = old_weak_ptr_list; w; w = w->link) {
1339               w->finalizer = evacuate(w->finalizer);
1340           }
1341
1342           // Next, move to the WeakThreads stage after fully
1343           // scavenging the finalizers we've just evacuated.
1344           weak_stage = WeakThreads;
1345       }
1346
1347       return rtsTrue;
1348
1349   case WeakThreads:
1350       /* Now deal with the all_threads list, which behaves somewhat like
1351        * the weak ptr list.  If we discover any threads that are about to
1352        * become garbage, we wake them up and administer an exception.
1353        */
1354       {
1355           StgTSO *t, *tmp, *next, **prev;
1356           
1357           prev = &old_all_threads;
1358           for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1359               
1360               tmp = (StgTSO *)isAlive((StgClosure *)t);
1361               
1362               if (tmp != NULL) {
1363                   t = tmp;
1364               }
1365               
1366               ASSERT(get_itbl(t)->type == TSO);
1367               switch (t->what_next) {
1368               case ThreadRelocated:
1369                   next = t->link;
1370                   *prev = next;
1371                   continue;
1372               case ThreadKilled:
1373               case ThreadComplete:
1374                   // finshed or died.  The thread might still be alive, but we
1375                   // don't keep it on the all_threads list.  Don't forget to
1376                   // stub out its global_link field.
1377                   next = t->global_link;
1378                   t->global_link = END_TSO_QUEUE;
1379                   *prev = next;
1380                   continue;
1381               default:
1382                   ;
1383               }
1384               
1385               if (tmp == NULL) {
1386                   // not alive (yet): leave this thread on the
1387                   // old_all_threads list.
1388                   prev = &(t->global_link);
1389                   next = t->global_link;
1390               } 
1391               else {
1392                   // alive: move this thread onto the all_threads list.
1393                   next = t->global_link;
1394                   t->global_link = all_threads;
1395                   all_threads  = t;
1396                   *prev = next;
1397               }
1398           }
1399       }
1400       
1401       /* If we evacuated any threads, we need to go back to the scavenger.
1402        */
1403       if (flag) return rtsTrue;
1404
1405       /* And resurrect any threads which were about to become garbage.
1406        */
1407       {
1408           StgTSO *t, *tmp, *next;
1409           for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1410               next = t->global_link;
1411               tmp = (StgTSO *)evacuate((StgClosure *)t);
1412               tmp->global_link = resurrected_threads;
1413               resurrected_threads = tmp;
1414           }
1415       }
1416       
1417       /* Finally, we can update the blackhole_queue.  This queue
1418        * simply strings together TSOs blocked on black holes, it is
1419        * not intended to keep anything alive.  Hence, we do not follow
1420        * pointers on the blackhole_queue until now, when we have
1421        * determined which TSOs are otherwise reachable.  We know at
1422        * this point that all TSOs have been evacuated, however.
1423        */
1424       { 
1425           StgTSO **pt;
1426           for (pt = &blackhole_queue; *pt != END_TSO_QUEUE; pt = &((*pt)->link)) {
1427               *pt = (StgTSO *)isAlive((StgClosure *)*pt);
1428               ASSERT(*pt != NULL);
1429           }
1430       }
1431
1432       weak_stage = WeakDone;  // *now* we're done,
1433       return rtsTrue;         // but one more round of scavenging, please
1434
1435   default:
1436       barf("traverse_weak_ptr_list");
1437       return rtsTrue;
1438   }
1439
1440 }
1441
1442 /* -----------------------------------------------------------------------------
1443    The blackhole queue
1444    
1445    Threads on this list behave like weak pointers during the normal
1446    phase of garbage collection: if the blackhole is reachable, then
1447    the thread is reachable too.
1448    -------------------------------------------------------------------------- */
1449 static rtsBool
1450 traverse_blackhole_queue (void)
1451 {
1452     StgTSO *prev, *t, *tmp;
1453     rtsBool flag;
1454
1455     flag = rtsFalse;
1456     prev = NULL;
1457
1458     for (t = blackhole_queue; t != END_TSO_QUEUE; prev=t, t = t->link) {
1459         if (! (tmp = (StgTSO *)isAlive((StgClosure*)t))) {
1460             if (isAlive(t->block_info.closure)) {
1461                 t = (StgTSO *)evacuate((StgClosure *)t);
1462                 if (prev) prev->link = t;
1463                 flag = rtsTrue;
1464             }
1465         }
1466     }
1467     return flag;
1468 }
1469
1470 /* -----------------------------------------------------------------------------
1471    After GC, the live weak pointer list may have forwarding pointers
1472    on it, because a weak pointer object was evacuated after being
1473    moved to the live weak pointer list.  We remove those forwarding
1474    pointers here.
1475
1476    Also, we don't consider weak pointer objects to be reachable, but
1477    we must nevertheless consider them to be "live" and retain them.
1478    Therefore any weak pointer objects which haven't as yet been
1479    evacuated need to be evacuated now.
1480    -------------------------------------------------------------------------- */
1481
1482
1483 static void
1484 mark_weak_ptr_list ( StgWeak **list )
1485 {
1486   StgWeak *w, **last_w;
1487
1488   last_w = list;
1489   for (w = *list; w; w = w->link) {
1490       // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
1491       ASSERT(w->header.info == &stg_DEAD_WEAK_info 
1492              || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
1493       w = (StgWeak *)evacuate((StgClosure *)w);
1494       *last_w = w;
1495       last_w = &(w->link);
1496   }
1497 }
1498
1499 /* -----------------------------------------------------------------------------
1500    isAlive determines whether the given closure is still alive (after
1501    a garbage collection) or not.  It returns the new address of the
1502    closure if it is alive, or NULL otherwise.
1503
1504    NOTE: Use it before compaction only!
1505    -------------------------------------------------------------------------- */
1506
1507
1508 StgClosure *
1509 isAlive(StgClosure *p)
1510 {
1511   const StgInfoTable *info;
1512   bdescr *bd;
1513
1514   while (1) {
1515
1516     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1517     info = get_itbl(p);
1518
1519     // ignore static closures 
1520     //
1521     // ToDo: for static closures, check the static link field.
1522     // Problem here is that we sometimes don't set the link field, eg.
1523     // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1524     //
1525     if (!HEAP_ALLOCED(p)) {
1526         return p;
1527     }
1528
1529     // ignore closures in generations that we're not collecting. 
1530     bd = Bdescr((P_)p);
1531     if (bd->gen_no > N) {
1532         return p;
1533     }
1534
1535     // if it's a pointer into to-space, then we're done
1536     if (bd->flags & BF_EVACUATED) {
1537         return p;
1538     }
1539
1540     // large objects use the evacuated flag
1541     if (bd->flags & BF_LARGE) {
1542         return NULL;
1543     }
1544
1545     // check the mark bit for compacted steps
1546     if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1547         return p;
1548     }
1549
1550     switch (info->type) {
1551
1552     case IND:
1553     case IND_STATIC:
1554     case IND_PERM:
1555     case IND_OLDGEN:            // rely on compatible layout with StgInd 
1556     case IND_OLDGEN_PERM:
1557       // follow indirections 
1558       p = ((StgInd *)p)->indirectee;
1559       continue;
1560
1561     case EVACUATED:
1562       // alive! 
1563       return ((StgEvacuated *)p)->evacuee;
1564
1565     case TSO:
1566       if (((StgTSO *)p)->what_next == ThreadRelocated) {
1567         p = (StgClosure *)((StgTSO *)p)->link;
1568         continue;
1569       } 
1570       return NULL;
1571
1572     default:
1573       // dead. 
1574       return NULL;
1575     }
1576   }
1577 }
1578
1579 static void
1580 mark_root(StgClosure **root)
1581 {
1582   *root = evacuate(*root);
1583 }
1584
1585 STATIC_INLINE void 
1586 upd_evacuee(StgClosure *p, StgClosure *dest)
1587 {
1588     // not true: (ToDo: perhaps it should be)
1589     // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
1590     SET_INFO(p, &stg_EVACUATED_info);
1591     ((StgEvacuated *)p)->evacuee = dest;
1592 }
1593
1594
1595 STATIC_INLINE StgClosure *
1596 copy(StgClosure *src, nat size, step *stp)
1597 {
1598   StgPtr to, from;
1599   nat i;
1600 #ifdef PROFILING
1601   // @LDV profiling
1602   nat size_org = size;
1603 #endif
1604
1605   TICK_GC_WORDS_COPIED(size);
1606   /* Find out where we're going, using the handy "to" pointer in 
1607    * the step of the source object.  If it turns out we need to
1608    * evacuate to an older generation, adjust it here (see comment
1609    * by evacuate()).
1610    */
1611   if (stp->gen_no < evac_gen) {
1612       if (eager_promotion) {
1613           stp = &generations[evac_gen].steps[0];
1614       } else {
1615           failed_to_evac = rtsTrue;
1616       }
1617   }
1618
1619   /* chain a new block onto the to-space for the destination step if
1620    * necessary.
1621    */
1622   if (stp->hp + size >= stp->hpLim) {
1623     gc_alloc_block(stp);
1624   }
1625
1626   to = stp->hp;
1627   from = (StgPtr)src;
1628   stp->hp = to + size;
1629   for (i = 0; i < size; i++) { // unroll for small i
1630       to[i] = from[i];
1631   }
1632   upd_evacuee((StgClosure *)from,(StgClosure *)to);
1633
1634 #ifdef PROFILING
1635   // We store the size of the just evacuated object in the LDV word so that
1636   // the profiler can guess the position of the next object later.
1637   SET_EVACUAEE_FOR_LDV(from, size_org);
1638 #endif
1639   return (StgClosure *)to;
1640 }
1641
1642 // Same as copy() above, except the object will be allocated in memory
1643 // that will not be scavenged.  Used for object that have no pointer
1644 // fields.
1645 STATIC_INLINE StgClosure *
1646 copy_noscav(StgClosure *src, nat size, step *stp)
1647 {
1648   StgPtr to, from;
1649   nat i;
1650 #ifdef PROFILING
1651   // @LDV profiling
1652   nat size_org = size;
1653 #endif
1654
1655   TICK_GC_WORDS_COPIED(size);
1656   /* Find out where we're going, using the handy "to" pointer in 
1657    * the step of the source object.  If it turns out we need to
1658    * evacuate to an older generation, adjust it here (see comment
1659    * by evacuate()).
1660    */
1661   if (stp->gen_no < evac_gen) {
1662       if (eager_promotion) {
1663           stp = &generations[evac_gen].steps[0];
1664       } else {
1665           failed_to_evac = rtsTrue;
1666       }
1667   }
1668
1669   /* chain a new block onto the to-space for the destination step if
1670    * necessary.
1671    */
1672   if (stp->scavd_hp + size >= stp->scavd_hpLim) {
1673     gc_alloc_scavd_block(stp);
1674   }
1675
1676   to = stp->scavd_hp;
1677   from = (StgPtr)src;
1678   stp->scavd_hp = to + size;
1679   for (i = 0; i < size; i++) { // unroll for small i
1680       to[i] = from[i];
1681   }
1682   upd_evacuee((StgClosure *)from,(StgClosure *)to);
1683
1684 #ifdef PROFILING
1685   // We store the size of the just evacuated object in the LDV word so that
1686   // the profiler can guess the position of the next object later.
1687   SET_EVACUAEE_FOR_LDV(from, size_org);
1688 #endif
1689   return (StgClosure *)to;
1690 }
1691
1692 /* Special version of copy() for when we only want to copy the info
1693  * pointer of an object, but reserve some padding after it.  This is
1694  * used to optimise evacuation of BLACKHOLEs.
1695  */
1696
1697
1698 static StgClosure *
1699 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1700 {
1701   P_ dest, to, from;
1702 #ifdef PROFILING
1703   // @LDV profiling
1704   nat size_to_copy_org = size_to_copy;
1705 #endif
1706
1707   TICK_GC_WORDS_COPIED(size_to_copy);
1708   if (stp->gen_no < evac_gen) {
1709       if (eager_promotion) {
1710           stp = &generations[evac_gen].steps[0];
1711       } else {
1712           failed_to_evac = rtsTrue;
1713       }
1714   }
1715
1716   if (stp->hp + size_to_reserve >= stp->hpLim) {
1717     gc_alloc_block(stp);
1718   }
1719
1720   for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1721     *to++ = *from++;
1722   }
1723   
1724   dest = stp->hp;
1725   stp->hp += size_to_reserve;
1726   upd_evacuee(src,(StgClosure *)dest);
1727 #ifdef PROFILING
1728   // We store the size of the just evacuated object in the LDV word so that
1729   // the profiler can guess the position of the next object later.
1730   // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1731   // words.
1732   SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1733   // fill the slop
1734   if (size_to_reserve - size_to_copy_org > 0)
1735     LDV_FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org)); 
1736 #endif
1737   return (StgClosure *)dest;
1738 }
1739
1740
1741 /* -----------------------------------------------------------------------------
1742    Evacuate a large object
1743
1744    This just consists of removing the object from the (doubly-linked)
1745    step->large_objects list, and linking it on to the (singly-linked)
1746    step->new_large_objects list, from where it will be scavenged later.
1747
1748    Convention: bd->flags has BF_EVACUATED set for a large object
1749    that has been evacuated, or unset otherwise.
1750    -------------------------------------------------------------------------- */
1751
1752
1753 STATIC_INLINE void
1754 evacuate_large(StgPtr p)
1755 {
1756   bdescr *bd = Bdescr(p);
1757   step *stp;
1758
1759   // object must be at the beginning of the block (or be a ByteArray)
1760   ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1761          (((W_)p & BLOCK_MASK) == 0));
1762
1763   // already evacuated? 
1764   if (bd->flags & BF_EVACUATED) { 
1765     /* Don't forget to set the failed_to_evac flag if we didn't get
1766      * the desired destination (see comments in evacuate()).
1767      */
1768     if (bd->gen_no < evac_gen) {
1769       failed_to_evac = rtsTrue;
1770       TICK_GC_FAILED_PROMOTION();
1771     }
1772     return;
1773   }
1774
1775   stp = bd->step;
1776   // remove from large_object list 
1777   if (bd->u.back) {
1778     bd->u.back->link = bd->link;
1779   } else { // first object in the list 
1780     stp->large_objects = bd->link;
1781   }
1782   if (bd->link) {
1783     bd->link->u.back = bd->u.back;
1784   }
1785   
1786   /* link it on to the evacuated large object list of the destination step
1787    */
1788   stp = bd->step->to;
1789   if (stp->gen_no < evac_gen) {
1790       if (eager_promotion) {
1791           stp = &generations[evac_gen].steps[0];
1792       } else {
1793           failed_to_evac = rtsTrue;
1794       }
1795   }
1796
1797   bd->step = stp;
1798   bd->gen_no = stp->gen_no;
1799   bd->link = stp->new_large_objects;
1800   stp->new_large_objects = bd;
1801   bd->flags |= BF_EVACUATED;
1802 }
1803
1804 /* -----------------------------------------------------------------------------
1805    Evacuate
1806
1807    This is called (eventually) for every live object in the system.
1808
1809    The caller to evacuate specifies a desired generation in the
1810    evac_gen global variable.  The following conditions apply to
1811    evacuating an object which resides in generation M when we're
1812    collecting up to generation N
1813
1814    if  M >= evac_gen 
1815            if  M > N     do nothing
1816            else          evac to step->to
1817
1818    if  M < evac_gen      evac to evac_gen, step 0
1819
1820    if the object is already evacuated, then we check which generation
1821    it now resides in.
1822
1823    if  M >= evac_gen     do nothing
1824    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1825                          didn't manage to evacuate this object into evac_gen.
1826
1827
1828    OPTIMISATION NOTES:
1829
1830    evacuate() is the single most important function performance-wise
1831    in the GC.  Various things have been tried to speed it up, but as
1832    far as I can tell the code generated by gcc 3.2 with -O2 is about
1833    as good as it's going to get.  We pass the argument to evacuate()
1834    in a register using the 'regparm' attribute (see the prototype for
1835    evacuate() near the top of this file).
1836
1837    Changing evacuate() to take an (StgClosure **) rather than
1838    returning the new pointer seems attractive, because we can avoid
1839    writing back the pointer when it hasn't changed (eg. for a static
1840    object, or an object in a generation > N).  However, I tried it and
1841    it doesn't help.  One reason is that the (StgClosure **) pointer
1842    gets spilled to the stack inside evacuate(), resulting in far more
1843    extra reads/writes than we save.
1844    -------------------------------------------------------------------------- */
1845
1846 REGPARM1 static StgClosure *
1847 evacuate(StgClosure *q)
1848 {
1849 #if defined(PAR)
1850   StgClosure *to;
1851 #endif
1852   bdescr *bd = NULL;
1853   step *stp;
1854   const StgInfoTable *info;
1855
1856 loop:
1857   ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
1858
1859   if (!HEAP_ALLOCED(q)) {
1860
1861       if (!major_gc) return q;
1862
1863       info = get_itbl(q);
1864       switch (info->type) {
1865
1866       case THUNK_STATIC:
1867           if (info->srt_bitmap != 0 && 
1868               *THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1869               *THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1870               static_objects = (StgClosure *)q;
1871           }
1872           return q;
1873           
1874       case FUN_STATIC:
1875           if (info->srt_bitmap != 0 && 
1876               *FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1877               *FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1878               static_objects = (StgClosure *)q;
1879           }
1880           return q;
1881           
1882       case IND_STATIC:
1883           /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1884            * on the CAF list, so don't do anything with it here (we'll
1885            * scavenge it later).
1886            */
1887           if (((StgIndStatic *)q)->saved_info == NULL
1888               && *IND_STATIC_LINK((StgClosure *)q) == NULL) {
1889               *IND_STATIC_LINK((StgClosure *)q) = static_objects;
1890               static_objects = (StgClosure *)q;
1891           }
1892           return q;
1893           
1894       case CONSTR_STATIC:
1895           if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
1896               *STATIC_LINK(info,(StgClosure *)q) = static_objects;
1897               static_objects = (StgClosure *)q;
1898           }
1899           return q;
1900           
1901       case CONSTR_NOCAF_STATIC:
1902           /* no need to put these on the static linked list, they don't need
1903            * to be scavenged.
1904            */
1905           return q;
1906           
1907       default:
1908           barf("evacuate(static): strange closure type %d", (int)(info->type));
1909       }
1910   }
1911
1912   bd = Bdescr((P_)q);
1913
1914   if (bd->gen_no > N) {
1915       /* Can't evacuate this object, because it's in a generation
1916        * older than the ones we're collecting.  Let's hope that it's
1917        * in evac_gen or older, or we will have to arrange to track
1918        * this pointer using the mutable list.
1919        */
1920       if (bd->gen_no < evac_gen) {
1921           // nope 
1922           failed_to_evac = rtsTrue;
1923           TICK_GC_FAILED_PROMOTION();
1924       }
1925       return q;
1926   }
1927
1928   if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
1929
1930       /* pointer into to-space: just return it.  This normally
1931        * shouldn't happen, but alllowing it makes certain things
1932        * slightly easier (eg. the mutable list can contain the same
1933        * object twice, for example).
1934        */
1935       if (bd->flags & BF_EVACUATED) {
1936           if (bd->gen_no < evac_gen) {
1937               failed_to_evac = rtsTrue;
1938               TICK_GC_FAILED_PROMOTION();
1939           }
1940           return q;
1941       }
1942
1943       /* evacuate large objects by re-linking them onto a different list.
1944        */
1945       if (bd->flags & BF_LARGE) {
1946           info = get_itbl(q);
1947           if (info->type == TSO && 
1948               ((StgTSO *)q)->what_next == ThreadRelocated) {
1949               q = (StgClosure *)((StgTSO *)q)->link;
1950               goto loop;
1951           }
1952           evacuate_large((P_)q);
1953           return q;
1954       }
1955       
1956       /* If the object is in a step that we're compacting, then we
1957        * need to use an alternative evacuate procedure.
1958        */
1959       if (bd->flags & BF_COMPACTED) {
1960           if (!is_marked((P_)q,bd)) {
1961               mark((P_)q,bd);
1962               if (mark_stack_full()) {
1963                   mark_stack_overflowed = rtsTrue;
1964                   reset_mark_stack();
1965               }
1966               push_mark_stack((P_)q);
1967           }
1968           return q;
1969       }
1970   }
1971       
1972   stp = bd->step->to;
1973
1974   info = get_itbl(q);
1975   
1976   switch (info->type) {
1977
1978   case MUT_VAR_CLEAN:
1979   case MUT_VAR_DIRTY:
1980   case MVAR:
1981       return copy(q,sizeW_fromITBL(info),stp);
1982
1983   case CONSTR_0_1:
1984   { 
1985       StgWord w = (StgWord)q->payload[0];
1986       if (q->header.info == Czh_con_info &&
1987           // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&  
1988           (StgChar)w <= MAX_CHARLIKE) {
1989           return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1990       }
1991       if (q->header.info == Izh_con_info &&
1992           (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1993           return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1994       }
1995       // else
1996       return copy_noscav(q,sizeofW(StgHeader)+1,stp);
1997   }
1998
1999   case FUN_0_1:
2000   case FUN_1_0:
2001   case CONSTR_1_0:
2002     return copy(q,sizeofW(StgHeader)+1,stp);
2003
2004   case THUNK_1_0:
2005   case THUNK_0_1:
2006     return copy(q,sizeofW(StgThunk)+1,stp);
2007
2008   case THUNK_1_1:
2009   case THUNK_2_0:
2010   case THUNK_0_2:
2011 #ifdef NO_PROMOTE_THUNKS
2012     if (bd->gen_no == 0 && 
2013         bd->step->no != 0 &&
2014         bd->step->no == generations[bd->gen_no].n_steps-1) {
2015       stp = bd->step;
2016     }
2017 #endif
2018     return copy(q,sizeofW(StgThunk)+2,stp);
2019
2020   case FUN_1_1:
2021   case FUN_2_0:
2022   case CONSTR_1_1:
2023   case CONSTR_2_0:
2024   case FUN_0_2:
2025     return copy(q,sizeofW(StgHeader)+2,stp);
2026
2027   case CONSTR_0_2:
2028     return copy_noscav(q,sizeofW(StgHeader)+2,stp);
2029
2030   case THUNK:
2031     return copy(q,thunk_sizeW_fromITBL(info),stp);
2032
2033   case FUN:
2034   case CONSTR:
2035   case IND_PERM:
2036   case IND_OLDGEN_PERM:
2037   case WEAK:
2038   case STABLE_NAME:
2039     return copy(q,sizeW_fromITBL(info),stp);
2040
2041   case BCO:
2042       return copy(q,bco_sizeW((StgBCO *)q),stp);
2043
2044   case CAF_BLACKHOLE:
2045   case SE_CAF_BLACKHOLE:
2046   case SE_BLACKHOLE:
2047   case BLACKHOLE:
2048     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
2049
2050   case THUNK_SELECTOR:
2051     {
2052         StgClosure *p;
2053         const StgInfoTable *info_ptr;
2054
2055         if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2056             return copy(q,THUNK_SELECTOR_sizeW(),stp);
2057         }
2058
2059         // stashed away for LDV profiling, see below
2060         info_ptr = q->header.info;
2061
2062         p = eval_thunk_selector(info->layout.selector_offset,
2063                                 (StgSelector *)q);
2064
2065         if (p == NULL) {
2066             return copy(q,THUNK_SELECTOR_sizeW(),stp);
2067         } else {
2068             StgClosure *val;
2069             // q is still BLACKHOLE'd.
2070             thunk_selector_depth++;
2071             val = evacuate(p);
2072             thunk_selector_depth--;
2073
2074 #ifdef PROFILING
2075             // For the purposes of LDV profiling, we have destroyed
2076             // the original selector thunk.
2077             SET_INFO(q, info_ptr);
2078             LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(q);
2079 #endif
2080
2081             // Update the THUNK_SELECTOR with an indirection to the
2082             // EVACUATED closure now at p.  Why do this rather than
2083             // upd_evacuee(q,p)?  Because we have an invariant that an
2084             // EVACUATED closure always points to an object in the
2085             // same or an older generation (required by the short-cut
2086             // test in the EVACUATED case, below).
2087             SET_INFO(q, &stg_IND_info);
2088             ((StgInd *)q)->indirectee = p;
2089
2090             // For the purposes of LDV profiling, we have created an
2091             // indirection.
2092             LDV_RECORD_CREATE(q);
2093
2094             return val;
2095         }
2096     }
2097
2098   case IND:
2099   case IND_OLDGEN:
2100     // follow chains of indirections, don't evacuate them 
2101     q = ((StgInd*)q)->indirectee;
2102     goto loop;
2103
2104   case RET_BCO:
2105   case RET_SMALL:
2106   case RET_VEC_SMALL:
2107   case RET_BIG:
2108   case RET_VEC_BIG:
2109   case RET_DYN:
2110   case UPDATE_FRAME:
2111   case STOP_FRAME:
2112   case CATCH_FRAME:
2113   case CATCH_STM_FRAME:
2114   case CATCH_RETRY_FRAME:
2115   case ATOMICALLY_FRAME:
2116     // shouldn't see these 
2117     barf("evacuate: stack frame at %p\n", q);
2118
2119   case PAP:
2120       return copy(q,pap_sizeW((StgPAP*)q),stp);
2121
2122   case AP:
2123       return copy(q,ap_sizeW((StgAP*)q),stp);
2124
2125   case AP_STACK:
2126       return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
2127
2128   case EVACUATED:
2129     /* Already evacuated, just return the forwarding address.
2130      * HOWEVER: if the requested destination generation (evac_gen) is
2131      * older than the actual generation (because the object was
2132      * already evacuated to a younger generation) then we have to
2133      * set the failed_to_evac flag to indicate that we couldn't 
2134      * manage to promote the object to the desired generation.
2135      */
2136     /* 
2137      * Optimisation: the check is fairly expensive, but we can often
2138      * shortcut it if either the required generation is 0, or the
2139      * current object (the EVACUATED) is in a high enough generation.
2140      * We know that an EVACUATED always points to an object in the
2141      * same or an older generation.  stp is the lowest step that the
2142      * current object would be evacuated to, so we only do the full
2143      * check if stp is too low.
2144      */
2145     if (evac_gen > 0 && stp->gen_no < evac_gen) {  // optimisation 
2146       StgClosure *p = ((StgEvacuated*)q)->evacuee;
2147       if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
2148         failed_to_evac = rtsTrue;
2149         TICK_GC_FAILED_PROMOTION();
2150       }
2151     }
2152     return ((StgEvacuated*)q)->evacuee;
2153
2154   case ARR_WORDS:
2155       // just copy the block 
2156       return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp);
2157
2158   case MUT_ARR_PTRS_CLEAN:
2159   case MUT_ARR_PTRS_DIRTY:
2160   case MUT_ARR_PTRS_FROZEN:
2161   case MUT_ARR_PTRS_FROZEN0:
2162       // just copy the block 
2163       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
2164
2165   case TSO:
2166     {
2167       StgTSO *tso = (StgTSO *)q;
2168
2169       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
2170        */
2171       if (tso->what_next == ThreadRelocated) {
2172         q = (StgClosure *)tso->link;
2173         goto loop;
2174       }
2175
2176       /* To evacuate a small TSO, we need to relocate the update frame
2177        * list it contains.  
2178        */
2179       {
2180           StgTSO *new_tso;
2181           StgPtr p, q;
2182
2183           new_tso = (StgTSO *)copyPart((StgClosure *)tso,
2184                                        tso_sizeW(tso),
2185                                        sizeofW(StgTSO), stp);
2186           move_TSO(tso, new_tso);
2187           for (p = tso->sp, q = new_tso->sp;
2188                p < tso->stack+tso->stack_size;) {
2189               *q++ = *p++;
2190           }
2191           
2192           return (StgClosure *)new_tso;
2193       }
2194     }
2195
2196 #if defined(PAR)
2197   case RBH:
2198     {
2199       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
2200       to = copy(q,BLACKHOLE_sizeW(),stp); 
2201       //ToDo: derive size etc from reverted IP
2202       //to = copy(q,size,stp);
2203       debugTrace(DEBUG_gc, "evacuate: RBH %p (%s) to %p (%s)",
2204                  q, info_type(q), to, info_type(to));
2205       return to;
2206     }
2207   
2208   case BLOCKED_FETCH:
2209     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE);
2210     to = copy(q,sizeofW(StgBlockedFetch),stp);
2211     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2212                q, info_type(q), to, info_type(to));
2213     return to;
2214
2215 # ifdef DIST    
2216   case REMOTE_REF:
2217 # endif
2218   case FETCH_ME:
2219     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2220     to = copy(q,sizeofW(StgFetchMe),stp);
2221     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2222                q, info_type(q), to, info_type(to)));
2223     return to;
2224
2225   case FETCH_ME_BQ:
2226     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2227     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2228     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2229                q, info_type(q), to, info_type(to)));
2230     return to;
2231 #endif
2232
2233   case TREC_HEADER: 
2234     return copy(q,sizeofW(StgTRecHeader),stp);
2235
2236   case TVAR_WAIT_QUEUE:
2237     return copy(q,sizeofW(StgTVarWaitQueue),stp);
2238
2239   case TVAR:
2240     return copy(q,sizeofW(StgTVar),stp);
2241     
2242   case TREC_CHUNK:
2243     return copy(q,sizeofW(StgTRecChunk),stp);
2244
2245   default:
2246     barf("evacuate: strange closure type %d", (int)(info->type));
2247   }
2248
2249   barf("evacuate");
2250 }
2251
2252 /* -----------------------------------------------------------------------------
2253    Evaluate a THUNK_SELECTOR if possible.
2254
2255    returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2256    a closure pointer if we evaluated it and this is the result.  Note
2257    that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2258    reducing it to HNF, just that we have eliminated the selection.
2259    The result might be another thunk, or even another THUNK_SELECTOR.
2260
2261    If the return value is non-NULL, the original selector thunk has
2262    been BLACKHOLE'd, and should be updated with an indirection or a
2263    forwarding pointer.  If the return value is NULL, then the selector
2264    thunk is unchanged.
2265
2266    ***
2267    ToDo: the treatment of THUNK_SELECTORS could be improved in the
2268    following way (from a suggestion by Ian Lynagh):
2269
2270    We can have a chain like this:
2271
2272       sel_0 --> (a,b)
2273                  |
2274                  |-----> sel_0 --> (a,b)
2275                                     |
2276                                     |-----> sel_0 --> ...
2277
2278    and the depth limit means we don't go all the way to the end of the
2279    chain, which results in a space leak.  This affects the recursive
2280    call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2281    the recursive call to eval_thunk_selector() in
2282    eval_thunk_selector().
2283
2284    We could eliminate the depth bound in this case, in the following
2285    way:
2286
2287       - traverse the chain once to discover the *value* of the 
2288         THUNK_SELECTOR.  Mark all THUNK_SELECTORS that we
2289         visit on the way as having been visited already (somehow).
2290
2291       - in a second pass, traverse the chain again updating all
2292         THUNK_SEELCTORS that we find on the way with indirections to
2293         the value.
2294
2295       - if we encounter a "marked" THUNK_SELECTOR in a normal 
2296         evacuate(), we konw it can't be updated so just evac it.
2297
2298    Program that illustrates the problem:
2299
2300         foo [] = ([], [])
2301         foo (x:xs) = let (ys, zs) = foo xs
2302                      in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2303
2304         main = bar [1..(100000000::Int)]
2305         bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2306
2307    -------------------------------------------------------------------------- */
2308
2309 static inline rtsBool
2310 is_to_space ( StgClosure *p )
2311 {
2312     bdescr *bd;
2313
2314     bd = Bdescr((StgPtr)p);
2315     if (HEAP_ALLOCED(p) &&
2316         ((bd->flags & BF_EVACUATED) 
2317          || ((bd->flags & BF_COMPACTED) &&
2318              is_marked((P_)p,bd)))) {
2319         return rtsTrue;
2320     } else {
2321         return rtsFalse;
2322     }
2323 }    
2324
2325 static StgClosure *
2326 eval_thunk_selector( nat field, StgSelector * p )
2327 {
2328     StgInfoTable *info;
2329     const StgInfoTable *info_ptr;
2330     StgClosure *selectee;
2331     
2332     selectee = p->selectee;
2333
2334     // Save the real info pointer (NOTE: not the same as get_itbl()).
2335     info_ptr = p->header.info;
2336
2337     // If the THUNK_SELECTOR is in a generation that we are not
2338     // collecting, then bail out early.  We won't be able to save any
2339     // space in any case, and updating with an indirection is trickier
2340     // in an old gen.
2341     if (Bdescr((StgPtr)p)->gen_no > N) {
2342         return NULL;
2343     }
2344
2345     // BLACKHOLE the selector thunk, since it is now under evaluation.
2346     // This is important to stop us going into an infinite loop if
2347     // this selector thunk eventually refers to itself.
2348     SET_INFO(p,&stg_BLACKHOLE_info);
2349
2350 selector_loop:
2351
2352     // We don't want to end up in to-space, because this causes
2353     // problems when the GC later tries to evacuate the result of
2354     // eval_thunk_selector().  There are various ways this could
2355     // happen:
2356     //
2357     // 1. following an IND_STATIC
2358     //
2359     // 2. when the old generation is compacted, the mark phase updates
2360     //    from-space pointers to be to-space pointers, and we can't
2361     //    reliably tell which we're following (eg. from an IND_STATIC).
2362     // 
2363     // 3. compacting GC again: if we're looking at a constructor in
2364     //    the compacted generation, it might point directly to objects
2365     //    in to-space.  We must bale out here, otherwise doing the selection
2366     //    will result in a to-space pointer being returned.
2367     //
2368     //  (1) is dealt with using a BF_EVACUATED test on the
2369     //  selectee. (2) and (3): we can tell if we're looking at an
2370     //  object in the compacted generation that might point to
2371     //  to-space objects by testing that (a) it is BF_COMPACTED, (b)
2372     //  the compacted generation is being collected, and (c) the
2373     //  object is marked.  Only a marked object may have pointers that
2374     //  point to to-space objects, because that happens when
2375     //  scavenging.
2376     //
2377     //  The to-space test is now embodied in the in_to_space() inline
2378     //  function, as it is re-used below.
2379     //
2380     if (is_to_space(selectee)) {
2381         goto bale_out;
2382     }
2383
2384     info = get_itbl(selectee);
2385     switch (info->type) {
2386       case CONSTR:
2387       case CONSTR_1_0:
2388       case CONSTR_0_1:
2389       case CONSTR_2_0:
2390       case CONSTR_1_1:
2391       case CONSTR_0_2:
2392       case CONSTR_STATIC:
2393       case CONSTR_NOCAF_STATIC:
2394           // check that the size is in range 
2395           ASSERT(field <  (StgWord32)(info->layout.payload.ptrs + 
2396                                       info->layout.payload.nptrs));
2397           
2398           // Select the right field from the constructor, and check
2399           // that the result isn't in to-space.  It might be in
2400           // to-space if, for example, this constructor contains
2401           // pointers to younger-gen objects (and is on the mut-once
2402           // list).
2403           //
2404           { 
2405               StgClosure *q;
2406               q = selectee->payload[field];
2407               if (is_to_space(q)) {
2408                   goto bale_out;
2409               } else {
2410                   return q;
2411               }
2412           }
2413
2414       case IND:
2415       case IND_PERM:
2416       case IND_OLDGEN:
2417       case IND_OLDGEN_PERM:
2418       case IND_STATIC:
2419           selectee = ((StgInd *)selectee)->indirectee;
2420           goto selector_loop;
2421
2422       case EVACUATED:
2423           // We don't follow pointers into to-space; the constructor
2424           // has already been evacuated, so we won't save any space
2425           // leaks by evaluating this selector thunk anyhow.
2426           break;
2427
2428       case THUNK_SELECTOR:
2429       {
2430           StgClosure *val;
2431
2432           // check that we don't recurse too much, re-using the
2433           // depth bound also used in evacuate().
2434           if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2435               break;
2436           }
2437           thunk_selector_depth++;
2438
2439           val = eval_thunk_selector(info->layout.selector_offset, 
2440                                     (StgSelector *)selectee);
2441
2442           thunk_selector_depth--;
2443
2444           if (val == NULL) { 
2445               break;
2446           } else {
2447               // We evaluated this selector thunk, so update it with
2448               // an indirection.  NOTE: we don't use UPD_IND here,
2449               // because we are guaranteed that p is in a generation
2450               // that we are collecting, and we never want to put the
2451               // indirection on a mutable list.
2452 #ifdef PROFILING
2453               // For the purposes of LDV profiling, we have destroyed
2454               // the original selector thunk.
2455               SET_INFO(p, info_ptr);
2456               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2457 #endif
2458               ((StgInd *)selectee)->indirectee = val;
2459               SET_INFO(selectee,&stg_IND_info);
2460
2461               // For the purposes of LDV profiling, we have created an
2462               // indirection.
2463               LDV_RECORD_CREATE(selectee);
2464
2465               selectee = val;
2466               goto selector_loop;
2467           }
2468       }
2469
2470       case AP:
2471       case AP_STACK:
2472       case THUNK:
2473       case THUNK_1_0:
2474       case THUNK_0_1:
2475       case THUNK_2_0:
2476       case THUNK_1_1:
2477       case THUNK_0_2:
2478       case THUNK_STATIC:
2479       case CAF_BLACKHOLE:
2480       case SE_CAF_BLACKHOLE:
2481       case SE_BLACKHOLE:
2482       case BLACKHOLE:
2483 #if defined(PAR)
2484       case RBH:
2485       case BLOCKED_FETCH:
2486 # ifdef DIST    
2487       case REMOTE_REF:
2488 # endif
2489       case FETCH_ME:
2490       case FETCH_ME_BQ:
2491 #endif
2492           // not evaluated yet 
2493           break;
2494     
2495       default:
2496         barf("eval_thunk_selector: strange selectee %d",
2497              (int)(info->type));
2498     }
2499
2500 bale_out:
2501     // We didn't manage to evaluate this thunk; restore the old info pointer
2502     SET_INFO(p, info_ptr);
2503     return NULL;
2504 }
2505
2506 /* -----------------------------------------------------------------------------
2507    move_TSO is called to update the TSO structure after it has been
2508    moved from one place to another.
2509    -------------------------------------------------------------------------- */
2510
2511 void
2512 move_TSO (StgTSO *src, StgTSO *dest)
2513 {
2514     ptrdiff_t diff;
2515
2516     // relocate the stack pointer... 
2517     diff = (StgPtr)dest - (StgPtr)src; // In *words* 
2518     dest->sp = (StgPtr)dest->sp + diff;
2519 }
2520
2521 /* Similar to scavenge_large_bitmap(), but we don't write back the
2522  * pointers we get back from evacuate().
2523  */
2524 static void
2525 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2526 {
2527     nat i, b, size;
2528     StgWord bitmap;
2529     StgClosure **p;
2530     
2531     b = 0;
2532     bitmap = large_srt->l.bitmap[b];
2533     size   = (nat)large_srt->l.size;
2534     p      = (StgClosure **)large_srt->srt;
2535     for (i = 0; i < size; ) {
2536         if ((bitmap & 1) != 0) {
2537             evacuate(*p);
2538         }
2539         i++;
2540         p++;
2541         if (i % BITS_IN(W_) == 0) {
2542             b++;
2543             bitmap = large_srt->l.bitmap[b];
2544         } else {
2545             bitmap = bitmap >> 1;
2546         }
2547     }
2548 }
2549
2550 /* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
2551  * srt field in the info table.  That's ok, because we'll
2552  * never dereference it.
2553  */
2554 STATIC_INLINE void
2555 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2556 {
2557   nat bitmap;
2558   StgClosure **p;
2559
2560   bitmap = srt_bitmap;
2561   p = srt;
2562
2563   if (bitmap == (StgHalfWord)(-1)) {  
2564       scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2565       return;
2566   }
2567
2568   while (bitmap != 0) {
2569       if ((bitmap & 1) != 0) {
2570 #ifdef ENABLE_WIN32_DLL_SUPPORT
2571           // Special-case to handle references to closures hiding out in DLLs, since
2572           // double indirections required to get at those. The code generator knows
2573           // which is which when generating the SRT, so it stores the (indirect)
2574           // reference to the DLL closure in the table by first adding one to it.
2575           // We check for this here, and undo the addition before evacuating it.
2576           // 
2577           // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2578           // closure that's fixed at link-time, and no extra magic is required.
2579           if ( (unsigned long)(*srt) & 0x1 ) {
2580               evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2581           } else {
2582               evacuate(*p);
2583           }
2584 #else
2585           evacuate(*p);
2586 #endif
2587       }
2588       p++;
2589       bitmap = bitmap >> 1;
2590   }
2591 }
2592
2593
2594 STATIC_INLINE void
2595 scavenge_thunk_srt(const StgInfoTable *info)
2596 {
2597     StgThunkInfoTable *thunk_info;
2598
2599     if (!major_gc) return;
2600
2601     thunk_info = itbl_to_thunk_itbl(info);
2602     scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2603 }
2604
2605 STATIC_INLINE void
2606 scavenge_fun_srt(const StgInfoTable *info)
2607 {
2608     StgFunInfoTable *fun_info;
2609
2610     if (!major_gc) return;
2611   
2612     fun_info = itbl_to_fun_itbl(info);
2613     scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2614 }
2615
2616 /* -----------------------------------------------------------------------------
2617    Scavenge a TSO.
2618    -------------------------------------------------------------------------- */
2619
2620 static void
2621 scavengeTSO (StgTSO *tso)
2622 {
2623     if (   tso->why_blocked == BlockedOnMVar
2624         || tso->why_blocked == BlockedOnBlackHole
2625         || tso->why_blocked == BlockedOnException
2626 #if defined(PAR)
2627         || tso->why_blocked == BlockedOnGA
2628         || tso->why_blocked == BlockedOnGA_NoSend
2629 #endif
2630         ) {
2631         tso->block_info.closure = evacuate(tso->block_info.closure);
2632     }
2633     tso->blocked_exceptions = 
2634         (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2635     
2636     // We don't always chase the link field: TSOs on the blackhole
2637     // queue are not automatically alive, so the link field is a
2638     // "weak" pointer in that case.
2639     if (tso->why_blocked != BlockedOnBlackHole) {
2640         tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
2641     }
2642
2643     // scavange current transaction record
2644     tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2645     
2646     // scavenge this thread's stack 
2647     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2648 }
2649
2650 /* -----------------------------------------------------------------------------
2651    Blocks of function args occur on the stack (at the top) and
2652    in PAPs.
2653    -------------------------------------------------------------------------- */
2654
2655 STATIC_INLINE StgPtr
2656 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2657 {
2658     StgPtr p;
2659     StgWord bitmap;
2660     nat size;
2661
2662     p = (StgPtr)args;
2663     switch (fun_info->f.fun_type) {
2664     case ARG_GEN:
2665         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2666         size = BITMAP_SIZE(fun_info->f.b.bitmap);
2667         goto small_bitmap;
2668     case ARG_GEN_BIG:
2669         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2670         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2671         p += size;
2672         break;
2673     default:
2674         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2675         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2676     small_bitmap:
2677         while (size > 0) {
2678             if ((bitmap & 1) == 0) {
2679                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2680             }
2681             p++;
2682             bitmap = bitmap >> 1;
2683             size--;
2684         }
2685         break;
2686     }
2687     return p;
2688 }
2689
2690 STATIC_INLINE StgPtr
2691 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2692 {
2693     StgPtr p;
2694     StgWord bitmap;
2695     StgFunInfoTable *fun_info;
2696     
2697     fun_info = get_fun_itbl(fun);
2698     ASSERT(fun_info->i.type != PAP);
2699     p = (StgPtr)payload;
2700
2701     switch (fun_info->f.fun_type) {
2702     case ARG_GEN:
2703         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2704         goto small_bitmap;
2705     case ARG_GEN_BIG:
2706         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2707         p += size;
2708         break;
2709     case ARG_BCO:
2710         scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2711         p += size;
2712         break;
2713     default:
2714         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2715     small_bitmap:
2716         while (size > 0) {
2717             if ((bitmap & 1) == 0) {
2718                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2719             }
2720             p++;
2721             bitmap = bitmap >> 1;
2722             size--;
2723         }
2724         break;
2725     }
2726     return p;
2727 }
2728
2729 STATIC_INLINE StgPtr
2730 scavenge_PAP (StgPAP *pap)
2731 {
2732     pap->fun = evacuate(pap->fun);
2733     return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2734 }
2735
2736 STATIC_INLINE StgPtr
2737 scavenge_AP (StgAP *ap)
2738 {
2739     ap->fun = evacuate(ap->fun);
2740     return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2741 }
2742
2743 /* -----------------------------------------------------------------------------
2744    Scavenge a given step until there are no more objects in this step
2745    to scavenge.
2746
2747    evac_gen is set by the caller to be either zero (for a step in a
2748    generation < N) or G where G is the generation of the step being
2749    scavenged.  
2750
2751    We sometimes temporarily change evac_gen back to zero if we're
2752    scavenging a mutable object where early promotion isn't such a good
2753    idea.  
2754    -------------------------------------------------------------------------- */
2755
2756 static void
2757 scavenge(step *stp)
2758 {
2759   StgPtr p, q;
2760   StgInfoTable *info;
2761   bdescr *bd;
2762   nat saved_evac_gen = evac_gen;
2763
2764   p = stp->scan;
2765   bd = stp->scan_bd;
2766
2767   failed_to_evac = rtsFalse;
2768
2769   /* scavenge phase - standard breadth-first scavenging of the
2770    * evacuated objects 
2771    */
2772
2773   while (bd != stp->hp_bd || p < stp->hp) {
2774
2775     // If we're at the end of this block, move on to the next block 
2776     if (bd != stp->hp_bd && p == bd->free) {
2777       bd = bd->link;
2778       p = bd->start;
2779       continue;
2780     }
2781
2782     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2783     info = get_itbl((StgClosure *)p);
2784     
2785     ASSERT(thunk_selector_depth == 0);
2786
2787     q = p;
2788     switch (info->type) {
2789
2790     case MVAR:
2791     { 
2792         StgMVar *mvar = ((StgMVar *)p);
2793         evac_gen = 0;
2794         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2795         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2796         mvar->value = evacuate((StgClosure *)mvar->value);
2797         evac_gen = saved_evac_gen;
2798         failed_to_evac = rtsTrue; // mutable.
2799         p += sizeofW(StgMVar);
2800         break;
2801     }
2802
2803     case FUN_2_0:
2804         scavenge_fun_srt(info);
2805         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2806         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2807         p += sizeofW(StgHeader) + 2;
2808         break;
2809
2810     case THUNK_2_0:
2811         scavenge_thunk_srt(info);
2812         ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2813         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2814         p += sizeofW(StgThunk) + 2;
2815         break;
2816
2817     case CONSTR_2_0:
2818         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2819         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2820         p += sizeofW(StgHeader) + 2;
2821         break;
2822         
2823     case THUNK_1_0:
2824         scavenge_thunk_srt(info);
2825         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2826         p += sizeofW(StgThunk) + 1;
2827         break;
2828         
2829     case FUN_1_0:
2830         scavenge_fun_srt(info);
2831     case CONSTR_1_0:
2832         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2833         p += sizeofW(StgHeader) + 1;
2834         break;
2835         
2836     case THUNK_0_1:
2837         scavenge_thunk_srt(info);
2838         p += sizeofW(StgThunk) + 1;
2839         break;
2840         
2841     case FUN_0_1:
2842         scavenge_fun_srt(info);
2843     case CONSTR_0_1:
2844         p += sizeofW(StgHeader) + 1;
2845         break;
2846         
2847     case THUNK_0_2:
2848         scavenge_thunk_srt(info);
2849         p += sizeofW(StgThunk) + 2;
2850         break;
2851         
2852     case FUN_0_2:
2853         scavenge_fun_srt(info);
2854     case CONSTR_0_2:
2855         p += sizeofW(StgHeader) + 2;
2856         break;
2857         
2858     case THUNK_1_1:
2859         scavenge_thunk_srt(info);
2860         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2861         p += sizeofW(StgThunk) + 2;
2862         break;
2863
2864     case FUN_1_1:
2865         scavenge_fun_srt(info);
2866     case CONSTR_1_1:
2867         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2868         p += sizeofW(StgHeader) + 2;
2869         break;
2870         
2871     case FUN:
2872         scavenge_fun_srt(info);
2873         goto gen_obj;
2874
2875     case THUNK:
2876     {
2877         StgPtr end;
2878
2879         scavenge_thunk_srt(info);
2880         end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2881         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2882             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2883         }
2884         p += info->layout.payload.nptrs;
2885         break;
2886     }
2887         
2888     gen_obj:
2889     case CONSTR:
2890     case WEAK:
2891     case STABLE_NAME:
2892     {
2893         StgPtr end;
2894
2895         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2896         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2897             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2898         }
2899         p += info->layout.payload.nptrs;
2900         break;
2901     }
2902
2903     case BCO: {
2904         StgBCO *bco = (StgBCO *)p;
2905         bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2906         bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2907         bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2908         bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2909         p += bco_sizeW(bco);
2910         break;
2911     }
2912
2913     case IND_PERM:
2914       if (stp->gen->no != 0) {
2915 #ifdef PROFILING
2916         // @LDV profiling
2917         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an 
2918         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2919         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2920 #endif        
2921         // 
2922         // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2923         //
2924         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2925
2926         // We pretend that p has just been created.
2927         LDV_RECORD_CREATE((StgClosure *)p);
2928       }
2929         // fall through 
2930     case IND_OLDGEN_PERM:
2931         ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2932         p += sizeofW(StgInd);
2933         break;
2934
2935     case MUT_VAR_CLEAN:
2936     case MUT_VAR_DIRTY: {
2937         rtsBool saved_eager_promotion = eager_promotion;
2938
2939         eager_promotion = rtsFalse;
2940         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2941         eager_promotion = saved_eager_promotion;
2942
2943         if (failed_to_evac) {
2944             ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
2945         } else {
2946             ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
2947         }
2948         p += sizeofW(StgMutVar);
2949         break;
2950     }
2951
2952     case CAF_BLACKHOLE:
2953     case SE_CAF_BLACKHOLE:
2954     case SE_BLACKHOLE:
2955     case BLACKHOLE:
2956         p += BLACKHOLE_sizeW();
2957         break;
2958
2959     case THUNK_SELECTOR:
2960     { 
2961         StgSelector *s = (StgSelector *)p;
2962         s->selectee = evacuate(s->selectee);
2963         p += THUNK_SELECTOR_sizeW();
2964         break;
2965     }
2966
2967     // A chunk of stack saved in a heap object
2968     case AP_STACK:
2969     {
2970         StgAP_STACK *ap = (StgAP_STACK *)p;
2971
2972         ap->fun = evacuate(ap->fun);
2973         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2974         p = (StgPtr)ap->payload + ap->size;
2975         break;
2976     }
2977
2978     case PAP:
2979         p = scavenge_PAP((StgPAP *)p);
2980         break;
2981
2982     case AP:
2983         p = scavenge_AP((StgAP *)p);
2984         break;
2985
2986     case ARR_WORDS:
2987         // nothing to follow 
2988         p += arr_words_sizeW((StgArrWords *)p);
2989         break;
2990
2991     case MUT_ARR_PTRS_CLEAN:
2992     case MUT_ARR_PTRS_DIRTY:
2993         // follow everything 
2994     {
2995         StgPtr next;
2996         rtsBool saved_eager;
2997
2998         // We don't eagerly promote objects pointed to by a mutable
2999         // array, but if we find the array only points to objects in
3000         // the same or an older generation, we mark it "clean" and
3001         // avoid traversing it during minor GCs.
3002         saved_eager = eager_promotion;
3003         eager_promotion = rtsFalse;
3004         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3005         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3006             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3007         }
3008         eager_promotion = saved_eager;
3009
3010         if (failed_to_evac) {
3011             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3012         } else {
3013             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3014         }
3015
3016         failed_to_evac = rtsTrue; // always put it on the mutable list.
3017         break;
3018     }
3019
3020     case MUT_ARR_PTRS_FROZEN:
3021     case MUT_ARR_PTRS_FROZEN0:
3022         // follow everything 
3023     {
3024         StgPtr next;
3025
3026         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3027         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3028             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3029         }
3030
3031         // If we're going to put this object on the mutable list, then
3032         // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3033         if (failed_to_evac) {
3034             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3035         } else {
3036             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3037         }
3038         break;
3039     }
3040
3041     case TSO:
3042     { 
3043         StgTSO *tso = (StgTSO *)p;
3044         rtsBool saved_eager = eager_promotion;
3045
3046         eager_promotion = rtsFalse;
3047         scavengeTSO(tso);
3048         eager_promotion = saved_eager;
3049
3050         if (failed_to_evac) {
3051             tso->flags |= TSO_DIRTY;
3052         } else {
3053             tso->flags &= ~TSO_DIRTY;
3054         }
3055
3056         failed_to_evac = rtsTrue; // always on the mutable list
3057         p += tso_sizeW(tso);
3058         break;
3059     }
3060
3061 #if defined(PAR)
3062     case RBH:
3063     { 
3064 #if 0
3065         nat size, ptrs, nonptrs, vhs;
3066         char str[80];
3067         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3068 #endif
3069         StgRBH *rbh = (StgRBH *)p;
3070         (StgClosure *)rbh->blocking_queue = 
3071             evacuate((StgClosure *)rbh->blocking_queue);
3072         failed_to_evac = rtsTrue;  // mutable anyhow.
3073         debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3074                    p, info_type(p), (StgClosure *)rbh->blocking_queue);
3075         // ToDo: use size of reverted closure here!
3076         p += BLACKHOLE_sizeW(); 
3077         break;
3078     }
3079
3080     case BLOCKED_FETCH:
3081     { 
3082         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3083         // follow the pointer to the node which is being demanded 
3084         (StgClosure *)bf->node = 
3085             evacuate((StgClosure *)bf->node);
3086         // follow the link to the rest of the blocking queue 
3087         (StgClosure *)bf->link = 
3088             evacuate((StgClosure *)bf->link);
3089         debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3090                    bf, info_type((StgClosure *)bf), 
3091                    bf->node, info_type(bf->node)));
3092         p += sizeofW(StgBlockedFetch);
3093         break;
3094     }
3095
3096 #ifdef DIST
3097     case REMOTE_REF:
3098 #endif
3099     case FETCH_ME:
3100         p += sizeofW(StgFetchMe);
3101         break; // nothing to do in this case
3102
3103     case FETCH_ME_BQ:
3104     { 
3105         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3106         (StgClosure *)fmbq->blocking_queue = 
3107             evacuate((StgClosure *)fmbq->blocking_queue);
3108         debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3109                    p, info_type((StgClosure *)p)));
3110         p += sizeofW(StgFetchMeBlockingQueue);
3111         break;
3112     }
3113 #endif
3114
3115     case TVAR_WAIT_QUEUE:
3116       {
3117         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3118         evac_gen = 0;
3119         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3120         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3121         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3122         evac_gen = saved_evac_gen;
3123         failed_to_evac = rtsTrue; // mutable
3124         p += sizeofW(StgTVarWaitQueue);
3125         break;
3126       }
3127
3128     case TVAR:
3129       {
3130         StgTVar *tvar = ((StgTVar *) p);
3131         evac_gen = 0;
3132         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3133         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3134         evac_gen = saved_evac_gen;
3135         failed_to_evac = rtsTrue; // mutable
3136         p += sizeofW(StgTVar);
3137         break;
3138       }
3139
3140     case TREC_HEADER:
3141       {
3142         StgTRecHeader *trec = ((StgTRecHeader *) p);
3143         evac_gen = 0;
3144         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3145         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3146         evac_gen = saved_evac_gen;
3147         failed_to_evac = rtsTrue; // mutable
3148         p += sizeofW(StgTRecHeader);
3149         break;
3150       }
3151
3152     case TREC_CHUNK:
3153       {
3154         StgWord i;
3155         StgTRecChunk *tc = ((StgTRecChunk *) p);
3156         TRecEntry *e = &(tc -> entries[0]);
3157         evac_gen = 0;
3158         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3159         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3160           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3161           e->expected_value = evacuate((StgClosure*)e->expected_value);
3162           e->new_value = evacuate((StgClosure*)e->new_value);
3163         }
3164         evac_gen = saved_evac_gen;
3165         failed_to_evac = rtsTrue; // mutable
3166         p += sizeofW(StgTRecChunk);
3167         break;
3168       }
3169
3170     default:
3171         barf("scavenge: unimplemented/strange closure type %d @ %p", 
3172              info->type, p);
3173     }
3174
3175     /*
3176      * We need to record the current object on the mutable list if
3177      *  (a) It is actually mutable, or 
3178      *  (b) It contains pointers to a younger generation.
3179      * Case (b) arises if we didn't manage to promote everything that
3180      * the current object points to into the current generation.
3181      */
3182     if (failed_to_evac) {
3183         failed_to_evac = rtsFalse;
3184         if (stp->gen_no > 0) {
3185             recordMutableGen((StgClosure *)q, stp->gen);
3186         }
3187     }
3188   }
3189
3190   stp->scan_bd = bd;
3191   stp->scan = p;
3192 }    
3193
3194 /* -----------------------------------------------------------------------------
3195    Scavenge everything on the mark stack.
3196
3197    This is slightly different from scavenge():
3198       - we don't walk linearly through the objects, so the scavenger
3199         doesn't need to advance the pointer on to the next object.
3200    -------------------------------------------------------------------------- */
3201
3202 static void
3203 scavenge_mark_stack(void)
3204 {
3205     StgPtr p, q;
3206     StgInfoTable *info;
3207     nat saved_evac_gen;
3208
3209     evac_gen = oldest_gen->no;
3210     saved_evac_gen = evac_gen;
3211
3212 linear_scan:
3213     while (!mark_stack_empty()) {
3214         p = pop_mark_stack();
3215
3216         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3217         info = get_itbl((StgClosure *)p);
3218         
3219         q = p;
3220         switch (info->type) {
3221             
3222         case MVAR:
3223         {
3224             StgMVar *mvar = ((StgMVar *)p);
3225             evac_gen = 0;
3226             mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3227             mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3228             mvar->value = evacuate((StgClosure *)mvar->value);
3229             evac_gen = saved_evac_gen;
3230             failed_to_evac = rtsTrue; // mutable.
3231             break;
3232         }
3233
3234         case FUN_2_0:
3235             scavenge_fun_srt(info);
3236             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3237             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3238             break;
3239
3240         case THUNK_2_0:
3241             scavenge_thunk_srt(info);
3242             ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
3243             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3244             break;
3245
3246         case CONSTR_2_0:
3247             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3248             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3249             break;
3250         
3251         case FUN_1_0:
3252         case FUN_1_1:
3253             scavenge_fun_srt(info);
3254             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3255             break;
3256
3257         case THUNK_1_0:
3258         case THUNK_1_1:
3259             scavenge_thunk_srt(info);
3260             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3261             break;
3262
3263         case CONSTR_1_0:
3264         case CONSTR_1_1:
3265             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3266             break;
3267         
3268         case FUN_0_1:
3269         case FUN_0_2:
3270             scavenge_fun_srt(info);
3271             break;
3272
3273         case THUNK_0_1:
3274         case THUNK_0_2:
3275             scavenge_thunk_srt(info);
3276             break;
3277
3278         case CONSTR_0_1:
3279         case CONSTR_0_2:
3280             break;
3281         
3282         case FUN:
3283             scavenge_fun_srt(info);
3284             goto gen_obj;
3285
3286         case THUNK:
3287         {
3288             StgPtr end;
3289             
3290             scavenge_thunk_srt(info);
3291             end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3292             for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3293                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3294             }
3295             break;
3296         }
3297         
3298         gen_obj:
3299         case CONSTR:
3300         case WEAK:
3301         case STABLE_NAME:
3302         {
3303             StgPtr end;
3304             
3305             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3306             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3307                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3308             }
3309             break;
3310         }
3311
3312         case BCO: {
3313             StgBCO *bco = (StgBCO *)p;
3314             bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3315             bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3316             bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3317             bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3318             break;
3319         }
3320
3321         case IND_PERM:
3322             // don't need to do anything here: the only possible case
3323             // is that we're in a 1-space compacting collector, with
3324             // no "old" generation.
3325             break;
3326
3327         case IND_OLDGEN:
3328         case IND_OLDGEN_PERM:
3329             ((StgInd *)p)->indirectee = 
3330                 evacuate(((StgInd *)p)->indirectee);
3331             break;
3332
3333         case MUT_VAR_CLEAN:
3334         case MUT_VAR_DIRTY: {
3335             rtsBool saved_eager_promotion = eager_promotion;
3336             
3337             eager_promotion = rtsFalse;
3338             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3339             eager_promotion = saved_eager_promotion;
3340             
3341             if (failed_to_evac) {
3342                 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3343             } else {
3344                 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3345             }
3346             break;
3347         }
3348
3349         case CAF_BLACKHOLE:
3350         case SE_CAF_BLACKHOLE:
3351         case SE_BLACKHOLE:
3352         case BLACKHOLE:
3353         case ARR_WORDS:
3354             break;
3355
3356         case THUNK_SELECTOR:
3357         { 
3358             StgSelector *s = (StgSelector *)p;
3359             s->selectee = evacuate(s->selectee);
3360             break;
3361         }
3362
3363         // A chunk of stack saved in a heap object
3364         case AP_STACK:
3365         {
3366             StgAP_STACK *ap = (StgAP_STACK *)p;
3367             
3368             ap->fun = evacuate(ap->fun);
3369             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3370             break;
3371         }
3372
3373         case PAP:
3374             scavenge_PAP((StgPAP *)p);
3375             break;
3376
3377         case AP:
3378             scavenge_AP((StgAP *)p);
3379             break;
3380       
3381         case MUT_ARR_PTRS_CLEAN:
3382         case MUT_ARR_PTRS_DIRTY:
3383             // follow everything 
3384         {
3385             StgPtr next;
3386             rtsBool saved_eager;
3387
3388             // We don't eagerly promote objects pointed to by a mutable
3389             // array, but if we find the array only points to objects in
3390             // the same or an older generation, we mark it "clean" and
3391             // avoid traversing it during minor GCs.
3392             saved_eager = eager_promotion;
3393             eager_promotion = rtsFalse;
3394             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3395             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3396                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3397             }
3398             eager_promotion = saved_eager;
3399
3400             if (failed_to_evac) {
3401                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3402             } else {
3403                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3404             }
3405
3406             failed_to_evac = rtsTrue; // mutable anyhow.
3407             break;
3408         }
3409
3410         case MUT_ARR_PTRS_FROZEN:
3411         case MUT_ARR_PTRS_FROZEN0:
3412             // follow everything 
3413         {
3414             StgPtr next, q = p;
3415             
3416             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3417             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3418                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3419             }
3420
3421             // If we're going to put this object on the mutable list, then
3422             // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3423             if (failed_to_evac) {
3424                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3425             } else {
3426                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3427             }
3428             break;
3429         }
3430
3431         case TSO:
3432         { 
3433             StgTSO *tso = (StgTSO *)p;
3434             rtsBool saved_eager = eager_promotion;
3435
3436             eager_promotion = rtsFalse;
3437             scavengeTSO(tso);
3438             eager_promotion = saved_eager;
3439             
3440             if (failed_to_evac) {
3441                 tso->flags |= TSO_DIRTY;
3442             } else {
3443                 tso->flags &= ~TSO_DIRTY;
3444             }
3445             
3446             failed_to_evac = rtsTrue; // always on the mutable list
3447             break;
3448         }
3449
3450 #if defined(PAR)
3451         case RBH:
3452         { 
3453 #if 0
3454             nat size, ptrs, nonptrs, vhs;
3455             char str[80];
3456             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3457 #endif
3458             StgRBH *rbh = (StgRBH *)p;
3459             bh->blocking_queue = 
3460                 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3461             failed_to_evac = rtsTrue;  // mutable anyhow.
3462             debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3463                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
3464             break;
3465         }
3466         
3467         case BLOCKED_FETCH:
3468         { 
3469             StgBlockedFetch *bf = (StgBlockedFetch *)p;
3470             // follow the pointer to the node which is being demanded 
3471             (StgClosure *)bf->node = 
3472                 evacuate((StgClosure *)bf->node);
3473             // follow the link to the rest of the blocking queue 
3474             (StgClosure *)bf->link = 
3475                 evacuate((StgClosure *)bf->link);
3476             debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3477                        bf, info_type((StgClosure *)bf), 
3478                        bf->node, info_type(bf->node)));
3479             break;
3480         }
3481
3482 #ifdef DIST
3483         case REMOTE_REF:
3484 #endif
3485         case FETCH_ME:
3486             break; // nothing to do in this case
3487
3488         case FETCH_ME_BQ:
3489         { 
3490             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3491             (StgClosure *)fmbq->blocking_queue = 
3492                 evacuate((StgClosure *)fmbq->blocking_queue);
3493             debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3494                        p, info_type((StgClosure *)p)));
3495             break;
3496         }
3497 #endif /* PAR */
3498
3499         case TVAR_WAIT_QUEUE:
3500           {
3501             StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3502             evac_gen = 0;
3503             wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3504             wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3505             wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3506             evac_gen = saved_evac_gen;
3507             failed_to_evac = rtsTrue; // mutable
3508             break;
3509           }
3510           
3511         case TVAR:
3512           {
3513             StgTVar *tvar = ((StgTVar *) p);
3514             evac_gen = 0;
3515             tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3516             tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3517             evac_gen = saved_evac_gen;
3518             failed_to_evac = rtsTrue; // mutable
3519             break;
3520           }
3521           
3522         case TREC_CHUNK:
3523           {
3524             StgWord i;
3525             StgTRecChunk *tc = ((StgTRecChunk *) p);
3526             TRecEntry *e = &(tc -> entries[0]);
3527             evac_gen = 0;
3528             tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3529             for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3530               e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3531               e->expected_value = evacuate((StgClosure*)e->expected_value);
3532               e->new_value = evacuate((StgClosure*)e->new_value);
3533             }
3534             evac_gen = saved_evac_gen;
3535             failed_to_evac = rtsTrue; // mutable
3536             break;
3537           }
3538
3539         case TREC_HEADER:
3540           {
3541             StgTRecHeader *trec = ((StgTRecHeader *) p);
3542             evac_gen = 0;
3543             trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3544             trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3545             evac_gen = saved_evac_gen;
3546             failed_to_evac = rtsTrue; // mutable
3547             break;
3548           }
3549
3550         default:
3551             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p", 
3552                  info->type, p);
3553         }
3554
3555         if (failed_to_evac) {
3556             failed_to_evac = rtsFalse;
3557             if (evac_gen > 0) {
3558                 recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3559             }
3560         }
3561         
3562         // mark the next bit to indicate "scavenged"
3563         mark(q+1, Bdescr(q));
3564
3565     } // while (!mark_stack_empty())
3566
3567     // start a new linear scan if the mark stack overflowed at some point
3568     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3569         debugTrace(DEBUG_gc, "scavenge_mark_stack: starting linear scan");
3570         mark_stack_overflowed = rtsFalse;
3571         oldgen_scan_bd = oldest_gen->steps[0].old_blocks;
3572         oldgen_scan = oldgen_scan_bd->start;
3573     }
3574
3575     if (oldgen_scan_bd) {
3576         // push a new thing on the mark stack
3577     loop:
3578         // find a closure that is marked but not scavenged, and start
3579         // from there.
3580         while (oldgen_scan < oldgen_scan_bd->free 
3581                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3582             oldgen_scan++;
3583         }
3584
3585         if (oldgen_scan < oldgen_scan_bd->free) {
3586
3587             // already scavenged?
3588             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3589                 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3590                 goto loop;
3591             }
3592             push_mark_stack(oldgen_scan);
3593             // ToDo: bump the linear scan by the actual size of the object
3594             oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3595             goto linear_scan;
3596         }
3597
3598         oldgen_scan_bd = oldgen_scan_bd->link;
3599         if (oldgen_scan_bd != NULL) {
3600             oldgen_scan = oldgen_scan_bd->start;
3601             goto loop;
3602         }
3603     }
3604 }
3605
3606 /* -----------------------------------------------------------------------------
3607    Scavenge one object.
3608
3609    This is used for objects that are temporarily marked as mutable
3610    because they contain old-to-new generation pointers.  Only certain
3611    objects can have this property.
3612    -------------------------------------------------------------------------- */
3613
3614 static rtsBool
3615 scavenge_one(StgPtr p)
3616 {
3617     const StgInfoTable *info;
3618     nat saved_evac_gen = evac_gen;
3619     rtsBool no_luck;
3620     
3621     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3622     info = get_itbl((StgClosure *)p);
3623     
3624     switch (info->type) {
3625         
3626     case MVAR:
3627     { 
3628         StgMVar *mvar = ((StgMVar *)p);
3629         evac_gen = 0;
3630         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3631         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3632         mvar->value = evacuate((StgClosure *)mvar->value);
3633         evac_gen = saved_evac_gen;
3634         failed_to_evac = rtsTrue; // mutable.
3635         break;
3636     }
3637
3638     case THUNK:
3639     case THUNK_1_0:
3640     case THUNK_0_1:
3641     case THUNK_1_1:
3642     case THUNK_0_2:
3643     case THUNK_2_0:
3644     {
3645         StgPtr q, end;
3646         
3647         end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3648         for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3649             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3650         }
3651         break;
3652     }
3653
3654     case FUN:
3655     case FUN_1_0:                       // hardly worth specialising these guys
3656     case FUN_0_1:
3657     case FUN_1_1:
3658     case FUN_0_2:
3659     case FUN_2_0:
3660     case CONSTR:
3661     case CONSTR_1_0:
3662     case CONSTR_0_1:
3663     case CONSTR_1_1:
3664     case CONSTR_0_2:
3665     case CONSTR_2_0:
3666     case WEAK:
3667     case IND_PERM:
3668     {
3669         StgPtr q, end;
3670         
3671         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3672         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3673             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3674         }
3675         break;
3676     }
3677     
3678     case MUT_VAR_CLEAN:
3679     case MUT_VAR_DIRTY: {
3680         StgPtr q = p;
3681         rtsBool saved_eager_promotion = eager_promotion;
3682
3683         eager_promotion = rtsFalse;
3684         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3685         eager_promotion = saved_eager_promotion;
3686
3687         if (failed_to_evac) {
3688             ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3689         } else {
3690             ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3691         }
3692         break;
3693     }
3694
3695     case CAF_BLACKHOLE:
3696     case SE_CAF_BLACKHOLE:
3697     case SE_BLACKHOLE:
3698     case BLACKHOLE:
3699         break;
3700         
3701     case THUNK_SELECTOR:
3702     { 
3703         StgSelector *s = (StgSelector *)p;
3704         s->selectee = evacuate(s->selectee);
3705         break;
3706     }
3707     
3708     case AP_STACK:
3709     {
3710         StgAP_STACK *ap = (StgAP_STACK *)p;
3711
3712         ap->fun = evacuate(ap->fun);
3713         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3714         p = (StgPtr)ap->payload + ap->size;
3715         break;
3716     }
3717
3718     case PAP:
3719         p = scavenge_PAP((StgPAP *)p);
3720         break;
3721
3722     case AP:
3723         p = scavenge_AP((StgAP *)p);
3724         break;
3725
3726     case ARR_WORDS:
3727         // nothing to follow 
3728         break;
3729
3730     case MUT_ARR_PTRS_CLEAN:
3731     case MUT_ARR_PTRS_DIRTY:
3732     {
3733         StgPtr next, q;
3734         rtsBool saved_eager;
3735
3736         // We don't eagerly promote objects pointed to by a mutable
3737         // array, but if we find the array only points to objects in
3738         // the same or an older generation, we mark it "clean" and
3739         // avoid traversing it during minor GCs.
3740         saved_eager = eager_promotion;
3741         eager_promotion = rtsFalse;
3742         q = p;
3743         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3744         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3745             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3746         }
3747         eager_promotion = saved_eager;
3748
3749         if (failed_to_evac) {
3750             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3751         } else {
3752             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3753         }
3754
3755         failed_to_evac = rtsTrue;
3756         break;
3757     }
3758
3759     case MUT_ARR_PTRS_FROZEN:
3760     case MUT_ARR_PTRS_FROZEN0:
3761     {
3762         // follow everything 
3763         StgPtr next, q=p;
3764       
3765         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3766         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3767             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3768         }
3769
3770         // If we're going to put this object on the mutable list, then
3771         // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3772         if (failed_to_evac) {
3773             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3774         } else {
3775             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3776         }
3777         break;
3778     }
3779
3780     case TSO:
3781     {
3782         StgTSO *tso = (StgTSO *)p;
3783         rtsBool saved_eager = eager_promotion;
3784
3785         eager_promotion = rtsFalse;
3786         scavengeTSO(tso);
3787         eager_promotion = saved_eager;
3788
3789         if (failed_to_evac) {
3790             tso->flags |= TSO_DIRTY;
3791         } else {
3792             tso->flags &= ~TSO_DIRTY;
3793         }
3794
3795         failed_to_evac = rtsTrue; // always on the mutable list
3796         break;
3797     }
3798   
3799 #if defined(PAR)
3800     case RBH:
3801     { 
3802 #if 0
3803         nat size, ptrs, nonptrs, vhs;
3804         char str[80];
3805         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3806 #endif
3807         StgRBH *rbh = (StgRBH *)p;
3808         (StgClosure *)rbh->blocking_queue = 
3809             evacuate((StgClosure *)rbh->blocking_queue);
3810         failed_to_evac = rtsTrue;  // mutable anyhow.
3811         debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3812                    p, info_type(p), (StgClosure *)rbh->blocking_queue));
3813         // ToDo: use size of reverted closure here!
3814         break;
3815     }
3816
3817     case BLOCKED_FETCH:
3818     { 
3819         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3820         // follow the pointer to the node which is being demanded 
3821         (StgClosure *)bf->node = 
3822             evacuate((StgClosure *)bf->node);
3823         // follow the link to the rest of the blocking queue 
3824         (StgClosure *)bf->link = 
3825             evacuate((StgClosure *)bf->link);
3826         debugTrace(DEBUG_gc,
3827                    "scavenge: %p (%s); node is now %p; exciting, isn't it",
3828                    bf, info_type((StgClosure *)bf), 
3829                    bf->node, info_type(bf->node)));
3830         break;
3831     }
3832
3833 #ifdef DIST
3834     case REMOTE_REF:
3835 #endif
3836     case FETCH_ME:
3837         break; // nothing to do in this case
3838
3839     case FETCH_ME_BQ:
3840     { 
3841         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3842         (StgClosure *)fmbq->blocking_queue = 
3843             evacuate((StgClosure *)fmbq->blocking_queue);
3844         debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3845                    p, info_type((StgClosure *)p)));
3846         break;
3847     }
3848 #endif
3849
3850     case TVAR_WAIT_QUEUE:
3851       {
3852         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3853         evac_gen = 0;
3854         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3855         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3856         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3857         evac_gen = saved_evac_gen;
3858         failed_to_evac = rtsTrue; // mutable
3859         break;
3860       }
3861
3862     case TV