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