ghc/rts/GC.c

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