ghc/rts/GC.c

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