ghc/rts/GC.c

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