ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.162 2003/10/24 11:45:40 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_EVACUATED;
 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 AP_STACK:
2135       case THUNK:
2136       case THUNK_1_0:
2137       case THUNK_0_1:
2138       case THUNK_2_0:
2139       case THUNK_1_1:
2140       case THUNK_0_2:
2141       case THUNK_STATIC:
2142       case CAF_BLACKHOLE:
2143       case SE_CAF_BLACKHOLE:
2144       case SE_BLACKHOLE:
2145       case BLACKHOLE:
2146       case BLACKHOLE_BQ:
2147 #if defined(PAR)
2148       case RBH:
2149       case BLOCKED_FETCH:
2150 # ifdef DIST
2151       case REMOTE_REF:
2152 # endif
2153       case FETCH_ME:
2154       case FETCH_ME_BQ:
2155 #endif
2156           // not evaluated yet
2157           break;
2158
2159       default:
2160         barf("eval_thunk_selector: strange selectee %d",
2161              (int)(info->type));
2162     }
2163
2164 bale_out:
2165     // We didn't manage to evaluate this thunk; restore the old info pointer
2166     SET_INFO(p, info_ptr);
2167     return NULL;
2168 }
2169
2170 /* -----------------------------------------------------------------------------
2171    move_TSO is called to update the TSO structure after it has been
2172    moved from one place to another.
2173    -------------------------------------------------------------------------- */
2174
2175 void
2176 move_TSO (StgTSO *src, StgTSO *dest)
2177 {
2178     ptrdiff_t diff;
2179
2180     // relocate the stack pointer...
2181     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2182     dest->sp = (StgPtr)dest->sp + diff;
2183 }
2184
2185 /* Similar to scavenge_large_bitmap(), but we don't write back the
2186  * pointers we get back from evacuate().
2187  */
2188 static void
2189 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2190 {
2191     nat i, b, size;
2192     StgWord bitmap;
2193     StgClosure **p;
2194
2195     b = 0;
2196     bitmap = large_srt->l.bitmap[b];
2197     size   = (nat)large_srt->l.size;
2198     p      = (StgClosure **)large_srt->srt;
2199     for (i = 0; i < size; ) {
2200         if ((bitmap & 1) != 0) {
2201             evacuate(*p);
2202         }
2203         i++;
2204         p++;
2205         if (i % BITS_IN(W_) == 0) {
2206             b++;
2207             bitmap = large_srt->l.bitmap[b];
2208         } else {
2209             bitmap = bitmap >> 1;
2210         }
2211     }
2212 }
2213
2214 /* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
2215  * srt field in the info table.  That's ok, because we'll
2216  * never dereference it.
2217  */
2218 static inline void
2219 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2220 {
2221   nat bitmap;
2222   StgClosure **p;
2223
2224   bitmap = srt_bitmap;
2225   p = srt;
2226
2227   if (bitmap == (StgHalfWord)(-1)) {
2228       scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2229       return;
2230   }
2231
2232   while (bitmap != 0) {
2233       if ((bitmap & 1) != 0) {
2234 #ifdef ENABLE_WIN32_DLL_SUPPORT
2235           // Special-case to handle references to closures hiding out in DLLs, since
2236           // double indirections required to get at those. The code generator knows
2237           // which is which when generating the SRT, so it stores the (indirect)
2238           // reference to the DLL closure in the table by first adding one to it.
2239           // We check for this here, and undo the addition before evacuating it.
2240           //
2241           // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2242           // closure that's fixed at link-time, and no extra magic is required.
2243           if ( (unsigned long)(*srt) & 0x1 ) {
2244               evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2245           } else {
2246               evacuate(*p);
2247           }
2248 #else
2249           evacuate(*p);
2250 #endif
2251       }
2252       p++;
2253       bitmap = bitmap >> 1;
2254   }
2255 }
2256
2257
2258 static inline void
2259 scavenge_thunk_srt(const StgInfoTable *info)
2260 {
2261     StgThunkInfoTable *thunk_info;
2262
2263     thunk_info = itbl_to_thunk_itbl(info);
2264     scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_bitmap);
2265 }
2266
2267 static inline void
2268 scavenge_fun_srt(const StgInfoTable *info)
2269 {
2270     StgFunInfoTable *fun_info;
2271
2272     fun_info = itbl_to_fun_itbl(info);
2273     scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_bitmap);
2274 }
2275
2276 static inline void
2277 scavenge_ret_srt(const StgInfoTable *info)
2278 {
2279     StgRetInfoTable *ret_info;
2280
2281     ret_info = itbl_to_ret_itbl(info);
2282     scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_bitmap);
2283 }
2284
2285 /* -----------------------------------------------------------------------------
2286    Scavenge a TSO.
2287    -------------------------------------------------------------------------- */
2288
2289 static void
2290 scavengeTSO (StgTSO *tso)
2291 {
2292     // chase the link field for any TSOs on the same queue
2293     (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2294     if (   tso->why_blocked == BlockedOnMVar
2295         || tso->why_blocked == BlockedOnBlackHole
2296         || tso->why_blocked == BlockedOnException
2297 #if defined(PAR)
2298         || tso->why_blocked == BlockedOnGA
2299         || tso->why_blocked == BlockedOnGA_NoSend
2300 #endif
2301         ) {
2302         tso->block_info.closure = evacuate(tso->block_info.closure);
2303     }
2304     if ( tso->blocked_exceptions != NULL ) {
2305         tso->blocked_exceptions =
2306             (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2307     }
2308
2309     // scavenge this thread's stack
2310     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2311 }
2312
2313 /* -----------------------------------------------------------------------------
2314    Blocks of function args occur on the stack (at the top) and
2315    in PAPs.
2316    -------------------------------------------------------------------------- */
2317
2318 static inline StgPtr
2319 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2320 {
2321     StgPtr p;
2322     StgWord bitmap;
2323     nat size;
2324
2325     p = (StgPtr)args;
2326     switch (fun_info->fun_type) {
2327     case ARG_GEN:
2328         bitmap = BITMAP_BITS(fun_info->bitmap);
2329         size = BITMAP_SIZE(fun_info->bitmap);
2330         goto small_bitmap;
2331     case ARG_GEN_BIG:
2332         size = ((StgLargeBitmap *)fun_info->bitmap)->size;
2333         scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
2334         p += size;
2335         break;
2336     default:
2337         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
2338         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
2339     small_bitmap:
2340         while (size > 0) {
2341             if ((bitmap & 1) == 0) {
2342                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2343             }
2344             p++;
2345             bitmap = bitmap >> 1;
2346             size--;
2347         }
2348         break;
2349     }
2350     return p;
2351 }
2352
2353 static inline StgPtr
2354 scavenge_PAP (StgPAP *pap)
2355 {
2356     StgPtr p;
2357     StgWord bitmap, size;
2358     StgFunInfoTable *fun_info;
2359
2360     pap->fun = evacuate(pap->fun);
2361     fun_info = get_fun_itbl(pap->fun);
2362     ASSERT(fun_info->i.type != PAP);
2363
2364     p = (StgPtr)pap->payload;
2365     size = pap->n_args;
2366
2367     switch (fun_info->fun_type) {
2368     case ARG_GEN:
2369         bitmap = BITMAP_BITS(fun_info->bitmap);
2370         goto small_bitmap;
2371     case ARG_GEN_BIG:
2372         scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
2373         p += size;
2374         break;
2375     case ARG_BCO:
2376         scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
2377         p += size;
2378         break;
2379     default:
2380         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
2381     small_bitmap:
2382         size = pap->n_args;
2383         while (size > 0) {
2384             if ((bitmap & 1) == 0) {
2385                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2386             }
2387             p++;
2388             bitmap = bitmap >> 1;
2389             size--;
2390         }
2391         break;
2392     }
2393     return p;
2394 }
2395
2396 /* -----------------------------------------------------------------------------
2397    Scavenge a given step until there are no more objects in this step
2398    to scavenge.
2399
2400    evac_gen is set by the caller to be either zero (for a step in a
2401    generation < N) or G where G is the generation of the step being
2402    scavenged.
2403
2404    We sometimes temporarily change evac_gen back to zero if we're
2405    scavenging a mutable object where early promotion isn't such a good
2406    idea.
2407    -------------------------------------------------------------------------- */
2408
2409 static void
2410 scavenge(step *stp)
2411 {
2412   StgPtr p, q;
2413   StgInfoTable *info;
2414   bdescr *bd;
2415   nat saved_evac_gen = evac_gen;
2416
2417   p = stp->scan;
2418   bd = stp->scan_bd;
2419
2420   failed_to_evac = rtsFalse;
2421
2422   /* scavenge phase - standard breadth-first scavenging of the
2423    * evacuated objects
2424    */
2425
2426   while (bd != stp->hp_bd || p < stp->hp) {
2427
2428     // If we're at the end of this block, move on to the next block
2429     if (bd != stp->hp_bd && p == bd->free) {
2430       bd = bd->link;
2431       p = bd->start;
2432       continue;
2433     }
2434
2435     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2436     info = get_itbl((StgClosure *)p);
2437
2438     ASSERT(thunk_selector_depth == 0);
2439
2440     q = p;
2441     switch (info->type) {
2442
2443     case MVAR:
2444         /* treat MVars specially, because we don't want to evacuate the
2445          * mut_link field in the middle of the closure.
2446          */
2447     {
2448         StgMVar *mvar = ((StgMVar *)p);
2449         evac_gen = 0;
2450         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2451         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2452         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2453         evac_gen = saved_evac_gen;
2454         recordMutable((StgMutClosure *)mvar);
2455         failed_to_evac = rtsFalse; // mutable.
2456         p += sizeofW(StgMVar);
2457         break;
2458     }
2459
2460     case FUN_2_0:
2461         scavenge_fun_srt(info);
2462         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2463         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2464         p += sizeofW(StgHeader) + 2;
2465         break;
2466
2467     case THUNK_2_0:
2468         scavenge_thunk_srt(info);
2469     case CONSTR_2_0:
2470         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2471         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2472         p += sizeofW(StgHeader) + 2;
2473         break;
2474
2475     case THUNK_1_0:
2476         scavenge_thunk_srt(info);
2477         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2478         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2479         break;
2480
2481     case FUN_1_0:
2482         scavenge_fun_srt(info);
2483     case CONSTR_1_0:
2484         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2485         p += sizeofW(StgHeader) + 1;
2486         break;
2487
2488     case THUNK_0_1:
2489         scavenge_thunk_srt(info);
2490         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2491         break;
2492
2493     case FUN_0_1:
2494         scavenge_fun_srt(info);
2495     case CONSTR_0_1:
2496         p += sizeofW(StgHeader) + 1;
2497         break;
2498
2499     case THUNK_0_2:
2500         scavenge_thunk_srt(info);
2501         p += sizeofW(StgHeader) + 2;
2502         break;
2503
2504     case FUN_0_2:
2505         scavenge_fun_srt(info);
2506     case CONSTR_0_2:
2507         p += sizeofW(StgHeader) + 2;
2508         break;
2509
2510     case THUNK_1_1:
2511         scavenge_thunk_srt(info);
2512         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2513         p += sizeofW(StgHeader) + 2;
2514         break;
2515
2516     case FUN_1_1:
2517         scavenge_fun_srt(info);
2518     case CONSTR_1_1:
2519         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2520         p += sizeofW(StgHeader) + 2;
2521         break;
2522
2523     case FUN:
2524         scavenge_fun_srt(info);
2525         goto gen_obj;
2526
2527     case THUNK:
2528         scavenge_thunk_srt(info);
2529         // fall through
2530
2531     gen_obj:
2532     case CONSTR:
2533     case WEAK:
2534     case FOREIGN:
2535     case STABLE_NAME:
2536     {
2537         StgPtr end;
2538
2539         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2540         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2541             (StgClosure *)*p = evacuate((StgClosure *)*p);
2542         }
2543         p += info->layout.payload.nptrs;
2544         break;
2545     }
2546
2547     case BCO: {
2548         StgBCO *bco = (StgBCO *)p;
2549         (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2550         (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2551         (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2552         (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2553         p += bco_sizeW(bco);
2554         break;
2555     }
2556
2557     case IND_PERM:
2558       if (stp->gen->no != 0) {
2559 #ifdef PROFILING
2560         // @LDV profiling
2561         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2562         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2563         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2564 #endif
2565         //
2566         // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
2567         //
2568         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2569 #ifdef PROFILING
2570         // @LDV profiling
2571         // We pretend that p has just been created.
2572         LDV_recordCreate((StgClosure *)p);
2573 #endif
2574       }
2575         // fall through
2576     case IND_OLDGEN_PERM:
2577         ((StgIndOldGen *)p)->indirectee =
2578             evacuate(((StgIndOldGen *)p)->indirectee);
2579         if (failed_to_evac) {
2580             failed_to_evac = rtsFalse;
2581             recordOldToNewPtrs((StgMutClosure *)p);
2582         }
2583         p += sizeofW(StgIndOldGen);
2584         break;
2585
2586     case MUT_VAR:
2587         evac_gen = 0;
2588         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2589         evac_gen = saved_evac_gen;
2590         recordMutable((StgMutClosure *)p);
2591         failed_to_evac = rtsFalse; // mutable anyhow
2592         p += sizeofW(StgMutVar);
2593         break;
2594
2595     case MUT_CONS:
2596         // ignore these
2597         failed_to_evac = rtsFalse; // mutable anyhow
2598         p += sizeofW(StgMutVar);
2599         break;
2600
2601     case CAF_BLACKHOLE:
2602     case SE_CAF_BLACKHOLE:
2603     case SE_BLACKHOLE:
2604     case BLACKHOLE:
2605         p += BLACKHOLE_sizeW();
2606         break;
2607
2608     case BLACKHOLE_BQ:
2609     {
2610         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2611         (StgClosure *)bh->blocking_queue =
2612             evacuate((StgClosure *)bh->blocking_queue);
2613         recordMutable((StgMutClosure *)bh);
2614         failed_to_evac = rtsFalse;
2615         p += BLACKHOLE_sizeW();
2616         break;
2617     }
2618
2619     case THUNK_SELECTOR:
2620     {
2621         StgSelector *s = (StgSelector *)p;
2622         s->selectee = evacuate(s->selectee);
2623         p += THUNK_SELECTOR_sizeW();
2624         break;
2625     }
2626
2627     // A chunk of stack saved in a heap object
2628     case AP_STACK:
2629     {
2630         StgAP_STACK *ap = (StgAP_STACK *)p;
2631
2632         ap->fun = evacuate(ap->fun);
2633         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2634         p = (StgPtr)ap->payload + ap->size;
2635         break;
2636     }
2637
2638     case PAP:
2639     case AP:
2640         p = scavenge_PAP((StgPAP *)p);
2641         break;
2642
2643     case ARR_WORDS:
2644         // nothing to follow
2645         p += arr_words_sizeW((StgArrWords *)p);
2646         break;
2647
2648     case MUT_ARR_PTRS:
2649         // follow everything
2650     {
2651         StgPtr next;
2652
2653         evac_gen = 0;           // repeatedly mutable
2654         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2655         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2656             (StgClosure *)*p = evacuate((StgClosure *)*p);
2657         }
2658         evac_gen = saved_evac_gen;
2659         recordMutable((StgMutClosure *)q);
2660         failed_to_evac = rtsFalse; // mutable anyhow.
2661         break;
2662     }
2663
2664     case MUT_ARR_PTRS_FROZEN:
2665         // follow everything
2666     {
2667         StgPtr next;
2668
2669         // Set the mut_link field to NULL, so that we will put this
2670         // array back on the mutable list if it is subsequently thawed
2671         // by unsafeThaw#.
2672         ((StgMutArrPtrs*)p)->mut_link = NULL;
2673
2674         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2675         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2676             (StgClosure *)*p = evacuate((StgClosure *)*p);
2677         }
2678         // it's tempting to recordMutable() if failed_to_evac is
2679         // false, but that breaks some assumptions (eg. every
2680         // closure on the mutable list is supposed to have the MUT
2681         // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2682         break;
2683     }
2684
2685     case TSO:
2686     {
2687         StgTSO *tso = (StgTSO *)p;
2688         evac_gen = 0;
2689         scavengeTSO(tso);
2690         evac_gen = saved_evac_gen;
2691         recordMutable((StgMutClosure *)tso);
2692         failed_to_evac = rtsFalse; // mutable anyhow.
2693         p += tso_sizeW(tso);
2694         break;
2695     }
2696
2697 #if defined(PAR)
2698     case RBH: // cf. BLACKHOLE_BQ
2699     {
2700 #if 0
2701         nat size, ptrs, nonptrs, vhs;
2702         char str[80];
2703         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2704 #endif
2705         StgRBH *rbh = (StgRBH *)p;
2706         (StgClosure *)rbh->blocking_queue =
2707             evacuate((StgClosure *)rbh->blocking_queue);
2708         recordMutable((StgMutClosure *)to);
2709         failed_to_evac = rtsFalse;  // mutable anyhow.
2710         IF_DEBUG(gc,
2711                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2712                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2713         // ToDo: use size of reverted closure here!
2714         p += BLACKHOLE_sizeW();
2715         break;
2716     }
2717
2718     case BLOCKED_FETCH:
2719     {
2720         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2721         // follow the pointer to the node which is being demanded
2722         (StgClosure *)bf->node =
2723             evacuate((StgClosure *)bf->node);
2724         // follow the link to the rest of the blocking queue
2725         (StgClosure *)bf->link =
2726             evacuate((StgClosure *)bf->link);
2727         if (failed_to_evac) {
2728             failed_to_evac = rtsFalse;
2729             recordMutable((StgMutClosure *)bf);
2730         }
2731         IF_DEBUG(gc,
2732                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2733                        bf, info_type((StgClosure *)bf),
2734                        bf->node, info_type(bf->node)));
2735         p += sizeofW(StgBlockedFetch);
2736         break;
2737     }
2738
2739 #ifdef DIST
2740     case REMOTE_REF:
2741 #endif
2742     case FETCH_ME:
2743         p += sizeofW(StgFetchMe);
2744         break; // nothing to do in this case
2745
2746     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2747     {
2748         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2749         (StgClosure *)fmbq->blocking_queue =
2750             evacuate((StgClosure *)fmbq->blocking_queue);
2751         if (failed_to_evac) {
2752             failed_to_evac = rtsFalse;
2753             recordMutable((StgMutClosure *)fmbq);
2754         }
2755         IF_DEBUG(gc,
2756                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2757                        p, info_type((StgClosure *)p)));
2758         p += sizeofW(StgFetchMeBlockingQueue);
2759         break;
2760     }
2761 #endif
2762
2763     default:
2764         barf("scavenge: unimplemented/strange closure type %d @ %p",
2765              info->type, p);
2766     }
2767
2768     /* If we didn't manage to promote all the objects pointed to by
2769      * the current object, then we have to designate this object as
2770      * mutable (because it contains old-to-new generation pointers).
2771      */
2772     if (failed_to_evac) {
2773         failed_to_evac = rtsFalse;
2774         mkMutCons((StgClosure *)q, &generations[evac_gen]);
2775     }
2776   }
2777
2778   stp->scan_bd = bd;
2779   stp->scan = p;
2780 }
2781
2782 /* -----------------------------------------------------------------------------
2783    Scavenge everything on the mark stack.
2784
2785    This is slightly different from scavenge():
2786       - we don't walk linearly through the objects, so the scavenger
2787         doesn't need to advance the pointer on to the next object.
2788    -------------------------------------------------------------------------- */
2789
2790 static void
2791 scavenge_mark_stack(void)
2792 {
2793     StgPtr p, q;
2794     StgInfoTable *info;
2795     nat saved_evac_gen;
2796
2797     evac_gen = oldest_gen->no;
2798     saved_evac_gen = evac_gen;
2799
2800 linear_scan:
2801     while (!mark_stack_empty()) {
2802         p = pop_mark_stack();
2803
2804         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2805         info = get_itbl((StgClosure *)p);
2806
2807         q = p;
2808         switch (info->type) {
2809
2810         case MVAR:
2811             /* treat MVars specially, because we don't want to evacuate the
2812              * mut_link field in the middle of the closure.
2813              */
2814         {
2815             StgMVar *mvar = ((StgMVar *)p);
2816             evac_gen = 0;
2817             (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2818             (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2819             (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2820             evac_gen = saved_evac_gen;
2821             failed_to_evac = rtsFalse; // mutable.
2822             break;
2823         }
2824
2825         case FUN_2_0:
2826             scavenge_fun_srt(info);
2827             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2828             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2829             break;
2830
2831         case THUNK_2_0:
2832             scavenge_thunk_srt(info);
2833         case CONSTR_2_0:
2834             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2835             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2836             break;
2837
2838         case FUN_1_0:
2839         case FUN_1_1:
2840             scavenge_fun_srt(info);
2841             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2842             break;
2843
2844         case THUNK_1_0:
2845         case THUNK_1_1:
2846             scavenge_thunk_srt(info);
2847         case CONSTR_1_0:
2848         case CONSTR_1_1:
2849             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2850             break;
2851
2852         case FUN_0_1:
2853         case FUN_0_2:
2854             scavenge_fun_srt(info);
2855             break;
2856
2857         case THUNK_0_1:
2858         case THUNK_0_2:
2859             scavenge_thunk_srt(info);
2860             break;
2861
2862         case CONSTR_0_1:
2863         case CONSTR_0_2:
2864             break;
2865
2866         case FUN:
2867             scavenge_fun_srt(info);
2868             goto gen_obj;
2869
2870         case THUNK:
2871             scavenge_thunk_srt(info);
2872             // fall through
2873
2874         gen_obj:
2875         case CONSTR:
2876         case WEAK:
2877         case FOREIGN:
2878         case STABLE_NAME:
2879         {
2880             StgPtr end;
2881
2882             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2883             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2884                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2885             }
2886             break;
2887         }
2888
2889         case BCO: {
2890             StgBCO *bco = (StgBCO *)p;
2891             (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2892             (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2893             (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2894             (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2895             break;
2896         }
2897
2898         case IND_PERM:
2899             // don't need to do anything here: the only possible case
2900             // is that we're in a 1-space compacting collector, with
2901             // no "old" generation.
2902             break;
2903
2904         case IND_OLDGEN:
2905         case IND_OLDGEN_PERM:
2906             ((StgIndOldGen *)p)->indirectee =
2907                 evacuate(((StgIndOldGen *)p)->indirectee);
2908             if (failed_to_evac) {
2909                 recordOldToNewPtrs((StgMutClosure *)p);
2910             }
2911             failed_to_evac = rtsFalse;
2912             break;
2913
2914         case MUT_VAR:
2915             evac_gen = 0;
2916             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2917             evac_gen = saved_evac_gen;
2918             failed_to_evac = rtsFalse;
2919             break;
2920
2921         case MUT_CONS:
2922             // ignore these
2923             failed_to_evac = rtsFalse;
2924             break;
2925
2926         case CAF_BLACKHOLE:
2927         case SE_CAF_BLACKHOLE:
2928         case SE_BLACKHOLE:
2929         case BLACKHOLE:
2930         case ARR_WORDS:
2931             break;
2932
2933         case BLACKHOLE_BQ:
2934         {
2935             StgBlockingQueue *bh = (StgBlockingQueue *)p;
2936             (StgClosure *)bh->blocking_queue =
2937                 evacuate((StgClosure *)bh->blocking_queue);
2938             failed_to_evac = rtsFalse;
2939             break;
2940         }
2941
2942         case THUNK_SELECTOR:
2943         {
2944             StgSelector *s = (StgSelector *)p;
2945             s->selectee = evacuate(s->selectee);
2946             break;
2947         }
2948
2949         // A chunk of stack saved in a heap object
2950         case AP_STACK:
2951         {
2952             StgAP_STACK *ap = (StgAP_STACK *)p;
2953
2954             ap->fun = evacuate(ap->fun);
2955             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2956             break;
2957         }
2958
2959         case PAP:
2960         case AP:
2961             scavenge_PAP((StgPAP *)p);
2962             break;
2963
2964         case MUT_ARR_PTRS:
2965             // follow everything
2966         {
2967             StgPtr next;
2968
2969             evac_gen = 0;               // repeatedly mutable
2970             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2971             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2972                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2973             }
2974             evac_gen = saved_evac_gen;
2975             failed_to_evac = rtsFalse; // mutable anyhow.
2976             break;
2977         }
2978
2979         case MUT_ARR_PTRS_FROZEN:
2980             // follow everything
2981         {
2982             StgPtr next;
2983
2984             // Set the mut_link field to NULL, so that we will put this
2985             // array on the mutable list if it is subsequently thawed
2986             // by unsafeThaw#.
2987             ((StgMutArrPtrs*)p)->mut_link = NULL;
2988
2989             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2990             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2991                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2992             }
2993             break;
2994         }
2995
2996         case TSO:
2997         {
2998             StgTSO *tso = (StgTSO *)p;
2999             evac_gen = 0;
3000             scavengeTSO(tso);
3001             evac_gen = saved_evac_gen;
3002             failed_to_evac = rtsFalse;
3003             break;
3004         }
3005
3006 #if defined(PAR)
3007         case RBH: // cf. BLACKHOLE_BQ
3008         {
3009 #if 0
3010             nat size, ptrs, nonptrs, vhs;
3011             char str[80];
3012             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3013 #endif
3014             StgRBH *rbh = (StgRBH *)p;
3015             (StgClosure *)rbh->blocking_queue =
3016                 evacuate((StgClosure *)rbh->blocking_queue);
3017             recordMutable((StgMutClosure *)rbh);
3018             failed_to_evac = rtsFalse;  // mutable anyhow.
3019             IF_DEBUG(gc,
3020                      belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3021                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
3022             break;
3023         }
3024
3025         case BLOCKED_FETCH:
3026         {
3027             StgBlockedFetch *bf = (StgBlockedFetch *)p;
3028             // follow the pointer to the node which is being demanded
3029             (StgClosure *)bf->node =
3030                 evacuate((StgClosure *)bf->node);
3031             // follow the link to the rest of the blocking queue
3032             (StgClosure *)bf->link =
3033                 evacuate((StgClosure *)bf->link);
3034             if (failed_to_evac) {
3035                 failed_to_evac = rtsFalse;
3036                 recordMutable((StgMutClosure *)bf);
3037             }
3038             IF_DEBUG(gc,
3039                      belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3040                            bf, info_type((StgClosure *)bf),
3041                            bf->node, info_type(bf->node)));
3042             break;
3043         }
3044
3045 #ifdef DIST
3046         case REMOTE_REF:
3047 #endif
3048         case FETCH_ME:
3049             break; // nothing to do in this case
3050
3051         case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3052         {
3053             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3054             (StgClosure *)fmbq->blocking_queue =
3055                 evacuate((StgClosure *)fmbq->blocking_queue);
3056             if (failed_to_evac) {
3057                 failed_to_evac = rtsFalse;
3058                 recordMutable((StgMutClosure *)fmbq);
3059             }
3060             IF_DEBUG(gc,
3061                      belch("@@ scavenge: %p (%s) exciting, isn't it",
3062                            p, info_type((StgClosure *)p)));
3063             break;
3064         }
3065 #endif // PAR
3066
3067         default:
3068             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3069                  info->type, p);
3070         }
3071
3072         if (failed_to_evac) {
3073             failed_to_evac = rtsFalse;
3074             mkMutCons((StgClosure *)q, &generations[evac_gen]);
3075         }
3076
3077         // mark the next bit to indicate "scavenged"
3078         mark(q+1, Bdescr(q));
3079
3080     } // while (!mark_stack_empty())
3081
3082     // start a new linear scan if the mark stack overflowed at some point
3083     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3084         IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
3085         mark_stack_overflowed = rtsFalse;
3086         oldgen_scan_bd = oldest_gen->steps[0].blocks;
3087         oldgen_scan = oldgen_scan_bd->start;
3088     }
3089
3090     if (oldgen_scan_bd) {
3091         // push a new thing on the mark stack
3092     loop:
3093         // find a closure that is marked but not scavenged, and start
3094         // from there.
3095         while (oldgen_scan < oldgen_scan_bd->free
3096                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3097             oldgen_scan++;
3098         }
3099
3100         if (oldgen_scan < oldgen_scan_bd->free) {
3101
3102             // already scavenged?
3103             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3104                 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3105                 goto loop;
3106             }
3107             push_mark_stack(oldgen_scan);
3108             // ToDo: bump the linear scan by the actual size of the object
3109             oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3110             goto linear_scan;
3111         }
3112
3113         oldgen_scan_bd = oldgen_scan_bd->link;
3114         if (oldgen_scan_bd != NULL) {
3115             oldgen_scan = oldgen_scan_bd->start;
3116             goto loop;
3117         }
3118     }
3119 }
3120
3121 /* -----------------------------------------------------------------------------
3122    Scavenge one object.
3123
3124    This is used for objects that are temporarily marked as mutable
3125    because they contain old-to-new generation pointers.  Only certain
3126    objects can have this property.
3127    -------------------------------------------------------------------------- */
3128
3129 static rtsBool
3130 scavenge_one(StgPtr p)
3131 {
3132     const StgInfoTable *info;
3133     nat saved_evac_gen = evac_gen;
3134     rtsBool no_luck;
3135
3136     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3137     info = get_itbl((StgClosure *)p);
3138
3139     switch (info->type) {
3140
3141     case FUN:
3142     case FUN_1_0:                       // hardly worth specialising these guys
3143     case FUN_0_1:
3144     case FUN_1_1:
3145     case FUN_0_2:
3146     case FUN_2_0:
3147     case THUNK:
3148     case THUNK_1_0:
3149     case THUNK_0_1:
3150     case THUNK_1_1:
3151     case THUNK_0_2:
3152     case THUNK_2_0:
3153     case CONSTR:
3154     case CONSTR_1_0:
3155     case CONSTR_0_1:
3156     case CONSTR_1_1:
3157     case CONSTR_0_2:
3158     case CONSTR_2_0:
3159     case WEAK:
3160     case FOREIGN:
3161     case IND_PERM:
3162     case IND_OLDGEN_PERM:
3163     {
3164         StgPtr q, end;
3165
3166         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3167         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3168             (StgClosure *)*q = evacuate((StgClosure *)*q);
3169         }
3170         break;
3171     }
3172
3173     case CAF_BLACKHOLE:
3174     case SE_CAF_BLACKHOLE:
3175     case SE_BLACKHOLE:
3176     case BLACKHOLE:
3177         break;
3178
3179     case THUNK_SELECTOR:
3180     {
3181         StgSelector *s = (StgSelector *)p;
3182         s->selectee = evacuate(s->selectee);
3183         break;
3184     }
3185
3186     case ARR_WORDS:
3187         // nothing to follow
3188         break;
3189
3190     case MUT_ARR_PTRS:
3191     {
3192         // follow everything
3193         StgPtr next;
3194
3195         evac_gen = 0;           // repeatedly mutable
3196         recordMutable((StgMutClosure *)p);
3197         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3198         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3199             (StgClosure *)*p = evacuate((StgClosure *)*p);
3200         }
3201         evac_gen = saved_evac_gen;
3202         failed_to_evac = rtsFalse;
3203         break;
3204     }
3205
3206     case MUT_ARR_PTRS_FROZEN:
3207     {
3208         // follow everything
3209         StgPtr next;
3210
3211         // Set the mut_link field to NULL, so that we will put this
3212         // array on the mutable list if it is subsequently thawed
3213         // by unsafeThaw#.
3214         ((StgMutArrPtrs*)p)->mut_link = NULL;
3215
3216         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3217         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3218             (StgClosure *)*p = evacuate((StgClosure *)*p);
3219         }
3220         break;
3221     }
3222
3223     case TSO:
3224     {
3225         StgTSO *tso = (StgTSO *)p;
3226
3227         evac_gen = 0;           // repeatedly mutable
3228         scavengeTSO(tso);
3229         recordMutable((StgMutClosure *)tso);
3230         evac_gen = saved_evac_gen;
3231         failed_to_evac = rtsFalse;
3232         break;
3233     }
3234
3235     case AP_STACK:
3236     {
3237         StgAP_STACK *ap = (StgAP_STACK *)p;
3238
3239         ap->fun = evacuate(ap->fun);
3240         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3241         p = (StgPtr)ap->payload + ap->size;
3242         break;
3243     }
3244
3245     case PAP:
3246     case AP:
3247         p = scavenge_PAP((StgPAP *)p);
3248         break;
3249
3250     case IND_OLDGEN:
3251         // This might happen if for instance a MUT_CONS was pointing to a
3252         // THUNK which has since been updated.  The IND_OLDGEN will
3253         // be on the mutable list anyway, so we don't need to do anything
3254         // here.
3255         break;
3256
3257     default:
3258         barf("scavenge_one: strange object %d", (int)(info->type));
3259     }
3260
3261     no_luck = failed_to_evac;
3262     failed_to_evac = rtsFalse;
3263     return (no_luck);
3264 }
3265
3266 /* -----------------------------------------------------------------------------
3267    Scavenging mutable lists.
3268
3269    We treat the mutable list of each generation > N (i.e. all the
3270    generations older than the one being collected) as roots.  We also
3271    remove non-mutable objects from the mutable list at this point.
3272    -------------------------------------------------------------------------- */
3273
3274 static void
3275 scavenge_mut_once_list(generation *gen)
3276 {
3277   const StgInfoTable *info;
3278   StgMutClosure *p, *next, *new_list;
3279
3280   p = gen->mut_once_list;
3281   new_list = END_MUT_LIST;
3282   next = p->mut_link;
3283
3284   evac_gen = gen->no;
3285   failed_to_evac = rtsFalse;
3286
3287   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3288
3289     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3290     info = get_itbl(p);
3291     /*
3292     if (info->type==RBH)
3293       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3294     */
3295     switch(info->type) {
3296
3297     case IND_OLDGEN:
3298     case IND_OLDGEN_PERM:
3299     case IND_STATIC:
3300       /* Try to pull the indirectee into this generation, so we can
3301        * remove the indirection from the mutable list.
3302        */
3303       ((StgIndOldGen *)p)->indirectee =
3304         evacuate(((StgIndOldGen *)p)->indirectee);
3305
3306 #if 0 && defined(DEBUG)
3307       if (RtsFlags.DebugFlags.gc)
3308       /* Debugging code to print out the size of the thing we just
3309        * promoted
3310        */
3311       {
3312         StgPtr start = gen->steps[0].scan;
3313         bdescr *start_bd = gen->steps[0].scan_bd;
3314         nat size = 0;
3315         scavenge(&gen->steps[0]);
3316         if (start_bd != gen->steps[0].scan_bd) {
3317           size += (P_)BLOCK_ROUND_UP(start) - start;
3318           start_bd = start_bd->link;
3319           while (start_bd != gen->steps[0].scan_bd) {
3320             size += BLOCK_SIZE_W;
3321             start_bd = start_bd->link;
3322           }
3323           size += gen->steps[0].scan -
3324             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3325         } else {
3326           size = gen->steps[0].scan - start;
3327         }
3328         belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3329       }
3330 #endif
3331
3332       /* failed_to_evac might happen if we've got more than two
3333        * generations, we're collecting only generation 0, the
3334        * indirection resides in generation 2 and the indirectee is
3335        * in generation 1.
3336        */
3337       if (failed_to_evac) {
3338         failed_to_evac = rtsFalse;
3339         p->mut_link = new_list;
3340         new_list = p;
3341       } else {
3342         /* the mut_link field of an IND_STATIC is overloaded as the
3343          * static link field too (it just so happens that we don't need
3344          * both at the same time), so we need to NULL it out when
3345          * removing this object from the mutable list because the static
3346          * link fields are all assumed to be NULL before doing a major
3347          * collection.
3348          */
3349         p->mut_link = NULL;
3350       }
3351       continue;
3352
3353     case MUT_CONS:
3354         /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3355          * it from the mutable list if possible by promoting whatever it
3356          * points to.
3357          */
3358         if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3359             /* didn't manage to promote everything, so put the
3360              * MUT_CONS back on the list.
3361              */
3362             p->mut_link = new_list;
3363             new_list = p;
3364         }
3365         continue;
3366
3367     default:
3368       // shouldn't have anything else on the mutables list
3369       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3370     }
3371   }
3372
3373   gen->mut_once_list = new_list;
3374 }
3375
3376
3377 static void
3378 scavenge_mutable_list(generation *gen)
3379 {
3380   const StgInfoTable *info;
3381   StgMutClosure *p, *next;
3382
3383   p = gen->saved_mut_list;
3384   next = p->mut_link;
3385
3386   evac_gen = 0;
3387   failed_to_evac = rtsFalse;
3388
3389   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3390
3391     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3392     info = get_itbl(p);
3393     /*
3394     if (info->type==RBH)
3395       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3396     */
3397     switch(info->type) {
3398
3399     case MUT_ARR_PTRS:
3400       // follow everything
3401       p->mut_link = gen->mut_list;
3402       gen->mut_list = p;
3403       {
3404         StgPtr end, q;
3405
3406         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3407         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3408           (StgClosure *)*q = evacuate((StgClosure *)*q);
3409         }
3410         continue;
3411       }
3412
3413       // Happens if a MUT_ARR_PTRS in the old generation is frozen
3414     case MUT_ARR_PTRS_FROZEN:
3415       {
3416         StgPtr end, q;
3417
3418         evac_gen = gen->no;
3419         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3420         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3421           (StgClosure *)*q = evacuate((StgClosure *)*q);
3422         }
3423         evac_gen = 0;
3424         // Set the mut_link field to NULL, so that we will put this
3425         // array back on the mutable list if it is subsequently thawed
3426         // by unsafeThaw#.
3427         p->mut_link = NULL;
3428         if (failed_to_evac) {
3429             failed_to_evac = rtsFalse;
3430             mkMutCons((StgClosure *)p, gen);
3431         }
3432         continue;
3433       }
3434
3435     case MUT_VAR:
3436         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3437         p->mut_link = gen->mut_list;
3438         gen->mut_list = p;
3439         continue;
3440
3441     case MVAR:
3442       {
3443         StgMVar *mvar = (StgMVar *)p;
3444         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3445         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3446         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3447         p->mut_link = gen->mut_list;
3448         gen->mut_list = p;
3449         continue;
3450       }
3451
3452     case TSO:
3453       {
3454         StgTSO *tso = (StgTSO *)p;
3455
3456         scavengeTSO(tso);
3457
3458         /* Don't take this TSO off the mutable list - it might still
3459          * point to some younger objects (because we set evac_gen to 0
3460          * above).
3461          */
3462         tso->mut_link = gen->mut_list;
3463         gen->mut_list = (StgMutClosure *)tso;
3464         continue;
3465       }
3466
3467     case BLACKHOLE_BQ:
3468       {
3469         StgBlockingQueue *bh = (StgBlockingQueue *)p;
3470         (StgClosure *)bh->blocking_queue =
3471           evacuate((StgClosure *)bh->blocking_queue);
3472         p->mut_link = gen->mut_list;
3473         gen->mut_list = p;
3474         continue;
3475       }
3476
3477       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3478        */
3479     case IND_OLDGEN:
3480     case IND_OLDGEN_PERM:
3481       /* Try to pull the indirectee into this generation, so we can
3482        * remove the indirection from the mutable list.
3483        */
3484       evac_gen = gen->no;
3485       ((StgIndOldGen *)p)->indirectee =
3486         evacuate(((StgIndOldGen *)p)->indirectee);
3487       evac_gen = 0;
3488
3489       if (failed_to_evac) {
3490         failed_to_evac = rtsFalse;
3491         p->mut_link = gen->mut_once_list;
3492         gen->mut_once_list = p;
3493       } else {
3494         p->mut_link = NULL;
3495       }
3496       continue;
3497
3498 #if defined(PAR)
3499     // HWL: check whether all of these are necessary
3500
3501     case RBH: // cf. BLACKHOLE_BQ
3502       {
3503         // nat size, ptrs, nonptrs, vhs;
3504         // char str[80];
3505         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3506         StgRBH *rbh = (StgRBH *)p;
3507         (StgClosure *)rbh->blocking_queue =
3508           evacuate((StgClosure *)rbh->blocking_queue);
3509         if (failed_to_evac) {
3510           failed_to_evac = rtsFalse;
3511           recordMutable((StgMutClosure *)rbh);
3512         }
3513         // ToDo: use size of reverted closure here!
3514         p += BLACKHOLE_sizeW();
3515         break;
3516       }
3517
3518     case BLOCKED_FETCH:
3519       {
3520         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3521         // follow the pointer to the node which is being demanded
3522         (StgClosure *)bf->node =
3523           evacuate((StgClosure *)bf->node);
3524         // follow the link to the rest of the blocking queue
3525         (StgClosure *)bf->link =
3526           evacuate((StgClosure *)bf->link);
3527         if (failed_to_evac) {
3528           failed_to_evac = rtsFalse;
3529           recordMutable((StgMutClosure *)bf);
3530         }
3531         p += sizeofW(StgBlockedFetch);
3532         break;
3533       }
3534
3535 #ifdef DIST
3536     case REMOTE_REF:
3537       barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3538 #endif
3539     case FETCH_ME:
3540       p += sizeofW(StgFetchMe);
3541       break; // nothing to do in this case
3542
3543     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3544       {
3545         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3546         (StgClosure *)fmbq->blocking_queue =
3547           evacuate((StgClosure *)fmbq->blocking_queue);
3548         if (failed_to_evac) {
3549           failed_to_evac = rtsFalse;
3550           recordMutable((StgMutClosure *)fmbq);
3551         }
3552         p += sizeofW(StgFetchMeBlockingQueue);
3553         break;
3554       }
3555 #endif
3556
3557     default:
3558       // shouldn't have anything else on the mutables list
3559       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3560     }
3561   }
3562 }
3563
3564
3565 static void
3566 scavenge_static(void)
3567 {
3568   StgClosure* p = static_objects;
3569   const StgInfoTable *info;
3570
3571   /* Always evacuate straight to the oldest generation for static
3572    * objects */
3573   evac_gen = oldest_gen->no;
3574
3575   /* keep going until we've scavenged all the objects on the linked
3576      list... */
3577   while (p != END_OF_STATIC_LIST) {
3578
3579     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3580     info = get_itbl(p);
3581     /*
3582     if (info->type==RBH)
3583       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3584     */
3585     // make sure the info pointer is into text space
3586
3587     /* Take this object *off* the static_objects list,
3588      * and put it on the scavenged_static_objects list.
3589      */
3590     static_objects = STATIC_LINK(info,p);
3591     STATIC_LINK(info,p) = scavenged_static_objects;
3592     scavenged_static_objects = p;
3593
3594     switch (info -> type) {
3595
3596     case IND_STATIC:
3597       {
3598         StgInd *ind = (StgInd *)p;
3599         ind->indirectee = evacuate(ind->indirectee);
3600
3601         /* might fail to evacuate it, in which case we have to pop it
3602          * back on the mutable list (and take it off the
3603          * scavenged_static list because the static link and mut link
3604          * pointers are one and the same).
3605          */
3606         if (failed_to_evac) {
3607           failed_to_evac = rtsFalse;
3608           scavenged_static_objects = IND_STATIC_LINK(p);
3609           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3610           oldest_gen->mut_once_list = (StgMutClosure *)ind;
3611         }
3612         break;
3613       }
3614
3615     case THUNK_STATIC:
3616       scavenge_thunk_srt(info);
3617       break;
3618
3619     case FUN_STATIC:
3620       scavenge_fun_srt(info);
3621       break;
3622
3623     case CONSTR_STATIC:
3624       {
3625         StgPtr q, next;
3626
3627         next = (P_)p->payload + info->layout.payload.ptrs;
3628         // evacuate the pointers
3629         for (q = (P_)p->payload; q < next; q++) {
3630           (StgClosure *)*q = evacuate((StgClosure *)*q);
3631         }
3632         break;
3633       }
3634
3635     default:
3636       barf("scavenge_static: strange closure %d", (int)(info->type));
3637     }
3638
3639     ASSERT(failed_to_evac == rtsFalse);
3640
3641     /* get the next static object from the list.  Remember, there might
3642      * be more stuff on this list now that we've done some evacuating!
3643      * (static_objects is a global)
3644      */
3645     p = static_objects;
3646   }
3647 }
3648
3649 /* -----------------------------------------------------------------------------
3650    scavenge a chunk of memory described by a bitmap
3651    -------------------------------------------------------------------------- */
3652
3653 static void
3654 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
3655 {
3656     nat i, b;
3657     StgWord bitmap;
3658
3659     b = 0;
3660     bitmap = large_bitmap->bitmap[b];
3661     for (i = 0; i < size; ) {
3662         if ((bitmap & 1) == 0) {
3663             (StgClosure *)*p = evacuate((StgClosure *)*p);
3664         }
3665         i++;
3666         p++;
3667         if (i % BITS_IN(W_) == 0) {
3668             b++;
3669             bitmap = large_bitmap->bitmap[b];
3670         } else {
3671             bitmap = bitmap >> 1;
3672         }
3673     }
3674 }
3675
3676 static inline StgPtr
3677 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
3678 {
3679     while (size > 0) {
3680         if ((bitmap & 1) == 0) {
3681             (StgClosure *)*p = evacuate((StgClosure *)*p);
3682         }
3683         p++;
3684         bitmap = bitmap >> 1;
3685         size--;
3686     }
3687     return p;
3688 }
3689
3690 /* -----------------------------------------------------------------------------
3691    scavenge_stack walks over a section of stack and evacuates all the
3692    objects pointed to by it.  We can use the same code for walking
3693    AP_STACK_UPDs, since these are just sections of copied stack.
3694    -------------------------------------------------------------------------- */
3695
3696
3697 static void
3698 scavenge_stack(StgPtr p, StgPtr stack_end)
3699 {
3700   const StgRetInfoTable* info;
3701   StgWord bitmap;
3702   nat size;
3703
3704   //IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
3705
3706   /*
3707    * Each time around this loop, we are looking at a chunk of stack
3708    * that starts with an activation record.
3709    */
3710
3711   while (p < stack_end) {
3712     info  = get_ret_itbl((StgClosure *)p);
3713
3714     switch (info->i.type) {
3715
3716     case UPDATE_FRAME:
3717         ((StgUpdateFrame *)p)->updatee
3718             = evacuate(((StgUpdateFrame *)p)->updatee);
3719         p += sizeofW(StgUpdateFrame);
3720         continue;
3721
3722       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3723     case STOP_FRAME:
3724     case CATCH_FRAME:
3725     case RET_SMALL:
3726     case RET_VEC_SMALL:
3727         bitmap = BITMAP_BITS(info->i.layout.bitmap);
3728         size   = BITMAP_SIZE(info->i.layout.bitmap);
3729         // NOTE: the payload starts immediately after the info-ptr, we
3730         // don't have an StgHeader in the same sense as a heap closure.
3731         p++;
3732         p = scavenge_small_bitmap(p, size, bitmap);
3733
3734     follow_srt:
3735         scavenge_srt((StgClosure **)info->srt, info->i.srt_bitmap);
3736         continue;
3737
3738     case RET_BCO: {
3739         StgBCO *bco;
3740         nat size;
3741
3742         p++;
3743         (StgClosure *)*p = evacuate((StgClosure *)*p);
3744         bco = (StgBCO *)*p;
3745         p++;
3746         size = BCO_BITMAP_SIZE(bco);
3747         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
3748         p += size;
3749         continue;
3750     }
3751
3752       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3753     case RET_BIG:
3754     case RET_VEC_BIG:
3755     {
3756         nat size;
3757
3758         size = info->i.layout.large_bitmap->size;
3759         p++;
3760         scavenge_large_bitmap(p, info->i.layout.large_bitmap, size);
3761         p += size;
3762         // and don't forget to follow the SRT
3763         goto follow_srt;
3764     }
3765
3766       // Dynamic bitmap: the mask is stored on the stack, and
3767       // there are a number of non-pointers followed by a number
3768       // of pointers above the bitmapped area.  (see StgMacros.h,
3769       // HEAP_CHK_GEN).
3770     case RET_DYN:
3771     {
3772         StgWord dyn;
3773         dyn = ((StgRetDyn *)p)->liveness;
3774
3775         // traverse the bitmap first
3776         bitmap = GET_LIVENESS(dyn);
3777         p      = (P_)&((StgRetDyn *)p)->payload[0];
3778         size   = RET_DYN_BITMAP_SIZE;
3779         p = scavenge_small_bitmap(p, size, bitmap);
3780
3781         // skip over the non-ptr words
3782         p += GET_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
3783
3784         // follow the ptr words
3785         for (size = GET_PTRS(dyn); size > 0; size--) {
3786             (StgClosure *)*p = evacuate((StgClosure *)*p);
3787             p++;
3788         }
3789         continue;
3790     }
3791
3792     case RET_FUN:
3793     {
3794         StgRetFun *ret_fun = (StgRetFun *)p;
3795         StgFunInfoTable *fun_info;
3796
3797         ret_fun->fun = evacuate(ret_fun->fun);
3798         fun_info = get_fun_itbl(ret_fun->fun);
3799         p = scavenge_arg_block(fun_info, ret_fun->payload);
3800         goto follow_srt;
3801     }
3802
3803     default:
3804         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
3805     }
3806   }
3807 }
3808
3809 /*-----------------------------------------------------------------------------
3810   scavenge the large object list.
3811
3812   evac_gen set by caller; similar games played with evac_gen as with
3813   scavenge() - see comment at the top of scavenge().  Most large
3814   objects are (repeatedly) mutable, so most of the time evac_gen will
3815   be zero.
3816   --------------------------------------------------------------------------- */
3817
3818 static void
3819 scavenge_large(step *stp)
3820 {
3821   bdescr *bd;
3822   StgPtr p;
3823
3824   bd = stp->new_large_objects;
3825
3826   for (; bd != NULL; bd = stp->new_large_objects) {
3827
3828     /* take this object *off* the large objects list and put it on
3829      * the scavenged large objects list.  This is so that we can
3830      * treat new_large_objects as a stack and push new objects on
3831      * the front when evacuating.
3832      */
3833     stp->new_large_objects = bd->link;
3834     dbl_link_onto(bd, &stp->scavenged_large_objects);
3835
3836     // update the block count in this step.
3837     stp->n_scavenged_large_blocks += bd->blocks;
3838
3839     p = bd->start;
3840     if (scavenge_one(p)) {
3841         mkMutCons((StgClosure *)p, stp->gen);
3842     }
3843   }
3844 }
3845
3846 /* -----------------------------------------------------------------------------
3847    Initialising the static object & mutable lists
3848    -------------------------------------------------------------------------- */
3849
3850 static void
3851 zero_static_object_list(StgClosure* first_static)
3852 {
3853   StgClosure* p;
3854   StgClosure* link;
3855   const StgInfoTable *info;
3856
3857   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3858     info = get_itbl(p);
3859     link = STATIC_LINK(info, p);
3860     STATIC_LINK(info,p) = NULL;
3861   }
3862 }
3863
3864 /* This function is only needed because we share the mutable link
3865  * field with the static link field in an IND_STATIC, so we have to
3866  * zero the mut_link field before doing a major GC, which needs the
3867  * static link field.
3868  *
3869  * It doesn't do any harm to zero all the mutable link fields on the
3870  * mutable list.
3871  */
3872
3873 static void
3874 zero_mutable_list( StgMutClosure *first )
3875 {
3876   StgMutClosure *next, *c;
3877
3878   for (c = first; c != END_MUT_LIST; c = next) {
3879     next = c->mut_link;
3880     c->mut_link = NULL;
3881   }
3882 }
3883
3884 /* -----------------------------------------------------------------------------
3885    Reverting CAFs
3886    -------------------------------------------------------------------------- */
3887
3888 void
3889 revertCAFs( void )
3890 {
3891     StgIndStatic *c;
3892
3893     for (c = (StgIndStatic *)caf_list; c != NULL;
3894          c = (StgIndStatic *)c->static_link)
3895     {
3896         c->header.info = c->saved_info;
3897         c->saved_info = NULL;
3898         // could, but not necessary: c->static_link = NULL;
3899     }
3900     caf_list = NULL;
3901 }
3902
3903 void
3904 markCAFs( evac_fn evac )
3905 {
3906     StgIndStatic *c;
3907
3908     for (c = (StgIndStatic *)caf_list; c != NULL;
3909          c = (StgIndStatic *)c->static_link)
3910     {
3911         evac(&c->indirectee);
3912     }
3913 }
3914
3915 /* -----------------------------------------------------------------------------
3916    Sanity code for CAF garbage collection.
3917
3918    With DEBUG turned on, we manage a CAF list in addition to the SRT
3919    mechanism.  After GC, we run down the CAF list and blackhole any
3920    CAFs which have been garbage collected.  This means we get an error
3921    whenever the program tries to enter a garbage collected CAF.
3922
3923    Any garbage collected CAFs are taken off the CAF list at the same
3924    time.
3925    -------------------------------------------------------------------------- */
3926
3927 #if 0 && defined(DEBUG)
3928
3929 static void
3930 gcCAFs(void)
3931 {
3932   StgClosure*  p;
3933   StgClosure** pp;
3934   const StgInfoTable *info;
3935   nat i;
3936
3937   i = 0;
3938   p = caf_list;
3939   pp = &caf_list;
3940
3941   while (p != NULL) {
3942
3943     info = get_itbl(p);
3944
3945     ASSERT(info->type == IND_STATIC);
3946
3947     if (STATIC_LINK(info,p) == NULL) {
3948       IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3949       // black hole it
3950       SET_INFO(p,&stg_BLACKHOLE_info);
3951       p = STATIC_LINK2(info,p);
3952       *pp = p;
3953     }
3954     else {
3955       pp = &STATIC_LINK2(info,p);
3956       p = *pp;
3957       i++;
3958     }
3959
3960   }
3961
3962   //  belch("%d CAFs live", i);
3963 }
3964 #endif
3965
3966
3967 /* -----------------------------------------------------------------------------
3968    Lazy black holing.
3969
3970    Whenever a thread returns to the scheduler after possibly doing
3971    some work, we have to run down the stack and black-hole all the
3972    closures referred to by update frames.
3973    -------------------------------------------------------------------------- */
3974
3975 static void
3976 threadLazyBlackHole(StgTSO *tso)
3977 {
3978     StgClosure *frame;
3979     StgRetInfoTable *info;
3980     StgBlockingQueue *bh;
3981     StgPtr stack_end;
3982
3983     stack_end = &tso->stack[tso->stack_size];
3984
3985     frame = (StgClosure *)tso->sp;
3986
3987     while (1) {
3988         info = get_ret_itbl(frame);
3989
3990         switch (info->i.type) {
3991
3992         case UPDATE_FRAME:
3993             bh = (StgBlockingQueue *)((StgUpdateFrame *)frame)->updatee;
3994
3995             /* if the thunk is already blackholed, it means we've also
3996              * already blackholed the rest of the thunks on this stack,
3997              * so we can stop early.
3998              *
3999              * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
4000              * don't interfere with this optimisation.
4001              */
4002             if (bh->header.info == &stg_BLACKHOLE_info) {
4003                 return;
4004             }
4005
4006             if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
4007                 bh->header.info != &stg_CAF_BLACKHOLE_info) {
4008 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4009                 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4010 #endif
4011 #ifdef PROFILING
4012                 // @LDV profiling
4013                 // We pretend that bh is now dead.
4014                 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4015 #endif
4016                 SET_INFO(bh,&stg_BLACKHOLE_info);
4017 #ifdef PROFILING
4018                 // @LDV profiling
4019                 // We pretend that bh has just been created.
4020                 LDV_recordCreate(bh);
4021 #endif
4022             }
4023
4024             frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4025             break;
4026
4027         case STOP_FRAME:
4028             return;
4029
4030             // normal stack frames; do nothing except advance the pointer
4031         default:
4032             (StgPtr)frame += stack_frame_sizeW(frame);
4033         }
4034     }
4035 }
4036
4037
4038 /* -----------------------------------------------------------------------------
4039  * Stack squeezing
4040  *
4041  * Code largely pinched from old RTS, then hacked to bits.  We also do
4042  * lazy black holing here.
4043  *
4044  * -------------------------------------------------------------------------- */
4045
4046 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4047
4048 static void
4049 threadSqueezeStack(StgTSO *tso)
4050 {
4051     StgPtr frame;
4052     rtsBool prev_was_update_frame;
4053     StgClosure *updatee = NULL;
4054     StgPtr bottom;
4055     StgRetInfoTable *info;
4056     StgWord current_gap_size;
4057     struct stack_gap *gap;
4058
4059     // Stage 1:
4060     //    Traverse the stack upwards, replacing adjacent update frames
4061     //    with a single update frame and a "stack gap".  A stack gap
4062     //    contains two values: the size of the gap, and the distance
4063     //    to the next gap (or the stack top).
4064
4065     bottom = &(tso->stack[tso->stack_size]);
4066
4067     frame = tso->sp;
4068
4069     ASSERT(frame < bottom);
4070
4071     prev_was_update_frame = rtsFalse;
4072     current_gap_size = 0;
4073     gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4074
4075     while (frame < bottom) {
4076
4077         info = get_ret_itbl((StgClosure *)frame);
4078         switch (info->i.type) {
4079
4080         case UPDATE_FRAME:
4081         {
4082             StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4083
4084             if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
4085
4086                 // found a BLACKHOLE'd update frame; we've been here
4087                 // before, in a previous GC, so just break out.
4088
4089                 // Mark the end of the gap, if we're in one.
4090                 if (current_gap_size != 0) {
4091                     gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
4092                 }
4093
4094                 frame += sizeofW(StgUpdateFrame);
4095                 goto done_traversing;
4096             }
4097
4098             if (prev_was_update_frame) {
4099
4100                 TICK_UPD_SQUEEZED();
4101                 /* wasn't there something about update squeezing and ticky to be
4102                  * sorted out?  oh yes: we aren't counting each enter properly
4103                  * in this case.  See the log somewhere.  KSW 1999-04-21
4104                  *
4105                  * Check two things: that the two update frames don't point to
4106                  * the same object, and that the updatee_bypass isn't already an
4107                  * indirection.  Both of these cases only happen when we're in a
4108                  * block hole-style loop (and there are multiple update frames
4109                  * on the stack pointing to the same closure), but they can both
4110                  * screw us up if we don't check.
4111                  */
4112                 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4113                     // this wakes the threads up
4114                     UPD_IND_NOLOCK(upd->updatee, updatee);
4115                 }
4116
4117                 // now mark this update frame as a stack gap.  The gap
4118                 // marker resides in the bottom-most update frame of
4119                 // the series of adjacent frames, and covers all the
4120                 // frames in this series.
4121                 current_gap_size += sizeofW(StgUpdateFrame);
4122                 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4123                 ((struct stack_gap *)frame)->next_gap = gap;
4124
4125                 frame += sizeofW(StgUpdateFrame);
4126                 continue;
4127             }
4128
4129             // single update frame, or the topmost update frame in a series
4130             else {
4131                 StgBlockingQueue *bh = (StgBlockingQueue *)upd->updatee;
4132
4133                 // Do lazy black-holing
4134                 if (bh->header.info != &stg_BLACKHOLE_info &&
4135                     bh->header.info != &stg_BLACKHOLE_BQ_info &&
4136                     bh->header.info != &stg_CAF_BLACKHOLE_info) {
4137 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4138                     belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4139 #endif
4140 #ifdef DEBUG
4141                     /* zero out the slop so that the sanity checker can tell
4142                      * where the next closure is.
4143                      */
4144                     {
4145                         StgInfoTable *bh_info = get_itbl(bh);
4146                         nat np = bh_info->layout.payload.ptrs,
4147                             nw = bh_info->layout.payload.nptrs, i;
4148                         /* don't zero out slop for a THUNK_SELECTOR,
4149                          * because its layout info is used for a
4150                          * different purpose, and it's exactly the
4151                          * same size as a BLACKHOLE in any case.
4152                          */
4153                         if (bh_info->type != THUNK_SELECTOR) {
4154                             for (i = np; i < np + nw; i++) {
4155                                 ((StgClosure *)bh)->payload[i] = 0;
4156                             }
4157                         }
4158                     }
4159 #endif
4160 #ifdef PROFILING
4161                     // We pretend that bh is now dead.
4162                     LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4163 #endif
4164                     // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
4165                     SET_INFO(bh,&stg_BLACKHOLE_info);
4166 #ifdef PROFILING
4167                     // We pretend that bh has just been created.
4168                     LDV_recordCreate(bh);
4169 #endif
4170                 }
4171
4172                 prev_was_update_frame = rtsTrue;
4173                 updatee = upd->updatee;
4174                 frame += sizeofW(StgUpdateFrame);
4175                 continue;
4176             }
4177         }
4178
4179         default:
4180             prev_was_update_frame = rtsFalse;
4181
4182             // we're not in a gap... check whether this is the end of a gap
4183             // (an update frame can't be the end of a gap).
4184             if (current_gap_size != 0) {
4185                 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4186             }
4187             current_gap_size = 0;
4188
4189             frame += stack_frame_sizeW((StgClosure *)frame);
4190             continue;
4191         }
4192     }
4193
4194 done_traversing:
4195
4196     // Now we have a stack with gaps in it, and we have to walk down
4197     // shoving the stack up to fill in the gaps.  A diagram might
4198     // help:
4199     //
4200     //    +| ********* |
4201     //     | ********* | <- sp
4202     //     |           |
4203     //     |           | <- gap_start
4204     //     | ......... |                |
4205     //     | stack_gap | <- gap         | chunk_size
4206     //     | ......... |                |
4207     //     | ......... | <- gap_end     v
4208     //     | ********* |
4209     //     | ********* |
4210     //     | ********* |
4211     //    -| ********* |
4212     //
4213     // 'sp'  points the the current top-of-stack
4214     // 'gap' points to the stack_gap structure inside the gap
4215     // *****   indicates real stack data
4216     // .....   indicates gap
4217     // <empty> indicates unused
4218     //
4219     {
4220         void *sp;
4221         void *gap_start, *next_gap_start, *gap_end;
4222         nat chunk_size;
4223
4224         next_gap_start = (void *)gap + sizeof(StgUpdateFrame);
4225         sp = next_gap_start;
4226
4227         while ((StgPtr)gap > tso->sp) {
4228
4229             // we're working in *bytes* now...
4230             gap_start = next_gap_start;
4231             gap_end = gap_start - gap->gap_size * sizeof(W_);
4232
4233             gap = gap->next_gap;
4234             next_gap_start = (void *)gap + sizeof(StgUpdateFrame);
4235
4236             chunk_size = gap_end - next_gap_start;
4237             sp -= chunk_size;
4238             memmove(sp, next_gap_start, chunk_size);
4239         }
4240
4241         tso->sp = (StgPtr)sp;
4242     }
4243 }
4244
4245 /* -----------------------------------------------------------------------------
4246  * Pausing a thread
4247  *
4248  * We have to prepare for GC - this means doing lazy black holing
4249  * here.  We also take the opportunity to do stack squeezing if it's
4250  * turned on.
4251  * -------------------------------------------------------------------------- */
4252 void
4253 threadPaused(StgTSO *tso)
4254 {
4255   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4256     threadSqueezeStack(tso);    // does black holing too
4257   else
4258     threadLazyBlackHole(tso);
4259 }
4260
4261 /* -----------------------------------------------------------------------------
4262  * Debugging
4263  * -------------------------------------------------------------------------- */
4264
4265 #if DEBUG
4266 void
4267 printMutOnceList(generation *gen)
4268 {
4269   StgMutClosure *p, *next;
4270
4271   p = gen->mut_once_list;
4272   next = p->mut_link;
4273
4274   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4275   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4276     fprintf(stderr, "%p (%s), ",
4277             p, info_type((StgClosure *)p));
4278   }
4279   fputc('\n', stderr);
4280 }
4281
4282 void
4283 printMutableList(generation *gen)
4284 {
4285   StgMutClosure *p, *next;
4286
4287   p = gen->mut_list;
4288   next = p->mut_link;
4289
4290   fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4291   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4292     fprintf(stderr, "%p (%s), ",
4293             p, info_type((StgClosure *)p));
4294   }
4295   fputc('\n', stderr);
4296 }
4297
4298 static inline rtsBool
4299 maybeLarge(StgClosure *closure)
4300 {
4301   StgInfoTable *info = get_itbl(closure);
4302
4303   /* closure types that may be found on the new_large_objects list;
4304      see scavenge_large */
4305   return (info->type == MUT_ARR_PTRS ||
4306           info->type == MUT_ARR_PTRS_FROZEN ||
4307           info->type == TSO ||
4308           info->type == ARR_WORDS);
4309 }
4310
4311
4312 #endif // DEBUG