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         const StgInfoTable *info_ptr;
2020
2021         if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2022             return copy(q,THUNK_SELECTOR_sizeW(),stp);
2023         }
2024
2025         // stashed away for LDV profiling, see below
2026         info_ptr = q->header.info;
2027
2028         p = eval_thunk_selector(info->layout.selector_offset,
2029                                 (StgSelector *)q);
2030
2031         if (p == NULL) {
2032             return copy(q,THUNK_SELECTOR_sizeW(),stp);
2033         } else {
2034             StgClosure *val;
2035             // q is still BLACKHOLE'd.
2036             thunk_selector_depth++;
2037             val = evacuate(p);
2038             thunk_selector_depth--;
2039
2040 #ifdef PROFILING
2041             // For the purposes of LDV profiling, we have destroyed
2042             // the original selector thunk.
2043             SET_INFO(q, info_ptr);
2044             LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(q);
2045 #endif
2046
2047             // Update the THUNK_SELECTOR with an indirection to the
2048             // EVACUATED closure now at p.  Why do this rather than
2049             // upd_evacuee(q,p)?  Because we have an invariant that an
2050             // EVACUATED closure always points to an object in the
2051             // same or an older generation (required by the short-cut
2052             // test in the EVACUATED case, below).
2053             SET_INFO(q, &stg_IND_info);
2054             ((StgInd *)q)->indirectee = p;
2055
2056             // For the purposes of LDV profiling, we have created an
2057             // indirection.
2058             LDV_RECORD_CREATE(q);
2059
2060             return val;
2061         }
2062     }
2063
2064   case IND:
2065   case IND_OLDGEN:
2066     // follow chains of indirections, don't evacuate them
2067     q = ((StgInd*)q)->indirectee;
2068     goto loop;
2069
2070   case RET_BCO:
2071   case RET_SMALL:
2072   case RET_VEC_SMALL:
2073   case RET_BIG:
2074   case RET_VEC_BIG:
2075   case RET_DYN:
2076   case UPDATE_FRAME:
2077   case STOP_FRAME:
2078   case CATCH_FRAME:
2079   case CATCH_STM_FRAME:
2080   case CATCH_RETRY_FRAME:
2081   case ATOMICALLY_FRAME:
2082     // shouldn't see these
2083     barf("evacuate: stack frame at %p\n", q);
2084
2085   case PAP:
2086       return copy(q,pap_sizeW((StgPAP*)q),stp);
2087
2088   case AP:
2089       return copy(q,ap_sizeW((StgAP*)q),stp);
2090
2091   case AP_STACK:
2092       return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
2093
2094   case EVACUATED:
2095     /* Already evacuated, just return the forwarding address.
2096      * HOWEVER: if the requested destination generation (evac_gen) is
2097      * older than the actual generation (because the object was
2098      * already evacuated to a younger generation) then we have to
2099      * set the failed_to_evac flag to indicate that we couldn't
2100      * manage to promote the object to the desired generation.
2101      */
2102     /*
2103      * Optimisation: the check is fairly expensive, but we can often
2104      * shortcut it if either the required generation is 0, or the
2105      * current object (the EVACUATED) is in a high enough generation.
2106      * We know that an EVACUATED always points to an object in the
2107      * same or an older generation.  stp is the lowest step that the
2108      * current object would be evacuated to, so we only do the full
2109      * check if stp is too low.
2110      */
2111     if (evac_gen > 0 && stp->gen_no < evac_gen) {  // optimisation
2112       StgClosure *p = ((StgEvacuated*)q)->evacuee;
2113       if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
2114         failed_to_evac = rtsTrue;
2115         TICK_GC_FAILED_PROMOTION();
2116       }
2117     }
2118     return ((StgEvacuated*)q)->evacuee;
2119
2120   case ARR_WORDS:
2121       // just copy the block
2122       return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp);
2123
2124   case MUT_ARR_PTRS_CLEAN:
2125   case MUT_ARR_PTRS_DIRTY:
2126   case MUT_ARR_PTRS_FROZEN:
2127   case MUT_ARR_PTRS_FROZEN0:
2128       // just copy the block
2129       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
2130
2131   case TSO:
2132     {
2133       StgTSO *tso = (StgTSO *)q;
2134
2135       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
2136        */
2137       if (tso->what_next == ThreadRelocated) {
2138         q = (StgClosure *)tso->link;
2139         goto loop;
2140       }
2141
2142       /* To evacuate a small TSO, we need to relocate the update frame
2143        * list it contains.
2144        */
2145       {
2146           StgTSO *new_tso;
2147           StgPtr p, q;
2148
2149           new_tso = (StgTSO *)copyPart((StgClosure *)tso,
2150                                        tso_sizeW(tso),
2151                                        sizeofW(StgTSO), stp);
2152           move_TSO(tso, new_tso);
2153           for (p = tso->sp, q = new_tso->sp;
2154                p < tso->stack+tso->stack_size;) {
2155               *q++ = *p++;
2156           }
2157
2158           return (StgClosure *)new_tso;
2159       }
2160     }
2161
2162 #if defined(PAR)
2163   case RBH:
2164     {
2165       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
2166       to = copy(q,BLACKHOLE_sizeW(),stp);
2167       //ToDo: derive size etc from reverted IP
2168       //to = copy(q,size,stp);
2169       IF_DEBUG(gc,
2170                debugBelch("@@ evacuate: RBH %p (%s) to %p (%s)",
2171                      q, info_type(q), to, info_type(to)));
2172       return to;
2173     }
2174
2175   case BLOCKED_FETCH:
2176     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE);
2177     to = copy(q,sizeofW(StgBlockedFetch),stp);
2178     IF_DEBUG(gc,
2179              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2180                    q, info_type(q), to, info_type(to)));
2181     return to;
2182
2183 # ifdef DIST
2184   case REMOTE_REF:
2185 # endif
2186   case FETCH_ME:
2187     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2188     to = copy(q,sizeofW(StgFetchMe),stp);
2189     IF_DEBUG(gc,
2190              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2191                    q, info_type(q), to, info_type(to)));
2192     return to;
2193
2194   case FETCH_ME_BQ:
2195     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2196     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2197     IF_DEBUG(gc,
2198              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2199                    q, info_type(q), to, info_type(to)));
2200     return to;
2201 #endif
2202
2203   case TREC_HEADER:
2204     return copy(q,sizeofW(StgTRecHeader),stp);
2205
2206   case TVAR_WAIT_QUEUE:
2207     return copy(q,sizeofW(StgTVarWaitQueue),stp);
2208
2209   case TVAR:
2210     return copy(q,sizeofW(StgTVar),stp);
2211
2212   case TREC_CHUNK:
2213     return copy(q,sizeofW(StgTRecChunk),stp);
2214
2215   default:
2216     barf("evacuate: strange closure type %d", (int)(info->type));
2217   }
2218
2219   barf("evacuate");
2220 }
2221
2222 /* -----------------------------------------------------------------------------
2223    Evaluate a THUNK_SELECTOR if possible.
2224
2225    returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2226    a closure pointer if we evaluated it and this is the result.  Note
2227    that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2228    reducing it to HNF, just that we have eliminated the selection.
2229    The result might be another thunk, or even another THUNK_SELECTOR.
2230
2231    If the return value is non-NULL, the original selector thunk has
2232    been BLACKHOLE'd, and should be updated with an indirection or a
2233    forwarding pointer.  If the return value is NULL, then the selector
2234    thunk is unchanged.
2235
2236    ***
2237    ToDo: the treatment of THUNK_SELECTORS could be improved in the
2238    following way (from a suggestion by Ian Lynagh):
2239
2240    We can have a chain like this:
2241
2242       sel_0 --> (a,b)
2243                  |
2244                  |-----> sel_0 --> (a,b)
2245                                     |
2246                                     |-----> sel_0 --> ...
2247
2248    and the depth limit means we don't go all the way to the end of the
2249    chain, which results in a space leak.  This affects the recursive
2250    call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2251    the recursive call to eval_thunk_selector() in
2252    eval_thunk_selector().
2253
2254    We could eliminate the depth bound in this case, in the following
2255    way:
2256
2257       - traverse the chain once to discover the *value* of the
2258         THUNK_SELECTOR.  Mark all THUNK_SELECTORS that we
2259         visit on the way as having been visited already (somehow).
2260
2261       - in a second pass, traverse the chain again updating all
2262         THUNK_SEELCTORS that we find on the way with indirections to
2263         the value.
2264
2265       - if we encounter a "marked" THUNK_SELECTOR in a normal
2266         evacuate(), we konw it can't be updated so just evac it.
2267
2268    Program that illustrates the problem:
2269
2270         foo [] = ([], [])
2271         foo (x:xs) = let (ys, zs) = foo xs
2272                      in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2273
2274         main = bar [1..(100000000::Int)]
2275         bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2276
2277    -------------------------------------------------------------------------- */
2278
2279 static inline rtsBool
2280 is_to_space ( StgClosure *p )
2281 {
2282     bdescr *bd;
2283
2284     bd = Bdescr((StgPtr)p);
2285     if (HEAP_ALLOCED(p) &&
2286         ((bd->flags & BF_EVACUATED)
2287          || ((bd->flags & BF_COMPACTED) &&
2288              is_marked((P_)p,bd)))) {
2289         return rtsTrue;
2290     } else {
2291         return rtsFalse;
2292     }
2293 }
2294
2295 static StgClosure *
2296 eval_thunk_selector( nat field, StgSelector * p )
2297 {
2298     StgInfoTable *info;
2299     const StgInfoTable *info_ptr;
2300     StgClosure *selectee;
2301
2302     selectee = p->selectee;
2303
2304     // Save the real info pointer (NOTE: not the same as get_itbl()).
2305     info_ptr = p->header.info;
2306
2307     // If the THUNK_SELECTOR is in a generation that we are not
2308     // collecting, then bail out early.  We won't be able to save any
2309     // space in any case, and updating with an indirection is trickier
2310     // in an old gen.
2311     if (Bdescr((StgPtr)p)->gen_no > N) {
2312         return NULL;
2313     }
2314
2315     // BLACKHOLE the selector thunk, since it is now under evaluation.
2316     // This is important to stop us going into an infinite loop if
2317     // this selector thunk eventually refers to itself.
2318     SET_INFO(p,&stg_BLACKHOLE_info);
2319
2320 selector_loop:
2321
2322     // We don't want to end up in to-space, because this causes
2323     // problems when the GC later tries to evacuate the result of
2324     // eval_thunk_selector().  There are various ways this could
2325     // happen:
2326     //
2327     // 1. following an IND_STATIC
2328     //
2329     // 2. when the old generation is compacted, the mark phase updates
2330     //    from-space pointers to be to-space pointers, and we can't
2331     //    reliably tell which we're following (eg. from an IND_STATIC).
2332     //
2333     // 3. compacting GC again: if we're looking at a constructor in
2334     //    the compacted generation, it might point directly to objects
2335     //    in to-space.  We must bale out here, otherwise doing the selection
2336     //    will result in a to-space pointer being returned.
2337     //
2338     //  (1) is dealt with using a BF_EVACUATED test on the
2339     //  selectee. (2) and (3): we can tell if we're looking at an
2340     //  object in the compacted generation that might point to
2341     //  to-space objects by testing that (a) it is BF_COMPACTED, (b)
2342     //  the compacted generation is being collected, and (c) the
2343     //  object is marked.  Only a marked object may have pointers that
2344     //  point to to-space objects, because that happens when
2345     //  scavenging.
2346     //
2347     //  The to-space test is now embodied in the in_to_space() inline
2348     //  function, as it is re-used below.
2349     //
2350     if (is_to_space(selectee)) {
2351         goto bale_out;
2352     }
2353
2354     info = get_itbl(selectee);
2355     switch (info->type) {
2356       case CONSTR:
2357       case CONSTR_1_0:
2358       case CONSTR_0_1:
2359       case CONSTR_2_0:
2360       case CONSTR_1_1:
2361       case CONSTR_0_2:
2362       case CONSTR_STATIC:
2363       case CONSTR_NOCAF_STATIC:
2364           // check that the size is in range
2365           ASSERT(field <  (StgWord32)(info->layout.payload.ptrs +
2366                                       info->layout.payload.nptrs));
2367
2368           // Select the right field from the constructor, and check
2369           // that the result isn't in to-space.  It might be in
2370           // to-space if, for example, this constructor contains
2371           // pointers to younger-gen objects (and is on the mut-once
2372           // list).
2373           //
2374           {
2375               StgClosure *q;
2376               q = selectee->payload[field];
2377               if (is_to_space(q)) {
2378                   goto bale_out;
2379               } else {
2380                   return q;
2381               }
2382           }
2383
2384       case IND:
2385       case IND_PERM:
2386       case IND_OLDGEN:
2387       case IND_OLDGEN_PERM:
2388       case IND_STATIC:
2389           selectee = ((StgInd *)selectee)->indirectee;
2390           goto selector_loop;
2391
2392       case EVACUATED:
2393           // We don't follow pointers into to-space; the constructor
2394           // has already been evacuated, so we won't save any space
2395           // leaks by evaluating this selector thunk anyhow.
2396           break;
2397
2398       case THUNK_SELECTOR:
2399       {
2400           StgClosure *val;
2401
2402           // check that we don't recurse too much, re-using the
2403           // depth bound also used in evacuate().
2404           if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2405               break;
2406           }
2407           thunk_selector_depth++;
2408
2409           val = eval_thunk_selector(info->layout.selector_offset,
2410                                     (StgSelector *)selectee);
2411
2412           thunk_selector_depth--;
2413
2414           if (val == NULL) {
2415               break;
2416           } else {
2417               // We evaluated this selector thunk, so update it with
2418               // an indirection.  NOTE: we don't use UPD_IND here,
2419               // because we are guaranteed that p is in a generation
2420               // that we are collecting, and we never want to put the
2421               // indirection on a mutable list.
2422 #ifdef PROFILING
2423               // For the purposes of LDV profiling, we have destroyed
2424               // the original selector thunk.
2425               SET_INFO(p, info_ptr);
2426               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2427 #endif
2428               ((StgInd *)selectee)->indirectee = val;
2429               SET_INFO(selectee,&stg_IND_info);
2430
2431               // For the purposes of LDV profiling, we have created an
2432               // indirection.
2433               LDV_RECORD_CREATE(selectee);
2434
2435               selectee = val;
2436               goto selector_loop;
2437           }
2438       }
2439
2440       case AP:
2441       case AP_STACK:
2442       case THUNK:
2443       case THUNK_1_0:
2444       case THUNK_0_1:
2445       case THUNK_2_0:
2446       case THUNK_1_1:
2447       case THUNK_0_2:
2448       case THUNK_STATIC:
2449       case CAF_BLACKHOLE:
2450       case SE_CAF_BLACKHOLE:
2451       case SE_BLACKHOLE:
2452       case BLACKHOLE:
2453 #if defined(PAR)
2454       case RBH:
2455       case BLOCKED_FETCH:
2456 # ifdef DIST
2457       case REMOTE_REF:
2458 # endif
2459       case FETCH_ME:
2460       case FETCH_ME_BQ:
2461 #endif
2462           // not evaluated yet
2463           break;
2464
2465       default:
2466         barf("eval_thunk_selector: strange selectee %d",
2467              (int)(info->type));
2468     }
2469
2470 bale_out:
2471     // We didn't manage to evaluate this thunk; restore the old info pointer
2472     SET_INFO(p, info_ptr);
2473     return NULL;
2474 }
2475
2476 /* -----------------------------------------------------------------------------
2477    move_TSO is called to update the TSO structure after it has been
2478    moved from one place to another.
2479    -------------------------------------------------------------------------- */
2480
2481 void
2482 move_TSO (StgTSO *src, StgTSO *dest)
2483 {
2484     ptrdiff_t diff;
2485
2486     // relocate the stack pointer...
2487     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2488     dest->sp = (StgPtr)dest->sp + diff;
2489 }
2490
2491 /* Similar to scavenge_large_bitmap(), but we don't write back the
2492  * pointers we get back from evacuate().
2493  */
2494 static void
2495 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2496 {
2497     nat i, b, size;
2498     StgWord bitmap;
2499     StgClosure **p;
2500
2501     b = 0;
2502     bitmap = large_srt->l.bitmap[b];
2503     size   = (nat)large_srt->l.size;
2504     p      = (StgClosure **)large_srt->srt;
2505     for (i = 0; i < size; ) {
2506         if ((bitmap & 1) != 0) {
2507             evacuate(*p);
2508         }
2509         i++;
2510         p++;
2511         if (i % BITS_IN(W_) == 0) {
2512             b++;
2513             bitmap = large_srt->l.bitmap[b];
2514         } else {
2515             bitmap = bitmap >> 1;
2516         }
2517     }
2518 }
2519
2520 /* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
2521  * srt field in the info table.  That's ok, because we'll
2522  * never dereference it.
2523  */
2524 STATIC_INLINE void
2525 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2526 {
2527   nat bitmap;
2528   StgClosure **p;
2529
2530   bitmap = srt_bitmap;
2531   p = srt;
2532
2533   if (bitmap == (StgHalfWord)(-1)) {
2534       scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2535       return;
2536   }
2537
2538   while (bitmap != 0) {
2539       if ((bitmap & 1) != 0) {
2540 #ifdef ENABLE_WIN32_DLL_SUPPORT
2541           // Special-case to handle references to closures hiding out in DLLs, since
2542           // double indirections required to get at those. The code generator knows
2543           // which is which when generating the SRT, so it stores the (indirect)
2544           // reference to the DLL closure in the table by first adding one to it.
2545           // We check for this here, and undo the addition before evacuating it.
2546           //
2547           // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2548           // closure that's fixed at link-time, and no extra magic is required.
2549           if ( (unsigned long)(*srt) & 0x1 ) {
2550               evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2551           } else {
2552               evacuate(*p);
2553           }
2554 #else
2555           evacuate(*p);
2556 #endif
2557       }
2558       p++;
2559       bitmap = bitmap >> 1;
2560   }
2561 }
2562
2563
2564 STATIC_INLINE void
2565 scavenge_thunk_srt(const StgInfoTable *info)
2566 {
2567     StgThunkInfoTable *thunk_info;
2568
2569     if (!major_gc) return;
2570
2571     thunk_info = itbl_to_thunk_itbl(info);
2572     scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2573 }
2574
2575 STATIC_INLINE void
2576 scavenge_fun_srt(const StgInfoTable *info)
2577 {
2578     StgFunInfoTable *fun_info;
2579
2580     if (!major_gc) return;
2581
2582     fun_info = itbl_to_fun_itbl(info);
2583     scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2584 }
2585
2586 /* -----------------------------------------------------------------------------
2587    Scavenge a TSO.
2588    -------------------------------------------------------------------------- */
2589
2590 static void
2591 scavengeTSO (StgTSO *tso)
2592 {
2593     if (   tso->why_blocked == BlockedOnMVar
2594         || tso->why_blocked == BlockedOnBlackHole
2595         || tso->why_blocked == BlockedOnException
2596 #if defined(PAR)
2597         || tso->why_blocked == BlockedOnGA
2598         || tso->why_blocked == BlockedOnGA_NoSend
2599 #endif
2600         ) {
2601         tso->block_info.closure = evacuate(tso->block_info.closure);
2602     }
2603     if ( tso->blocked_exceptions != NULL ) {
2604         tso->blocked_exceptions =
2605             (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2606     }
2607
2608     // We don't always chase the link field: TSOs on the blackhole
2609     // queue are not automatically alive, so the link field is a
2610     // "weak" pointer in that case.
2611     if (tso->why_blocked != BlockedOnBlackHole) {
2612         tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
2613     }
2614
2615     // scavange current transaction record
2616     tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2617
2618     // scavenge this thread's stack
2619     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2620 }
2621
2622 /* -----------------------------------------------------------------------------
2623    Blocks of function args occur on the stack (at the top) and
2624    in PAPs.
2625    -------------------------------------------------------------------------- */
2626
2627 STATIC_INLINE StgPtr
2628 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2629 {
2630     StgPtr p;
2631     StgWord bitmap;
2632     nat size;
2633
2634     p = (StgPtr)args;
2635     switch (fun_info->f.fun_type) {
2636     case ARG_GEN:
2637         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2638         size = BITMAP_SIZE(fun_info->f.b.bitmap);
2639         goto small_bitmap;
2640     case ARG_GEN_BIG:
2641         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2642         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2643         p += size;
2644         break;
2645     default:
2646         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2647         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2648     small_bitmap:
2649         while (size > 0) {
2650             if ((bitmap & 1) == 0) {
2651                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2652             }
2653             p++;
2654             bitmap = bitmap >> 1;
2655             size--;
2656         }
2657         break;
2658     }
2659     return p;
2660 }
2661
2662 STATIC_INLINE StgPtr
2663 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2664 {
2665     StgPtr p;
2666     StgWord bitmap;
2667     StgFunInfoTable *fun_info;
2668
2669     fun_info = get_fun_itbl(fun);
2670     ASSERT(fun_info->i.type != PAP);
2671     p = (StgPtr)payload;
2672
2673     switch (fun_info->f.fun_type) {
2674     case ARG_GEN:
2675         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2676         goto small_bitmap;
2677     case ARG_GEN_BIG:
2678         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2679         p += size;
2680         break;
2681     case ARG_BCO:
2682         scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2683         p += size;
2684         break;
2685     default:
2686         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2687     small_bitmap:
2688         while (size > 0) {
2689             if ((bitmap & 1) == 0) {
2690                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2691             }
2692             p++;
2693             bitmap = bitmap >> 1;
2694             size--;
2695         }
2696         break;
2697     }
2698     return p;
2699 }
2700
2701 STATIC_INLINE StgPtr
2702 scavenge_PAP (StgPAP *pap)
2703 {
2704     pap->fun = evacuate(pap->fun);
2705     return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2706 }
2707
2708 STATIC_INLINE StgPtr
2709 scavenge_AP (StgAP *ap)
2710 {
2711     ap->fun = evacuate(ap->fun);
2712     return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2713 }
2714
2715 /* -----------------------------------------------------------------------------
2716    Scavenge a given step until there are no more objects in this step
2717    to scavenge.
2718
2719    evac_gen is set by the caller to be either zero (for a step in a
2720    generation < N) or G where G is the generation of the step being
2721    scavenged.
2722
2723    We sometimes temporarily change evac_gen back to zero if we're
2724    scavenging a mutable object where early promotion isn't such a good
2725    idea.
2726    -------------------------------------------------------------------------- */
2727
2728 static void
2729 scavenge(step *stp)
2730 {
2731   StgPtr p, q;
2732   StgInfoTable *info;
2733   bdescr *bd;
2734   nat saved_evac_gen = evac_gen;
2735
2736   p = stp->scan;
2737   bd = stp->scan_bd;
2738
2739   failed_to_evac = rtsFalse;
2740
2741   /* scavenge phase - standard breadth-first scavenging of the
2742    * evacuated objects
2743    */
2744
2745   while (bd != stp->hp_bd || p < stp->hp) {
2746
2747     // If we're at the end of this block, move on to the next block
2748     if (bd != stp->hp_bd && p == bd->free) {
2749       bd = bd->link;
2750       p = bd->start;
2751       continue;
2752     }
2753
2754     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2755     info = get_itbl((StgClosure *)p);
2756
2757     ASSERT(thunk_selector_depth == 0);
2758
2759     q = p;
2760     switch (info->type) {
2761
2762     case MVAR:
2763     {
2764         StgMVar *mvar = ((StgMVar *)p);
2765         evac_gen = 0;
2766         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2767         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2768         mvar->value = evacuate((StgClosure *)mvar->value);
2769         evac_gen = saved_evac_gen;
2770         failed_to_evac = rtsTrue; // mutable.
2771         p += sizeofW(StgMVar);
2772         break;
2773     }
2774
2775     case FUN_2_0:
2776         scavenge_fun_srt(info);
2777         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2778         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2779         p += sizeofW(StgHeader) + 2;
2780         break;
2781
2782     case THUNK_2_0:
2783         scavenge_thunk_srt(info);
2784         ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2785         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2786         p += sizeofW(StgThunk) + 2;
2787         break;
2788
2789     case CONSTR_2_0:
2790         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2791         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2792         p += sizeofW(StgHeader) + 2;
2793         break;
2794
2795     case THUNK_1_0:
2796         scavenge_thunk_srt(info);
2797         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2798         p += sizeofW(StgThunk) + 1;
2799         break;
2800
2801     case FUN_1_0:
2802         scavenge_fun_srt(info);
2803     case CONSTR_1_0:
2804         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2805         p += sizeofW(StgHeader) + 1;
2806         break;
2807
2808     case THUNK_0_1:
2809         scavenge_thunk_srt(info);
2810         p += sizeofW(StgThunk) + 1;
2811         break;
2812
2813     case FUN_0_1:
2814         scavenge_fun_srt(info);
2815     case CONSTR_0_1:
2816         p += sizeofW(StgHeader) + 1;
2817         break;
2818
2819     case THUNK_0_2:
2820         scavenge_thunk_srt(info);
2821         p += sizeofW(StgThunk) + 2;
2822         break;
2823
2824     case FUN_0_2:
2825         scavenge_fun_srt(info);
2826     case CONSTR_0_2:
2827         p += sizeofW(StgHeader) + 2;
2828         break;
2829
2830     case THUNK_1_1:
2831         scavenge_thunk_srt(info);
2832         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2833         p += sizeofW(StgThunk) + 2;
2834         break;
2835
2836     case FUN_1_1:
2837         scavenge_fun_srt(info);
2838     case CONSTR_1_1:
2839         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2840         p += sizeofW(StgHeader) + 2;
2841         break;
2842
2843     case FUN:
2844         scavenge_fun_srt(info);
2845         goto gen_obj;
2846
2847     case THUNK:
2848     {
2849         StgPtr end;
2850
2851         scavenge_thunk_srt(info);
2852         end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2853         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2854             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2855         }
2856         p += info->layout.payload.nptrs;
2857         break;
2858     }
2859
2860     gen_obj:
2861     case CONSTR:
2862     case WEAK:
2863     case STABLE_NAME:
2864     {
2865         StgPtr end;
2866
2867         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2868         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2869             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2870         }
2871         p += info->layout.payload.nptrs;
2872         break;
2873     }
2874
2875     case BCO: {
2876         StgBCO *bco = (StgBCO *)p;
2877         bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2878         bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2879         bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2880         bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2881         p += bco_sizeW(bco);
2882         break;
2883     }
2884
2885     case IND_PERM:
2886       if (stp->gen->no != 0) {
2887 #ifdef PROFILING
2888         // @LDV profiling
2889         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2890         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2891         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2892 #endif
2893         //
2894         // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2895         //
2896         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2897
2898         // We pretend that p has just been created.
2899         LDV_RECORD_CREATE((StgClosure *)p);
2900       }
2901         // fall through
2902     case IND_OLDGEN_PERM:
2903         ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2904         p += sizeofW(StgInd);
2905         break;
2906
2907     case MUT_VAR_CLEAN:
2908     case MUT_VAR_DIRTY: {
2909         rtsBool saved_eager_promotion = eager_promotion;
2910
2911         eager_promotion = rtsFalse;
2912         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2913         eager_promotion = saved_eager_promotion;
2914
2915         if (failed_to_evac) {
2916             ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
2917         } else {
2918             ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
2919         }
2920         p += sizeofW(StgMutVar);
2921         break;
2922     }
2923
2924     case CAF_BLACKHOLE:
2925     case SE_CAF_BLACKHOLE:
2926     case SE_BLACKHOLE:
2927     case BLACKHOLE:
2928         p += BLACKHOLE_sizeW();
2929         break;
2930
2931     case THUNK_SELECTOR:
2932     {
2933         StgSelector *s = (StgSelector *)p;
2934         s->selectee = evacuate(s->selectee);
2935         p += THUNK_SELECTOR_sizeW();
2936         break;
2937     }
2938
2939     // A chunk of stack saved in a heap object
2940     case AP_STACK:
2941     {
2942         StgAP_STACK *ap = (StgAP_STACK *)p;
2943
2944         ap->fun = evacuate(ap->fun);
2945         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2946         p = (StgPtr)ap->payload + ap->size;
2947         break;
2948     }
2949
2950     case PAP:
2951         p = scavenge_PAP((StgPAP *)p);
2952         break;
2953
2954     case AP:
2955         p = scavenge_AP((StgAP *)p);
2956         break;
2957
2958     case ARR_WORDS:
2959         // nothing to follow
2960         p += arr_words_sizeW((StgArrWords *)p);
2961         break;
2962
2963     case MUT_ARR_PTRS_CLEAN:
2964     case MUT_ARR_PTRS_DIRTY:
2965         // follow everything
2966     {
2967         StgPtr next;
2968         rtsBool saved_eager;
2969
2970         // We don't eagerly promote objects pointed to by a mutable
2971         // array, but if we find the array only points to objects in
2972         // the same or an older generation, we mark it "clean" and
2973         // avoid traversing it during minor GCs.
2974         saved_eager = eager_promotion;
2975         eager_promotion = rtsFalse;
2976         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2977         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2978             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2979         }
2980         eager_promotion = saved_eager;
2981
2982         if (failed_to_evac) {
2983             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
2984         } else {
2985             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
2986         }
2987
2988         failed_to_evac = rtsTrue; // always put it on the mutable list.
2989         break;
2990     }
2991
2992     case MUT_ARR_PTRS_FROZEN:
2993     case MUT_ARR_PTRS_FROZEN0:
2994         // follow everything
2995     {
2996         StgPtr next;
2997
2998         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2999         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3000             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3001         }
3002
3003         // If we're going to put this object on the mutable list, then
3004         // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3005         if (failed_to_evac) {
3006             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3007         } else {
3008             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3009         }
3010         break;
3011     }
3012
3013     case TSO:
3014     {
3015         StgTSO *tso = (StgTSO *)p;
3016         rtsBool saved_eager = eager_promotion;
3017
3018         eager_promotion = rtsFalse;
3019         scavengeTSO(tso);
3020         eager_promotion = saved_eager;
3021
3022         if (failed_to_evac) {
3023             tso->flags |= TSO_DIRTY;
3024         } else {
3025             tso->flags &= ~TSO_DIRTY;
3026         }
3027
3028         failed_to_evac = rtsTrue; // always on the mutable list
3029         p += tso_sizeW(tso);
3030         break;
3031     }
3032
3033 #if defined(PAR)
3034     case RBH:
3035     {
3036 #if 0
3037         nat size, ptrs, nonptrs, vhs;
3038         char str[80];
3039         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3040 #endif
3041         StgRBH *rbh = (StgRBH *)p;
3042         (StgClosure *)rbh->blocking_queue =
3043             evacuate((StgClosure *)rbh->blocking_queue);
3044         failed_to_evac = rtsTrue;  // mutable anyhow.
3045         IF_DEBUG(gc,
3046                  debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3047                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
3048         // ToDo: use size of reverted closure here!
3049         p += BLACKHOLE_sizeW();
3050         break;
3051     }
3052
3053     case BLOCKED_FETCH:
3054     {
3055         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3056         // follow the pointer to the node which is being demanded
3057         (StgClosure *)bf->node =
3058             evacuate((StgClosure *)bf->node);
3059         // follow the link to the rest of the blocking queue
3060         (StgClosure *)bf->link =
3061             evacuate((StgClosure *)bf->link);
3062         IF_DEBUG(gc,
3063                  debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3064                        bf, info_type((StgClosure *)bf),
3065                        bf->node, info_type(bf->node)));
3066         p += sizeofW(StgBlockedFetch);
3067         break;
3068     }
3069
3070 #ifdef DIST
3071     case REMOTE_REF:
3072 #endif
3073     case FETCH_ME:
3074         p += sizeofW(StgFetchMe);
3075         break; // nothing to do in this case
3076
3077     case FETCH_ME_BQ:
3078     {
3079         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3080         (StgClosure *)fmbq->blocking_queue =
3081             evacuate((StgClosure *)fmbq->blocking_queue);
3082         IF_DEBUG(gc,
3083                  debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3084                        p, info_type((StgClosure *)p)));
3085         p += sizeofW(StgFetchMeBlockingQueue);
3086         break;
3087     }
3088 #endif
3089
3090     case TVAR_WAIT_QUEUE:
3091       {
3092         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3093         evac_gen = 0;
3094         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3095         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3096         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3097         evac_gen = saved_evac_gen;
3098         failed_to_evac = rtsTrue; // mutable
3099         p += sizeofW(StgTVarWaitQueue);
3100         break;
3101       }
3102
3103     case TVAR:
3104       {
3105         StgTVar *tvar = ((StgTVar *) p);
3106         evac_gen = 0;
3107         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3108         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3109         evac_gen = saved_evac_gen;
3110         failed_to_evac = rtsTrue; // mutable
3111         p += sizeofW(StgTVar);
3112         break;
3113       }
3114
3115     case TREC_HEADER:
3116       {
3117         StgTRecHeader *trec = ((StgTRecHeader *) p);
3118         evac_gen = 0;
3119         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3120         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3121         evac_gen = saved_evac_gen;
3122         failed_to_evac = rtsTrue; // mutable
3123         p += sizeofW(StgTRecHeader);
3124         break;
3125       }
3126
3127     case TREC_CHUNK:
3128       {
3129         StgWord i;
3130         StgTRecChunk *tc = ((StgTRecChunk *) p);
3131         TRecEntry *e = &(tc -> entries[0]);
3132         evac_gen = 0;
3133         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3134         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3135           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3136           e->expected_value = evacuate((StgClosure*)e->expected_value);
3137           e->new_value = evacuate((StgClosure*)e->new_value);
3138         }
3139         evac_gen = saved_evac_gen;
3140         failed_to_evac = rtsTrue; // mutable
3141         p += sizeofW(StgTRecChunk);
3142         break;
3143       }
3144
3145     default:
3146         barf("scavenge: unimplemented/strange closure type %d @ %p",
3147              info->type, p);
3148     }
3149
3150     /*
3151      * We need to record the current object on the mutable list if
3152      *  (a) It is actually mutable, or
3153      *  (b) It contains pointers to a younger generation.
3154      * Case (b) arises if we didn't manage to promote everything that
3155      * the current object points to into the current generation.
3156      */
3157     if (failed_to_evac) {
3158         failed_to_evac = rtsFalse;
3159         if (stp->gen_no > 0) {
3160             recordMutableGen((StgClosure *)q, stp->gen);
3161         }
3162     }
3163   }
3164
3165   stp->scan_bd = bd;
3166   stp->scan = p;
3167 }
3168
3169 /* -----------------------------------------------------------------------------
3170    Scavenge everything on the mark stack.
3171
3172    This is slightly different from scavenge():
3173       - we don't walk linearly through the objects, so the scavenger
3174         doesn't need to advance the pointer on to the next object.
3175    -------------------------------------------------------------------------- */
3176
3177 static void
3178 scavenge_mark_stack(void)
3179 {
3180     StgPtr p, q;
3181     StgInfoTable *info;
3182     nat saved_evac_gen;
3183
3184     evac_gen = oldest_gen->no;
3185     saved_evac_gen = evac_gen;
3186
3187 linear_scan:
3188     while (!mark_stack_empty()) {
3189         p = pop_mark_stack();
3190
3191         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3192         info = get_itbl((StgClosure *)p);
3193
3194         q = p;
3195         switch (info->type) {
3196
3197         case MVAR:
3198         {
3199             StgMVar *mvar = ((StgMVar *)p);
3200             evac_gen = 0;
3201             mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3202             mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3203             mvar->value = evacuate((StgClosure *)mvar->value);
3204             evac_gen = saved_evac_gen;
3205             failed_to_evac = rtsTrue; // mutable.
3206             break;
3207         }
3208
3209         case FUN_2_0:
3210             scavenge_fun_srt(info);
3211             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3212             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3213             break;
3214
3215         case THUNK_2_0:
3216             scavenge_thunk_srt(info);
3217             ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
3218             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3219             break;
3220
3221         case CONSTR_2_0:
3222             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3223             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3224             break;
3225
3226         case FUN_1_0:
3227         case FUN_1_1:
3228             scavenge_fun_srt(info);
3229             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3230             break;
3231
3232         case THUNK_1_0:
3233         case THUNK_1_1:
3234             scavenge_thunk_srt(info);
3235             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3236             break;
3237
3238         case CONSTR_1_0:
3239         case CONSTR_1_1:
3240             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3241             break;
3242
3243         case FUN_0_1:
3244         case FUN_0_2:
3245             scavenge_fun_srt(info);
3246             break;
3247
3248         case THUNK_0_1:
3249         case THUNK_0_2:
3250             scavenge_thunk_srt(info);
3251             break;
3252
3253         case CONSTR_0_1:
3254         case CONSTR_0_2:
3255             break;
3256
3257         case FUN:
3258             scavenge_fun_srt(info);
3259             goto gen_obj;
3260
3261         case THUNK:
3262         {
3263             StgPtr end;
3264
3265             scavenge_thunk_srt(info);
3266             end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3267             for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3268                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3269             }
3270             break;
3271         }
3272
3273         gen_obj:
3274         case CONSTR:
3275         case WEAK:
3276         case STABLE_NAME:
3277         {
3278             StgPtr end;
3279
3280             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3281             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3282                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3283             }
3284             break;
3285         }
3286
3287         case BCO: {
3288             StgBCO *bco = (StgBCO *)p;
3289             bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3290             bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3291             bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3292             bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3293             break;
3294         }
3295
3296         case IND_PERM:
3297             // don't need to do anything here: the only possible case
3298             // is that we're in a 1-space compacting collector, with
3299             // no "old" generation.
3300             break;
3301
3302         case IND_OLDGEN:
3303         case IND_OLDGEN_PERM:
3304             ((StgInd *)p)->indirectee =
3305                 evacuate(((StgInd *)p)->indirectee);
3306             break;
3307
3308         case MUT_VAR_CLEAN:
3309         case MUT_VAR_DIRTY: {
3310             rtsBool saved_eager_promotion = eager_promotion;
3311
3312             eager_promotion = rtsFalse;
3313             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3314             eager_promotion = saved_eager_promotion;
3315
3316             if (failed_to_evac) {
3317                 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3318             } else {
3319                 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3320             }
3321             break;
3322         }
3323
3324         case CAF_BLACKHOLE:
3325         case SE_CAF_BLACKHOLE:
3326         case SE_BLACKHOLE:
3327         case BLACKHOLE:
3328         case ARR_WORDS:
3329             break;
3330
3331         case THUNK_SELECTOR:
3332         {
3333             StgSelector *s = (StgSelector *)p;
3334             s->selectee = evacuate(s->selectee);
3335             break;
3336         }
3337
3338         // A chunk of stack saved in a heap object
3339         case AP_STACK:
3340         {
3341             StgAP_STACK *ap = (StgAP_STACK *)p;
3342
3343             ap->fun = evacuate(ap->fun);
3344             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3345             break;
3346         }
3347
3348         case PAP:
3349             scavenge_PAP((StgPAP *)p);
3350             break;
3351
3352         case AP:
3353             scavenge_AP((StgAP *)p);
3354             break;
3355
3356         case MUT_ARR_PTRS_CLEAN:
3357         case MUT_ARR_PTRS_DIRTY:
3358             // follow everything
3359         {
3360             StgPtr next;
3361             rtsBool saved_eager;
3362
3363             // We don't eagerly promote objects pointed to by a mutable
3364             // array, but if we find the array only points to objects in
3365             // the same or an older generation, we mark it "clean" and
3366             // avoid traversing it during minor GCs.
3367             saved_eager = eager_promotion;
3368             eager_promotion = rtsFalse;
3369             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3370             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3371                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3372             }
3373             eager_promotion = saved_eager;
3374
3375             if (failed_to_evac) {
3376                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3377             } else {
3378                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3379             }
3380
3381             failed_to_evac = rtsTrue; // mutable anyhow.
3382             break;
3383         }
3384
3385         case MUT_ARR_PTRS_FROZEN:
3386         case MUT_ARR_PTRS_FROZEN0:
3387             // follow everything
3388         {
3389             StgPtr next, q = p;
3390
3391             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3392             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3393                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3394             }
3395
3396             // If we're going to put this object on the mutable list, then
3397             // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3398             if (failed_to_evac) {
3399                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3400             } else {
3401                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3402             }
3403             break;
3404         }
3405
3406         case TSO:
3407         {
3408             StgTSO *tso = (StgTSO *)p;
3409             rtsBool saved_eager = eager_promotion;
3410
3411             eager_promotion = rtsFalse;
3412             scavengeTSO(tso);
3413             eager_promotion = saved_eager;
3414
3415             if (failed_to_evac) {
3416                 tso->flags |= TSO_DIRTY;
3417             } else {
3418                 tso->flags &= ~TSO_DIRTY;
3419             }
3420
3421             failed_to_evac = rtsTrue; // always on the mutable list
3422             break;
3423         }
3424
3425 #if defined(PAR)
3426         case RBH:
3427         {
3428 #if 0
3429             nat size, ptrs, nonptrs, vhs;
3430             char str[80];
3431             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3432 #endif
3433             StgRBH *rbh = (StgRBH *)p;
3434             bh->blocking_queue =
3435                 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3436             failed_to_evac = rtsTrue;  // mutable anyhow.
3437             IF_DEBUG(gc,
3438                      debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3439                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
3440             break;
3441         }
3442
3443         case BLOCKED_FETCH:
3444         {
3445             StgBlockedFetch *bf = (StgBlockedFetch *)p;
3446             // follow the pointer to the node which is being demanded
3447             (StgClosure *)bf->node =
3448                 evacuate((StgClosure *)bf->node);
3449             // follow the link to the rest of the blocking queue
3450             (StgClosure *)bf->link =
3451                 evacuate((StgClosure *)bf->link);
3452             IF_DEBUG(gc,
3453                      debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3454                            bf, info_type((StgClosure *)bf),
3455                            bf->node, info_type(bf->node)));
3456             break;
3457         }
3458
3459 #ifdef DIST
3460         case REMOTE_REF:
3461 #endif
3462         case FETCH_ME:
3463             break; // nothing to do in this case
3464
3465         case FETCH_ME_BQ:
3466         {
3467             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3468             (StgClosure *)fmbq->blocking_queue =
3469                 evacuate((StgClosure *)fmbq->blocking_queue);
3470             IF_DEBUG(gc,
3471                      debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3472                            p, info_type((StgClosure *)p)));
3473             break;
3474         }
3475 #endif /* PAR */
3476
3477         case TVAR_WAIT_QUEUE:
3478           {
3479             StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3480             evac_gen = 0;
3481             wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3482             wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3483             wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3484             evac_gen = saved_evac_gen;
3485             failed_to_evac = rtsTrue; // mutable
3486             break;
3487           }
3488
3489         case TVAR:
3490           {
3491             StgTVar *tvar = ((StgTVar *) p);
3492             evac_gen = 0;
3493             tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3494             tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3495             evac_gen = saved_evac_gen;
3496             failed_to_evac = rtsTrue; // mutable
3497             break;
3498           }
3499
3500         case TREC_CHUNK:
3501           {
3502             StgWord i;
3503             StgTRecChunk *tc = ((StgTRecChunk *) p);
3504             TRecEntry *e = &(tc -> entries[0]);
3505             evac_gen = 0;
3506             tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3507             for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3508               e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3509               e->expected_value = evacuate((StgClosure*)e->expected_value);
3510               e->new_value = evacuate((StgClosure*)e->new_value);
3511             }
3512             evac_gen = saved_evac_gen;
3513             failed_to_evac = rtsTrue; // mutable
3514             break;
3515           }
3516
3517         case TREC_HEADER:
3518           {
3519             StgTRecHeader *trec = ((StgTRecHeader *) p);
3520             evac_gen = 0;
3521             trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3522             trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3523             evac_gen = saved_evac_gen;
3524             failed_to_evac = rtsTrue; // mutable
3525             break;
3526           }
3527
3528         default:
3529             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3530                  info->type, p);
3531         }
3532
3533         if (failed_to_evac) {
3534             failed_to_evac = rtsFalse;
3535             if (evac_gen > 0) {
3536                 recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3537             }
3538         }
3539
3540         // mark the next bit to indicate "scavenged"
3541         mark(q+1, Bdescr(q));
3542
3543     } // while (!mark_stack_empty())
3544
3545     // start a new linear scan if the mark stack overflowed at some point
3546     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3547         IF_DEBUG(gc, debugBelch("scavenge_mark_stack: starting linear scan"));
3548         mark_stack_overflowed = rtsFalse;
3549         oldgen_scan_bd = oldest_gen->steps[0].old_blocks;
3550         oldgen_scan = oldgen_scan_bd->start;
3551     }
3552
3553     if (oldgen_scan_bd) {
3554         // push a new thing on the mark stack
3555     loop:
3556         // find a closure that is marked but not scavenged, and start
3557         // from there.
3558         while (oldgen_scan < oldgen_scan_bd->free
3559                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3560             oldgen_scan++;
3561         }
3562
3563         if (oldgen_scan < oldgen_scan_bd->free) {
3564
3565             // already scavenged?
3566             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3567                 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3568                 goto loop;
3569             }
3570             push_mark_stack(oldgen_scan);
3571             // ToDo: bump the linear scan by the actual size of the object
3572             oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3573             goto linear_scan;
3574         }
3575
3576         oldgen_scan_bd = oldgen_scan_bd->link;
3577         if (oldgen_scan_bd != NULL) {
3578             oldgen_scan = oldgen_scan_bd->start;
3579             goto loop;
3580         }
3581     }
3582 }
3583
3584 /* -----------------------------------------------------------------------------
3585    Scavenge one object.
3586
3587    This is used for objects that are temporarily marked as mutable
3588    because they contain old-to-new generation pointers.  Only certain
3589    objects can have this property.
3590    -------------------------------------------------------------------------- */
3591
3592 static rtsBool
3593 scavenge_one(StgPtr p)
3594 {
3595     const StgInfoTable *info;
3596     nat saved_evac_gen = evac_gen;
3597     rtsBool no_luck;
3598
3599     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3600     info = get_itbl((StgClosure *)p);
3601
3602     switch (info->type) {
3603
3604     case MVAR:
3605     {
3606         StgMVar *mvar = ((StgMVar *)p);
3607         evac_gen = 0;
3608         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3609         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3610         mvar->value = evacuate((StgClosure *)mvar->value);
3611         evac_gen = saved_evac_gen;
3612         failed_to_evac = rtsTrue; // mutable.
3613         break;
3614     }
3615
3616     case THUNK:
3617     case THUNK_1_0:
3618     case THUNK_0_1:
3619     case THUNK_1_1:
3620     case THUNK_0_2:
3621     case THUNK_2_0:
3622     {
3623         StgPtr q, end;
3624
3625         end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3626         for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3627             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3628         }
3629         break;
3630     }
3631
3632     case FUN:
3633     case FUN_1_0:                       // hardly worth specialising these guys
3634     case FUN_0_1:
3635     case FUN_1_1:
3636     case FUN_0_2:
3637     case FUN_2_0:
3638     case CONSTR:
3639     case CONSTR_1_0:
3640     case CONSTR_0_1:
3641     case CONSTR_1_1:
3642     case CONSTR_0_2:
3643     case CONSTR_2_0:
3644     case WEAK:
3645     case IND_PERM:
3646     {
3647         StgPtr q, end;
3648
3649         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3650         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3651             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3652         }
3653         break;
3654     }
3655
3656     case MUT_VAR_CLEAN:
3657     case MUT_VAR_DIRTY: {
3658         StgPtr q = p;
3659         rtsBool saved_eager_promotion = eager_promotion;
3660
3661         eager_promotion = rtsFalse;
3662         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3663         eager_promotion = saved_eager_promotion;
3664
3665         if (failed_to_evac) {
3666             ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3667         } else {
3668             ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3669         }
3670         break;
3671     }
3672
3673     case CAF_BLACKHOLE:
3674     case SE_CAF_BLACKHOLE:
3675     case SE_BLACKHOLE:
3676     case BLACKHOLE:
3677         break;
3678
3679     case THUNK_SELECTOR:
3680     {
3681         StgSelector *s = (StgSelector *)p;
3682         s->selectee = evacuate(s->selectee);
3683         break;
3684     }
3685
3686     case AP_STACK:
3687     {
3688         StgAP_STACK *ap = (StgAP_STACK *)p;
3689
3690         ap->fun = evacuate(ap->fun);
3691         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3692         p = (StgPtr)ap->payload + ap->size;
3693         break;
3694     }
3695
3696     case PAP:
3697         p = scavenge_PAP((StgPAP *)p);
3698         break;
3699
3700     case AP:
3701         p = scavenge_AP((StgAP *)p);
3702         break;
3703
3704     case ARR_WORDS:
3705         // nothing to follow
3706         break;
3707
3708     case MUT_ARR_PTRS_CLEAN:
3709     case MUT_ARR_PTRS_DIRTY:
3710     {
3711         StgPtr next, q;
3712         rtsBool saved_eager;
3713
3714         // We don't eagerly promote objects pointed to by a mutable
3715         // array, but if we find the array only points to objects in
3716         // the same or an older generation, we mark it "clean" and
3717         // avoid traversing it during minor GCs.
3718         saved_eager = eager_promotion;
3719         eager_promotion = rtsFalse;
3720         q = p;
3721         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3722         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3723             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3724         }
3725         eager_promotion = saved_eager;
3726
3727         if (failed_to_evac) {
3728             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3729         } else {
3730             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3731         }
3732
3733         failed_to_evac = rtsTrue;
3734         break;
3735     }
3736
3737     case MUT_ARR_PTRS_FROZEN:
3738     case MUT_ARR_PTRS_FROZEN0:
3739     {
3740         // follow everything
3741         StgPtr next, q=p;
3742
3743         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3744         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3745             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3746         }
3747
3748         // If we're going to put this object on the mutable list, then
3749         // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3750         if (failed_to_evac) {
3751             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3752         } else {
3753             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3754         }
3755         break;
3756     }
3757
3758     case TSO:
3759     {
3760         StgTSO *tso = (StgTSO *)p;
3761         rtsBool saved_eager = eager_promotion;
3762
3763         eager_promotion = rtsFalse;
3764         scavengeTSO(tso);
3765         eager_promotion = saved_eager;
3766
3767         if (failed_to_evac) {
3768             tso->flags |= TSO_DIRTY;
3769         } else {
3770             tso->flags &= ~TSO_DIRTY;
3771         }
3772
3773         failed_to_evac = rtsTrue; // always on the mutable list
3774         break;
3775     }
3776
3777 #if defined(PAR)
3778     case RBH:
3779     {
3780 #if 0
3781         nat size, ptrs, nonptrs, vhs;
3782         char str[80];
3783         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3784 #endif
3785         StgRBH *rbh = (StgRBH *)p;
3786         (StgClosure *)rbh->blocking_queue =
3787             evacuate((StgClosure *)rbh->blocking_queue);
3788         failed_to_evac = rtsTrue;  // mutable anyhow.
3789         IF_DEBUG(gc,
3790                  debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3791                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
3792         // ToDo: use size of reverted closure here!
3793         break;
3794     }
3795
3796     case BLOCKED_FETCH:
3797     {
3798         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3799         // follow the pointer to the node which is being demanded
3800         (StgClosure *)bf->node =
3801             evacuate((StgClosure *)bf->node);
3802         // follow the link to the rest of the blocking queue
3803         (StgClosure *)bf->link =
3804             evacuate((StgClosure *)bf->link);
3805         IF_DEBUG(gc,
3806                  debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3807                        bf, info_type((StgClosure *)bf),
3808                        bf->node, info_type(bf->node)));
3809         break;
3810     }
3811
3812 #ifdef DIST
3813     case REMOTE_REF:
3814 #endif
3815     case FETCH_ME:
3816         break; // nothing to do in this case
3817
3818     case FETCH_ME_BQ:
3819     {
3820         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3821         (StgClosure *)fmbq->blocking_queue =
3822             evacuate((StgClosure *)fmbq->blocking_queue);
3823         IF_DEBUG(gc,
3824                  debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3825                        p, info_type((StgClosure *)p)));
3826         break;
3827     }
3828 #endif
3829
3830     case TVAR_WAIT_QUEUE:
3831       {
3832         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3833         evac_gen = 0;
3834         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3835         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3836         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3837         evac_gen = saved_evac_gen;
3838         failed_to_evac = rtsTrue; // mutable
3839         break;
3840       }
3841
3842     case TVAR:
3843       {
3844         StgTVar *tvar = ((StgTVar *) p);
3845         evac_gen = 0;
3846         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3847         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3848         evac_gen = saved_evac_gen;
3849         failed_to_evac = rtsTrue; // mutable
3850         break;
3851       }
3852
3853     case TREC_HEADER:
3854       {
3855         StgTRecHeader *trec = ((StgTRecHeader *) p);
3856         evac_gen = 0;
3857         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3858         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3859         evac_gen = saved_evac_gen;
3860         failed_to_evac = rtsTrue; // mutable
3861         break;
3862       }
3863
3864     case TREC_CHUNK:
3865       {
3866         StgWord i;
3867         StgTRecChunk *tc = ((StgTRecChunk *) p);
3868         TRecEntry *e = &(tc -> entries[0]);
3869         evac_gen = 0;
3870         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3871         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3872           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3873           e->expected_value = evacuate((StgClosure*)e->expected_value);
3874           e->new_value = evacuate((StgClosure*)e->new_value);
3875         }
3876         evac_gen = saved_evac_gen;
3877         failed_to_evac = rtsTrue; // mutable
3878         break;
3879       }
3880
3881     case IND_OLDGEN:
3882     case IND_OLDGEN_PERM:
3883     case IND_STATIC:
3884     {
3885         /* Careful here: a THUNK can be on the mutable list because
3886          * it contains pointers to young gen objects.  If such a thunk
3887          * is updated, the IND_OLDGEN will be added to the mutable
3888          * list again, and we'll scavenge it twice.  evacuate()
3889          * doesn't check whether the object has already been
3890          * evacuated, so we perform that check here.
3891          */
3892         StgClosure *q = ((StgInd *)p)->indirectee;
3893         if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
3894             break;
3895         }
3896         ((StgInd *)p)->indirectee = evacuate(q);
3897     }
3898
3899 #if 0 && defined(DEBUG)
3900       if (RtsFlags.DebugFlags.gc)
3901       /* Debugging code to print out the size of the thing we just
3902        * promoted
3903        */
3904       {
3905         StgPtr start = gen->steps[0].scan;
3906         bdescr *start_bd = gen->steps[0].scan_bd;
3907         nat size = 0;
3908         scavenge(&gen->steps[0]);
3909         if (start_bd != gen->steps[0].scan_bd) {
3910           size += (P_)BLOCK_ROUND_UP(start) - start;
3911           start_bd = start_bd->link;
3912           while (start_bd != gen->steps[0].scan_bd) {
3913             size += BLOCK_SIZE_W;
3914             start_bd = start_bd->link;
3915           }
3916           size += gen->steps[0].scan -
3917             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3918         } else {
3919           size = gen->steps[0].scan - start;
3920         }
3921         debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3922       }
3923 #endif
3924       break;
3925
3926     default:
3927         barf("scavenge_one: strange object %d", (int)(info->type));
3928     }
3929
3930     no_luck = failed_to_evac;
3931     failed_to_evac = rtsFalse;
3932     return (no_luck);
3933 }
3934
3935 /* -----------------------------------------------------------------------------
3936    Scavenging mutable lists.
3937
3938    We treat the mutable list of each generation > N (i.e. all the
3939    generations older than the one being collected) as roots.  We also
3940    remove non-mutable objects from the mutable list at this point.
3941    -------------------------------------------------------------------------- */
3942
3943 static void
3944 scavenge_mutable_list(generation *gen)
3945 {
3946     bdescr *bd;
3947     StgPtr p, q;
3948
3949     bd = gen->saved_mut_list;
3950
3951     evac_gen = gen->no;
3952     for (; bd != NULL; bd = bd->link) {
3953         for (q = bd->start; q < bd->free; q++) {
3954             p = (StgPtr)*q;
3955             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3956
3957 #ifdef DEBUG
3958             switch (get_itbl((StgClosure *)p)->type) {
3959             case MUT_VAR_CLEAN:
3960                 barf("MUT_VAR_CLEAN on mutable list");
3961             case MUT_VAR_DIRTY:
3962                 mutlist_MUTVARS++; break;
3963             case MUT_ARR_PTRS_CLEAN:
3964             case MUT_ARR_PTRS_DIRTY:
3965             case MUT_ARR_PTRS_FROZEN:
3966             case MUT_ARR_PTRS_FROZEN0:
3967                 mutlist_MUTARRS++; break;
3968             default:
3969                 mutlist_OTHERS++; break;
3970             }
3971 #endif
3972
3973             // Check whether this object is "clean", that is it
3974             // definitely doesn't point into a young generation.
3975             // Clean objects don't need to be scavenged.  Some clean
3976             // objects (MUT_VAR_CLEAN) are not kept on the mutable
3977             // list at all; others, such as MUT_ARR_PTRS_CLEAN and
3978             // TSO, are always on the mutable list.
3979             //
3980             switch (get_itbl((StgClosure *)p)->type) {
3981             case MUT_ARR_PTRS_CLEAN:
3982                 recordMutableGen((StgClosure *)p,gen);
3983                 continue;
3984             case TSO: {
3985                 StgTSO *tso = (StgTSO *)p;
3986                 if ((tso->flags & TSO_DIRTY) == 0) {
3987                     // A clean TSO: we don't have to traverse its
3988                     // stack.  However, we *do* follow the link field:
3989                     // we don't want to have to mark a TSO dirty just
3990                     // because we put it on a different queue.
3991                     if (tso->why_blocked != BlockedOnBlackHole) {
3992                         tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
3993                     }
3994                     recordMutableGen((StgClosure *)p,gen);
3995                     continue;
3996                 }
3997             }
3998             default:
3999                 ;
4000             }
4001
4002             if (scavenge_one(p)) {
4003                 // didn't manage to promote everything, so put the
4004                 // object back on the list.
4005                 recordMutableGen((StgClosure *)p,gen);
4006             }
4007         }
4008     }
4009
4010     // free the old mut_list
4011     freeChain(gen->saved_mut_list);
4012     gen->saved_mut_list = NULL;
4013 }
4014
4015
4016 static void
4017 scavenge_static(void)
4018 {
4019   StgClosure* p = static_objects;
4020   const StgInfoTable *info;
4021
4022   /* Always evacuate straight to the oldest generation for static
4023    * objects */
4024   evac_gen = oldest_gen->no;
4025
4026   /* keep going until we've scavenged all the objects on the linked
4027      list... */
4028   while (p != END_OF_STATIC_LIST) {
4029
4030     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
4031     info = get_itbl(p);
4032     /*
4033     if (info->type==RBH)
4034       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
4035     */
4036     // make sure the info pointer is into text space
4037
4038     /* Take this object *off* the static_objects list,
4039      * and put it on the scavenged_static_objects list.
4040      */
4041     static_objects = *STATIC_LINK(info,p);
4042     *STATIC_LINK(info,p) = scavenged_static_objects;
4043     scavenged_static_objects = p;
4044
4045     switch (info -> type) {
4046
4047     case IND_STATIC:
4048       {
4049         StgInd *ind = (StgInd *)p;
4050         ind->indirectee = evacuate(ind->indirectee);
4051
4052         /* might fail to evacuate it, in which case we have to pop it
4053          * back on the mutable list of the oldest generation.  We
4054          * leave it *on* the scavenged_static_objects list, though,
4055          * in case we visit this object again.
4056          */
4057         if (failed_to_evac) {
4058           failed_to_evac = rtsFalse;
4059           recordMutableGen((StgClosure *)p,oldest_gen);
4060         }
4061         break;
4062       }
4063
4064     case THUNK_STATIC:
4065       scavenge_thunk_srt(info);
4066       break;
4067
4068     case FUN_STATIC:
4069       scavenge_fun_srt(info);
4070       break;
4071
4072     case CONSTR_STATIC:
4073       {
4074         StgPtr q, next;
4075
4076         next = (P_)p->payload + info->layout.payload.ptrs;
4077         // evacuate the pointers
4078         for (q = (P_)p->payload; q < next; q++) {
4079             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
4080         }
4081         break;
4082       }
4083
4084     default:
4085       barf("scavenge_static: strange closure %d", (int)(info->type));
4086     }
4087
4088     ASSERT(failed_to_evac == rtsFalse);
4089
4090     /* get the next static object from the list.  Remember, there might
4091      * be more stuff on this list now that we've done some evacuating!
4092      * (static_objects is a global)
4093      */
4094     p = static_objects;
4095   }
4096 }
4097
4098 /* -----------------------------------------------------------------------------
4099    scavenge a chunk of memory described by a bitmap
4100    -------------------------------------------------------------------------- */
4101
4102 static void
4103 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
4104 {
4105     nat i, b;
4106     StgWord bitmap;
4107
4108     b = 0;
4109     bitmap = large_bitmap->bitmap[b];
4110     for (i = 0; i < size; ) {
4111         if ((bitmap & 1) == 0) {
4112             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4113         }
4114         i++;
4115         p++;
4116         if (i % BITS_IN(W_) == 0) {
4117             b++;
4118             bitmap = large_bitmap->bitmap[b];
4119         } else {
4120             bitmap = bitmap >> 1;
4121         }
4122     }
4123 }
4124
4125 STATIC_INLINE StgPtr
4126 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
4127 {
4128     while (size > 0) {
4129         if ((bitmap & 1) == 0) {
4130             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4131         }
4132         p++;
4133         bitmap = bitmap >> 1;
4134         size--;
4135     }
4136     return p;
4137 }
4138
4139 /* -----------------------------------------------------------------------------
4140    scavenge_stack walks over a section of stack and evacuates all the
4141    objects pointed to by it.  We can use the same code for walking
4142    AP_STACK_UPDs, since these are just sections of copied stack.
4143    -------------------------------------------------------------------------- */
4144
4145
4146 static void
4147 scavenge_stack(StgPtr p, StgPtr stack_end)
4148 {
4149   const StgRetInfoTable* info;
4150   StgWord bitmap;
4151   nat size;
4152
4153   //IF_DEBUG(sanity, debugBelch("  scavenging stack between %p and %p", p, stack_end));
4154
4155   /*
4156    * Each time around this loop, we are looking at a chunk of stack
4157    * that starts with an activation record.
4158    */
4159
4160   while (p < stack_end) {
4161     info  = get_ret_itbl((StgClosure *)p);
4162
4163     switch (info->i.type) {
4164
4165     case UPDATE_FRAME:
4166         // In SMP, we can get update frames that point to indirections
4167         // when two threads evaluate the same thunk.  We do attempt to
4168         // discover this situation in threadPaused(), but it's
4169         // possible that the following sequence occurs:
4170         //
4171         //        A             B
4172         //                  enter T
4173         //     enter T
4174         //     blackhole T
4175         //                  update T
4176         //     GC
4177         //
4178         // Now T is an indirection, and the update frame is already
4179         // marked on A's stack, so we won't traverse it again in
4180         // threadPaused().  We could traverse the whole stack again
4181         // before GC, but that seems like overkill.
4182         //
4183         // Scavenging this update frame as normal would be disastrous;
4184         // the updatee would end up pointing to the value.  So we turn
4185         // the indirection into an IND_PERM, so that evacuate will
4186         // copy the indirection into the old generation instead of
4187         // discarding it.
4188         if (get_itbl(((StgUpdateFrame *)p)->updatee)->type == IND) {
4189             ((StgUpdateFrame *)p)->updatee->header.info =
4190                 (StgInfoTable *)&stg_IND_PERM_info;
4191         }
4192         ((StgUpdateFrame *)p)->updatee
4193             = evacuate(((StgUpdateFrame *)p)->updatee);
4194         p += sizeofW(StgUpdateFrame);
4195         continue;
4196
4197       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
4198     case CATCH_STM_FRAME:
4199     case CATCH_RETRY_FRAME:
4200     case ATOMICALLY_FRAME:
4201     case STOP_FRAME:
4202     case CATCH_FRAME:
4203     case RET_SMALL:
4204     case RET_VEC_SMALL:
4205         bitmap = BITMAP_BITS(info->i.layout.bitmap);
4206         size   = BITMAP_SIZE(info->i.layout.bitmap);
4207         // NOTE: the payload starts immediately after the info-ptr, we
4208         // don't have an StgHeader in the same sense as a heap closure.
4209         p++;
4210         p = scavenge_small_bitmap(p, size, bitmap);
4211
4212     follow_srt:
4213         if (major_gc)
4214             scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
4215         continue;
4216
4217     case RET_BCO: {
4218         StgBCO *bco;
4219         nat size;
4220
4221         p++;
4222         *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4223         bco = (StgBCO *)*p;
4224         p++;
4225         size = BCO_BITMAP_SIZE(bco);
4226         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
4227         p += size;
4228         continue;
4229     }
4230
4231       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
4232     case RET_BIG:
4233     case RET_VEC_BIG:
4234     {
4235         nat size;
4236
4237         size = GET_LARGE_BITMAP(&info->i)->size;
4238         p++;
4239         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
4240         p += size;
4241         // and don't forget to follow the SRT
4242         goto follow_srt;
4243     }
4244
4245       // Dynamic bitmap: the mask is stored on the stack, and
4246       // there are a number of non-pointers followed by a number
4247       // of pointers above the bitmapped area.  (see StgMacros.h,
4248       // HEAP_CHK_GEN).
4249     case RET_DYN:
4250     {
4251         StgWord dyn;
4252         dyn = ((StgRetDyn *)p)->liveness;
4253
4254         // traverse the bitmap first
4255         bitmap = RET_DYN_LIVENESS(dyn);
4256         p      = (P_)&((StgRetDyn *)p)->payload[0];
4257         size   = RET_DYN_BITMAP_SIZE;
4258         p = scavenge_small_bitmap(p, size, bitmap);
4259
4260         // skip over the non-ptr words
4261         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
4262
4263         // follow the ptr words
4264         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
4265             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4266             p++;
4267         }
4268         continue;
4269     }
4270
4271     case RET_FUN:
4272     {
4273         StgRetFun *ret_fun = (StgRetFun *)p;
4274         StgFunInfoTable *fun_info;
4275
4276         ret_fun->fun = evacuate(ret_fun->fun);
4277         fun_info = get_fun_itbl(ret_fun->fun);
4278         p = scavenge_arg_block(fun_info, ret_fun->payload);
4279         goto follow_srt;
4280     }
4281
4282     default:
4283         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
4284     }
4285   }
4286 }
4287
4288 /*-----------------------------------------------------------------------------
4289   scavenge the large object list.
4290
4291   evac_gen set by caller; similar games played with evac_gen as with
4292   scavenge() - see comment at the top of scavenge().  Most large
4293   objects are (repeatedly) mutable, so most of the time evac_gen will
4294   be zero.
4295   --------------------------------------------------------------------------- */
4296
4297 static void
4298 scavenge_large(step *stp)
4299 {
4300   bdescr *bd;
4301   StgPtr p;
4302
4303   bd = stp->new_large_objects;
4304
4305   for (; bd != NULL; bd = stp->new_large_objects) {
4306
4307     /* take this object *off* the large objects list and put it on
4308      * the scavenged large objects list.  This is so that we can
4309      * treat new_large_objects as a stack and push new objects on
4310      * the front when evacuating.
4311      */
4312     stp->new_large_objects = bd->link;
4313     dbl_link_onto(bd, &stp->scavenged_large_objects);
4314
4315     // update the block count in this step.
4316     stp->n_scavenged_large_blocks += bd->blocks;
4317
4318     p = bd->start;
4319     if (scavenge_one(p)) {
4320         if (stp->gen_no > 0) {
4321             recordMutableGen((StgClosure *)p, stp->gen);
4322         }
4323     }
4324   }
4325 }
4326
4327 /* -----------------------------------------------------------------------------
4328    Initialising the static object & mutable lists
4329    -------------------------------------------------------------------------- */
4330
4331 static void
4332 zero_static_object_list(StgClosure* first_static)
4333 {
4334   StgClosure* p;
4335   StgClosure* link;
4336   const StgInfoTable *info;
4337
4338   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
4339     info = get_itbl(p);
4340     link = *STATIC_LINK(info, p);
4341     *STATIC_LINK(info,p) = NULL;
4342   }
4343 }
4344
4345 /* -----------------------------------------------------------------------------
4346    Reverting CAFs
4347    -------------------------------------------------------------------------- */
4348
4349 void
4350 revertCAFs( void )
4351 {
4352     StgIndStatic *c;
4353
4354     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4355          c = (StgIndStatic *)c->static_link)
4356     {
4357         SET_INFO(c, c->saved_info);
4358         c->saved_info = NULL;
4359         // could, but not necessary: c->static_link = NULL;
4360     }
4361     revertible_caf_list = NULL;
4362 }
4363
4364 void
4365 markCAFs( evac_fn evac )
4366 {
4367     StgIndStatic *c;
4368
4369     for (c = (StgIndStatic *)caf_list; c != NULL;
4370          c = (StgIndStatic *)c->static_link)
4371     {
4372         evac(&c->indirectee);
4373     }
4374     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4375          c = (StgIndStatic *)c->static_link)
4376     {
4377         evac(&c->indirectee);
4378     }
4379 }
4380
4381 /* -----------------------------------------------------------------------------
4382    Sanity code for CAF garbage collection.
4383
4384    With DEBUG turned on, we manage a CAF list in addition to the SRT
4385    mechanism.  After GC, we run down the CAF list and blackhole any
4386    CAFs which have been garbage collected.  This means we get an error
4387    whenever the program tries to enter a garbage collected CAF.
4388
4389    Any garbage collected CAFs are taken off the CAF list at the same
4390    time.
4391    -------------------------------------------------------------------------- */
4392
4393 #if 0 && defined(DEBUG)
4394
4395 static void
4396 gcCAFs(void)
4397 {
4398   StgClosure*  p;
4399   StgClosure** pp;
4400   const StgInfoTable *info;
4401   nat i;
4402
4403   i = 0;
4404   p = caf_list;
4405   pp = &caf_list;
4406
4407   while (p != NULL) {
4408
4409     info = get_itbl(p);
4410
4411     ASSERT(info->type == IND_STATIC);
4412
4413     if (STATIC_LINK(info,p) == NULL) {
4414       IF_DEBUG(gccafs, debugBelch("CAF gc'd at 0x%04lx", (long)p));
4415       // black hole it
4416       SET_INFO(p,&stg_BLACKHOLE_info);
4417       p = STATIC_LINK2(info,p);
4418       *pp = p;
4419     }
4420     else {
4421       pp = &STATIC_LINK2(info,p);
4422       p = *pp;
4423       i++;
4424     }
4425
4426   }
4427
4428   //  debugBelch("%d CAFs live", i);
4429 }
4430 #endif
4431
4432
4433 /* -----------------------------------------------------------------------------
4434  * Stack squeezing
4435  *
4436  * Code largely pinched from old RTS, then hacked to bits.  We also do
4437  * lazy black holing here.
4438  *
4439  * -------------------------------------------------------------------------- */
4440
4441 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4442
4443 static void
4444 stackSqueeze(StgTSO *tso, StgPtr bottom)
4445 {
4446     StgPtr frame;
4447     rtsBool prev_was_update_frame;
4448     StgClosure *updatee = NULL;
4449     StgRetInfoTable *info;
4450     StgWord current_gap_size;
4451     struct stack_gap *gap;
4452
4453     // Stage 1:
4454     //    Traverse the stack upwards, replacing adjacent update frames
4455     //    with a single update frame and a "stack gap".  A stack gap
4456     //    contains two values: the size of the gap, and the distance
4457     //    to the next gap (or the stack top).
4458
4459     frame = tso->sp;
4460
4461     ASSERT(frame < bottom);
4462
4463     prev_was_update_frame = rtsFalse;
4464     current_gap_size = 0;
4465     gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4466
4467     while (frame < bottom) {
4468
4469         info = get_ret_itbl((StgClosure *)frame);
4470         switch (info->i.type) {
4471
4472         case UPDATE_FRAME:
4473         {
4474             StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4475
4476             if (prev_was_update_frame) {
4477
4478                 TICK_UPD_SQUEEZED();
4479                 /* wasn't there something about update squeezing and ticky to be
4480                  * sorted out?  oh yes: we aren't counting each enter properly
4481                  * in this case.  See the log somewhere.  KSW 1999-04-21
4482                  *
4483                  * Check two things: that the two update frames don't point to
4484                  * the same object, and that the updatee_bypass isn't already an
4485                  * indirection.  Both of these cases only happen when we're in a
4486                  * block hole-style loop (and there are multiple update frames
4487                  * on the stack pointing to the same closure), but they can both
4488                  * screw us up if we don't check.
4489                  */
4490                 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4491                     UPD_IND_NOLOCK(upd->updatee, updatee);
4492                 }
4493
4494                 // now mark this update frame as a stack gap.  The gap
4495                 // marker resides in the bottom-most update frame of
4496                 // the series of adjacent frames, and covers all the
4497                 // frames in this series.
4498                 current_gap_size += sizeofW(StgUpdateFrame);
4499                 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4500                 ((struct stack_gap *)frame)->next_gap = gap;
4501
4502                 frame += sizeofW(StgUpdateFrame);
4503                 continue;
4504             }
4505
4506             // single update frame, or the topmost update frame in a series
4507             else {
4508                 prev_was_update_frame = rtsTrue;
4509                 updatee = upd->updatee;
4510                 frame += sizeofW(StgUpdateFrame);
4511                 continue;
4512             }
4513         }
4514
4515         default:
4516             prev_was_update_frame = rtsFalse;
4517
4518             // we're not in a gap... check whether this is the end of a gap
4519             // (an update frame can't be the end of a gap).
4520             if (current_gap_size != 0) {
4521                 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4522             }
4523             current_gap_size = 0;
4524
4525             frame += stack_frame_sizeW((StgClosure *)frame);
4526             continue;
4527         }
4528     }
4529
4530     if (current_gap_size != 0) {
4531         gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4532     }
4533
4534     // Now we have a stack with gaps in it, and we have to walk down
4535     // shoving the stack up to fill in the gaps.  A diagram might
4536     // help:
4537     //
4538     //    +| ********* |
4539     //     | ********* | <- sp
4540     //     |           |
4541     //     |           | <- gap_start
4542     //     | ......... |                |
4543     //     | stack_gap | <- gap         | chunk_size
4544     //     | ......... |                |
4545     //     | ......... | <- gap_end     v
4546     //     | ********* |
4547     //     | ********* |
4548     //     | ********* |
4549     //    -| ********* |
4550     //
4551     // 'sp'  points the the current top-of-stack
4552     // 'gap' points to the stack_gap structure inside the gap
4553     // *****   indicates real stack data
4554     // .....   indicates gap
4555     // <empty> indicates unused
4556     //
4557     {
4558         void *sp;
4559         void *gap_start, *next_gap_start, *gap_end;
4560         nat chunk_size;
4561
4562         next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4563         sp = next_gap_start;
4564
4565         while ((StgPtr)gap > tso->sp) {
4566
4567             // we're working in *bytes* now...
4568             gap_start = next_gap_start;
4569             gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4570
4571             gap = gap->next_gap;
4572             next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4573
4574             chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4575             sp -= chunk_size;
4576             memmove(sp, next_gap_start, chunk_size);
4577         }
4578
4579         tso->sp = (StgPtr)sp;
4580     }
4581 }
4582
4583 /* -----------------------------------------------------------------------------
4584  * Pausing a thread
4585  *
4586  * We have to prepare for GC - this means doing lazy black holing
4587  * here.  We also take the opportunity to do stack squeezing if it's
4588  * turned on.
4589  * -------------------------------------------------------------------------- */
4590 void
4591 threadPaused(Capability *cap, StgTSO *tso)
4592 {
4593     StgClosure *frame;
4594     StgRetInfoTable *info;
4595     StgClosure *bh;
4596     StgPtr stack_end;
4597     nat words_to_squeeze = 0;
4598     nat weight           = 0;
4599     nat weight_pending   = 0;
4600     rtsBool prev_was_update_frame;
4601
4602     stack_end = &tso->stack[tso->stack_size];
4603
4604     frame = (StgClosure *)tso->sp;
4605
4606     while (1) {
4607         // If we've already marked this frame, then stop here.
4608         if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) {
4609             goto end;
4610         }
4611
4612         info = get_ret_itbl(frame);
4613
4614         switch (info->i.type) {
4615
4616         case UPDATE_FRAME:
4617
4618             SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info);
4619
4620             bh = ((StgUpdateFrame *)frame)->updatee;
4621
4622             if (closure_IND(bh) || bh->header.info == &stg_BLACKHOLE_info) {
4623                 IF_DEBUG(squeeze, debugBelch("suspending duplicate work: %ld words of stack\n", (StgPtr)frame - tso->sp));
4624
4625                 // If this closure is already an indirection, then
4626                 // suspend the computation up to this point:
4627                 suspendComputation(cap,tso,(StgPtr)frame);
4628
4629                 // Now drop the update frame, and arrange to return
4630                 // the value to the frame underneath:
4631                 tso->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2;
4632                 tso->sp[1] = (StgWord)bh;
4633                 tso->sp[0] = (W_)&stg_enter_info;
4634
4635                 // And continue with threadPaused; there might be
4636                 // yet more computation to suspend.
4637                 threadPaused(cap,tso);
4638                 return;
4639             }
4640
4641             if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
4642 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4643                 debugBelch("Unexpected lazy BHing required at 0x%04lx\n",(long)bh);
4644 #endif
4645                 // zero out the slop so that the sanity checker can tell
4646                 // where the next closure is.
4647                 DEBUG_FILL_SLOP(bh);
4648 #ifdef PROFILING
4649                 // @LDV profiling
4650                 // We pretend that bh is now dead.
4651                 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4652 #endif
4653                 SET_INFO(bh,&stg_BLACKHOLE_info);
4654
4655                 // We pretend that bh has just been created.
4656                 LDV_RECORD_CREATE(bh);
4657             }
4658
4659             frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4660             if (prev_was_update_frame) {
4661                 words_to_squeeze += sizeofW(StgUpdateFrame);
4662                 weight += weight_pending;
4663                 weight_pending = 0;
4664             }
4665             prev_was_update_frame = rtsTrue;
4666             break;
4667
4668         case STOP_FRAME:
4669             goto end;
4670
4671             // normal stack frames; do nothing except advance the pointer
4672         default:
4673         {
4674             nat frame_size = stack_frame_sizeW(frame);
4675             weight_pending += frame_size;
4676             frame = (StgClosure *)((StgPtr)frame + frame_size);
4677             prev_was_update_frame = rtsFalse;
4678         }
4679         }
4680     }
4681
4682 end:
4683     IF_DEBUG(squeeze,
4684              debugBelch("words_to_squeeze: %d, weight: %d, squeeze: %s\n",
4685                         words_to_squeeze, weight,
4686                         weight < words_to_squeeze ? "YES" : "NO"));
4687
4688     // Should we squeeze or not?  Arbitrary heuristic: we squeeze if
4689     // the number of words we have to shift down is less than the
4690     // number of stack words we squeeze away by doing so.
4691     if (1 /*RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue &&
4692             weight < words_to_squeeze*/) {
4693         stackSqueeze(tso, (StgPtr)frame);
4694     }
4695 }
4696
4697 /* -----------------------------------------------------------------------------
4698  * Debugging
4699  * -------------------------------------------------------------------------- */
4700
4701 #if DEBUG
4702 void
4703 printMutableList(generation *gen)
4704 {
4705     bdescr *bd;
4706     StgPtr p;
4707
4708     debugBelch("@@ Mutable list %p: ", gen->mut_list);
4709
4710     for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
4711         for (p = bd->start; p < bd->free; p++) {
4712             debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
4713         }
4714     }
4715     debugBelch("\n");
4716 }
4717 #endif /* DEBUG */