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