ghc/rts/GC.c

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