ghc/rts/GC.c

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