ghc/rts/GC.c

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