ghc/rts/GC.c

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