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