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