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