ghc/rts/GC.c

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