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       resizeNurseriesFixed(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       /* Finally, we can update the blackhole_queue.  This queue
1298        * simply strings together TSOs blocked on black holes, it is
1299        * not intended to keep anything alive.  Hence, we do not follow
1300        * pointers on the blackhole_queue until now, when we have
1301        * determined which TSOs are otherwise reachable.  We know at
1302        * this point that all TSOs have been evacuated, however.
1303        */
1304       {
1305           StgTSO **pt;
1306           for (pt = &blackhole_queue; *pt != END_TSO_QUEUE; pt = &((*pt)->link)) {
1307               *pt = (StgTSO *)isAlive((StgClosure *)*pt);
1308               ASSERT(*pt != NULL);
1309           }
1310       }
1311
1312       weak_stage = WeakDone;  // *now* we're done,
1313       return rtsTrue;         // but one more round of scavenging, please
1314
1315   default:
1316       barf("traverse_weak_ptr_list");
1317       return rtsTrue;
1318   }
1319
1320 }
1321
1322 /* -----------------------------------------------------------------------------
1323    After GC, the live weak pointer list may have forwarding pointers
1324    on it, because a weak pointer object was evacuated after being
1325    moved to the live weak pointer list.  We remove those forwarding
1326    pointers here.
1327
1328    Also, we don't consider weak pointer objects to be reachable, but
1329    we must nevertheless consider them to be "live" and retain them.
1330    Therefore any weak pointer objects which haven't as yet been
1331    evacuated need to be evacuated now.
1332    -------------------------------------------------------------------------- */
1333
1334
1335 static void
1336 mark_weak_ptr_list ( StgWeak **list )
1337 {
1338   StgWeak *w, **last_w;
1339
1340   last_w = list;
1341   for (w = *list; w; w = w->link) {
1342       // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here
1343       ASSERT(w->header.info == &stg_DEAD_WEAK_info
1344              || get_itbl(w)->type == WEAK || get_itbl(w)->type == EVACUATED);
1345       w = (StgWeak *)evacuate((StgClosure *)w);
1346       *last_w = w;
1347       last_w = &(w->link);
1348   }
1349 }
1350
1351 /* -----------------------------------------------------------------------------
1352    isAlive determines whether the given closure is still alive (after
1353    a garbage collection) or not.  It returns the new address of the
1354    closure if it is alive, or NULL otherwise.
1355
1356    NOTE: Use it before compaction only!
1357    -------------------------------------------------------------------------- */
1358
1359
1360 StgClosure *
1361 isAlive(StgClosure *p)
1362 {
1363   const StgInfoTable *info;
1364   bdescr *bd;
1365
1366   while (1) {
1367
1368     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
1369     info = get_itbl(p);
1370
1371     // ignore static closures
1372     //
1373     // ToDo: for static closures, check the static link field.
1374     // Problem here is that we sometimes don't set the link field, eg.
1375     // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1376     //
1377     if (!HEAP_ALLOCED(p)) {
1378         return p;
1379     }
1380
1381     // ignore closures in generations that we're not collecting.
1382     bd = Bdescr((P_)p);
1383     if (bd->gen_no > N) {
1384         return p;
1385     }
1386
1387     // if it's a pointer into to-space, then we're done
1388     if (bd->flags & BF_EVACUATED) {
1389         return p;
1390     }
1391
1392     // large objects use the evacuated flag
1393     if (bd->flags & BF_LARGE) {
1394         return NULL;
1395     }
1396
1397     // check the mark bit for compacted steps
1398     if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
1399         return p;
1400     }
1401
1402     switch (info->type) {
1403
1404     case IND:
1405     case IND_STATIC:
1406     case IND_PERM:
1407     case IND_OLDGEN:            // rely on compatible layout with StgInd
1408     case IND_OLDGEN_PERM:
1409       // follow indirections
1410       p = ((StgInd *)p)->indirectee;
1411       continue;
1412
1413     case EVACUATED:
1414       // alive!
1415       return ((StgEvacuated *)p)->evacuee;
1416
1417     case TSO:
1418       if (((StgTSO *)p)->what_next == ThreadRelocated) {
1419         p = (StgClosure *)((StgTSO *)p)->link;
1420         continue;
1421       }
1422       return NULL;
1423
1424     default:
1425       // dead.
1426       return NULL;
1427     }
1428   }
1429 }
1430
1431 static void
1432 mark_root(StgClosure **root)
1433 {
1434   *root = evacuate(*root);
1435 }
1436
1437 STATIC_INLINE void
1438 upd_evacuee(StgClosure *p, StgClosure *dest)
1439 {
1440     // not true: (ToDo: perhaps it should be)
1441     // ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
1442     SET_INFO(p, &stg_EVACUATED_info);
1443     ((StgEvacuated *)p)->evacuee = dest;
1444 }
1445
1446
1447 STATIC_INLINE StgClosure *
1448 copy(StgClosure *src, nat size, step *stp)
1449 {
1450   P_ to, from, dest;
1451 #ifdef PROFILING
1452   // @LDV profiling
1453   nat size_org = size;
1454 #endif
1455
1456   TICK_GC_WORDS_COPIED(size);
1457   /* Find out where we're going, using the handy "to" pointer in
1458    * the step of the source object.  If it turns out we need to
1459    * evacuate to an older generation, adjust it here (see comment
1460    * by evacuate()).
1461    */
1462   if (stp->gen_no < evac_gen) {
1463 #ifdef NO_EAGER_PROMOTION
1464     failed_to_evac = rtsTrue;
1465 #else
1466     stp = &generations[evac_gen].steps[0];
1467 #endif
1468   }
1469
1470   /* chain a new block onto the to-space for the destination step if
1471    * necessary.
1472    */
1473   if (stp->hp + size >= stp->hpLim) {
1474     gc_alloc_block(stp);
1475   }
1476
1477   for(to = stp->hp, from = (P_)src; size>0; --size) {
1478     *to++ = *from++;
1479   }
1480
1481   dest = stp->hp;
1482   stp->hp = to;
1483   upd_evacuee(src,(StgClosure *)dest);
1484 #ifdef PROFILING
1485   // We store the size of the just evacuated object in the LDV word so that
1486   // the profiler can guess the position of the next object later.
1487   SET_EVACUAEE_FOR_LDV(src, size_org);
1488 #endif
1489   return (StgClosure *)dest;
1490 }
1491
1492 /* Special version of copy() for when we only want to copy the info
1493  * pointer of an object, but reserve some padding after it.  This is
1494  * used to optimise evacuation of BLACKHOLEs.
1495  */
1496
1497
1498 static StgClosure *
1499 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1500 {
1501   P_ dest, to, from;
1502 #ifdef PROFILING
1503   // @LDV profiling
1504   nat size_to_copy_org = size_to_copy;
1505 #endif
1506
1507   TICK_GC_WORDS_COPIED(size_to_copy);
1508   if (stp->gen_no < evac_gen) {
1509 #ifdef NO_EAGER_PROMOTION
1510     failed_to_evac = rtsTrue;
1511 #else
1512     stp = &generations[evac_gen].steps[0];
1513 #endif
1514   }
1515
1516   if (stp->hp + size_to_reserve >= stp->hpLim) {
1517     gc_alloc_block(stp);
1518   }
1519
1520   for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1521     *to++ = *from++;
1522   }
1523
1524   dest = stp->hp;
1525   stp->hp += size_to_reserve;
1526   upd_evacuee(src,(StgClosure *)dest);
1527 #ifdef PROFILING
1528   // We store the size of the just evacuated object in the LDV word so that
1529   // the profiler can guess the position of the next object later.
1530   // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1531   // words.
1532   SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1533   // fill the slop
1534   if (size_to_reserve - size_to_copy_org > 0)
1535     FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1536 #endif
1537   return (StgClosure *)dest;
1538 }
1539
1540
1541 /* -----------------------------------------------------------------------------
1542    Evacuate a large object
1543
1544    This just consists of removing the object from the (doubly-linked)
1545    step->large_objects list, and linking it on to the (singly-linked)
1546    step->new_large_objects list, from where it will be scavenged later.
1547
1548    Convention: bd->flags has BF_EVACUATED set for a large object
1549    that has been evacuated, or unset otherwise.
1550    -------------------------------------------------------------------------- */
1551
1552
1553 STATIC_INLINE void
1554 evacuate_large(StgPtr p)
1555 {
1556   bdescr *bd = Bdescr(p);
1557   step *stp;
1558
1559   // object must be at the beginning of the block (or be a ByteArray)
1560   ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1561          (((W_)p & BLOCK_MASK) == 0));
1562
1563   // already evacuated?
1564   if (bd->flags & BF_EVACUATED) {
1565     /* Don't forget to set the failed_to_evac flag if we didn't get
1566      * the desired destination (see comments in evacuate()).
1567      */
1568     if (bd->gen_no < evac_gen) {
1569       failed_to_evac = rtsTrue;
1570       TICK_GC_FAILED_PROMOTION();
1571     }
1572     return;
1573   }
1574
1575   stp = bd->step;
1576   // remove from large_object list
1577   if (bd->u.back) {
1578     bd->u.back->link = bd->link;
1579   } else { // first object in the list
1580     stp->large_objects = bd->link;
1581   }
1582   if (bd->link) {
1583     bd->link->u.back = bd->u.back;
1584   }
1585
1586   /* link it on to the evacuated large object list of the destination step
1587    */
1588   stp = bd->step->to;
1589   if (stp->gen_no < evac_gen) {
1590 #ifdef NO_EAGER_PROMOTION
1591     failed_to_evac = rtsTrue;
1592 #else
1593     stp = &generations[evac_gen].steps[0];
1594 #endif
1595   }
1596
1597   bd->step = stp;
1598   bd->gen_no = stp->gen_no;
1599   bd->link = stp->new_large_objects;
1600   stp->new_large_objects = bd;
1601   bd->flags |= BF_EVACUATED;
1602 }
1603
1604 /* -----------------------------------------------------------------------------
1605    Evacuate
1606
1607    This is called (eventually) for every live object in the system.
1608
1609    The caller to evacuate specifies a desired generation in the
1610    evac_gen global variable.  The following conditions apply to
1611    evacuating an object which resides in generation M when we're
1612    collecting up to generation N
1613
1614    if  M >= evac_gen
1615            if  M > N     do nothing
1616            else          evac to step->to
1617
1618    if  M < evac_gen      evac to evac_gen, step 0
1619
1620    if the object is already evacuated, then we check which generation
1621    it now resides in.
1622
1623    if  M >= evac_gen     do nothing
1624    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1625                          didn't manage to evacuate this object into evac_gen.
1626
1627
1628    OPTIMISATION NOTES:
1629
1630    evacuate() is the single most important function performance-wise
1631    in the GC.  Various things have been tried to speed it up, but as
1632    far as I can tell the code generated by gcc 3.2 with -O2 is about
1633    as good as it's going to get.  We pass the argument to evacuate()
1634    in a register using the 'regparm' attribute (see the prototype for
1635    evacuate() near the top of this file).
1636
1637    Changing evacuate() to take an (StgClosure **) rather than
1638    returning the new pointer seems attractive, because we can avoid
1639    writing back the pointer when it hasn't changed (eg. for a static
1640    object, or an object in a generation > N).  However, I tried it and
1641    it doesn't help.  One reason is that the (StgClosure **) pointer
1642    gets spilled to the stack inside evacuate(), resulting in far more
1643    extra reads/writes than we save.
1644    -------------------------------------------------------------------------- */
1645
1646 REGPARM1 static StgClosure *
1647 evacuate(StgClosure *q)
1648 {
1649 #if defined(PAR)
1650   StgClosure *to;
1651 #endif
1652   bdescr *bd = NULL;
1653   step *stp;
1654   const StgInfoTable *info;
1655
1656 loop:
1657   if (HEAP_ALLOCED(q)) {
1658     bd = Bdescr((P_)q);
1659
1660     if (bd->gen_no > N) {
1661         /* Can't evacuate this object, because it's in a generation
1662          * older than the ones we're collecting.  Let's hope that it's
1663          * in evac_gen or older, or we will have to arrange to track
1664          * this pointer using the mutable list.
1665          */
1666         if (bd->gen_no < evac_gen) {
1667             // nope
1668             failed_to_evac = rtsTrue;
1669             TICK_GC_FAILED_PROMOTION();
1670         }
1671         return q;
1672     }
1673
1674     /* evacuate large objects by re-linking them onto a different list.
1675      */
1676     if (bd->flags & BF_LARGE) {
1677         info = get_itbl(q);
1678         if (info->type == TSO &&
1679             ((StgTSO *)q)->what_next == ThreadRelocated) {
1680             q = (StgClosure *)((StgTSO *)q)->link;
1681             goto loop;
1682         }
1683         evacuate_large((P_)q);
1684         return q;
1685     }
1686
1687     /* If the object is in a step that we're compacting, then we
1688      * need to use an alternative evacuate procedure.
1689      */
1690     if (bd->flags & BF_COMPACTED) {
1691         if (!is_marked((P_)q,bd)) {
1692             mark((P_)q,bd);
1693             if (mark_stack_full()) {
1694                 mark_stack_overflowed = rtsTrue;
1695                 reset_mark_stack();
1696             }
1697             push_mark_stack((P_)q);
1698         }
1699         return q;
1700     }
1701
1702     /* Object is not already evacuated. */
1703     ASSERT((bd->flags & BF_EVACUATED) == 0);
1704
1705     stp = bd->step->to;
1706   }
1707 #ifdef DEBUG
1708   else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1709 #endif
1710
1711   // make sure the info pointer is into text space
1712   ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
1713   info = get_itbl(q);
1714
1715   switch (info -> type) {
1716
1717   case MUT_VAR:
1718   case MVAR:
1719       return copy(q,sizeW_fromITBL(info),stp);
1720
1721   case CONSTR_0_1:
1722   {
1723       StgWord w = (StgWord)q->payload[0];
1724       if (q->header.info == Czh_con_info &&
1725           // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&
1726           (StgChar)w <= MAX_CHARLIKE) {
1727           return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1728       }
1729       if (q->header.info == Izh_con_info &&
1730           (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1731           return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1732       }
1733       // else, fall through ...
1734   }
1735
1736   case FUN_1_0:
1737   case FUN_0_1:
1738   case CONSTR_1_0:
1739     return copy(q,sizeofW(StgHeader)+1,stp);
1740
1741   case THUNK_1_0:
1742   case THUNK_0_1:
1743     return copy(q,sizeofW(StgThunk)+1,stp);
1744
1745   case THUNK_1_1:
1746   case THUNK_0_2:
1747   case THUNK_2_0:
1748 #ifdef NO_PROMOTE_THUNKS
1749     if (bd->gen_no == 0 &&
1750         bd->step->no != 0 &&
1751         bd->step->no == generations[bd->gen_no].n_steps-1) {
1752       stp = bd->step;
1753     }
1754 #endif
1755     return copy(q,sizeofW(StgThunk)+2,stp);
1756
1757   case FUN_1_1:
1758   case FUN_0_2:
1759   case FUN_2_0:
1760   case CONSTR_1_1:
1761   case CONSTR_0_2:
1762   case CONSTR_2_0:
1763     return copy(q,sizeofW(StgHeader)+2,stp);
1764
1765   case THUNK:
1766     return copy(q,thunk_sizeW_fromITBL(info),stp);
1767
1768   case FUN:
1769   case CONSTR:
1770   case IND_PERM:
1771   case IND_OLDGEN_PERM:
1772   case WEAK:
1773   case FOREIGN:
1774   case STABLE_NAME:
1775     return copy(q,sizeW_fromITBL(info),stp);
1776
1777   case BCO:
1778       return copy(q,bco_sizeW((StgBCO *)q),stp);
1779
1780   case CAF_BLACKHOLE:
1781   case SE_CAF_BLACKHOLE:
1782   case SE_BLACKHOLE:
1783   case BLACKHOLE:
1784     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1785
1786   case THUNK_SELECTOR:
1787     {
1788         StgClosure *p;
1789
1790         if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
1791             return copy(q,THUNK_SELECTOR_sizeW(),stp);
1792         }
1793
1794         p = eval_thunk_selector(info->layout.selector_offset,
1795                                 (StgSelector *)q);
1796
1797         if (p == NULL) {
1798             return copy(q,THUNK_SELECTOR_sizeW(),stp);
1799         } else {
1800             // q is still BLACKHOLE'd.
1801             thunk_selector_depth++;
1802             p = evacuate(p);
1803             thunk_selector_depth--;
1804             upd_evacuee(q,p);
1805 #ifdef PROFILING
1806             // We store the size of the just evacuated object in the
1807             // LDV word so that the profiler can guess the position of
1808             // the next object later.
1809             SET_EVACUAEE_FOR_LDV(q, THUNK_SELECTOR_sizeW());
1810 #endif
1811             return p;
1812         }
1813     }
1814
1815   case IND:
1816   case IND_OLDGEN:
1817     // follow chains of indirections, don't evacuate them
1818     q = ((StgInd*)q)->indirectee;
1819     goto loop;
1820
1821   case THUNK_STATIC:
1822     if (info->srt_bitmap != 0 && major_gc &&
1823         *THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1824       *THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1825       static_objects = (StgClosure *)q;
1826     }
1827     return q;
1828
1829   case FUN_STATIC:
1830     if (info->srt_bitmap != 0 && major_gc &&
1831         *FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1832       *FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1833       static_objects = (StgClosure *)q;
1834     }
1835     return q;
1836
1837   case IND_STATIC:
1838     /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1839      * on the CAF list, so don't do anything with it here (we'll
1840      * scavenge it later).
1841      */
1842     if (major_gc
1843           && ((StgIndStatic *)q)->saved_info == NULL
1844           && *IND_STATIC_LINK((StgClosure *)q) == NULL) {
1845         *IND_STATIC_LINK((StgClosure *)q) = static_objects;
1846         static_objects = (StgClosure *)q;
1847     }
1848     return q;
1849
1850   case CONSTR_STATIC:
1851     if (major_gc && *STATIC_LINK(info,(StgClosure *)q) == NULL) {
1852       *STATIC_LINK(info,(StgClosure *)q) = static_objects;
1853       static_objects = (StgClosure *)q;
1854     }
1855     return q;
1856
1857   case CONSTR_INTLIKE:
1858   case CONSTR_CHARLIKE:
1859   case CONSTR_NOCAF_STATIC:
1860     /* no need to put these on the static linked list, they don't need
1861      * to be scavenged.
1862      */
1863     return q;
1864
1865   case RET_BCO:
1866   case RET_SMALL:
1867   case RET_VEC_SMALL:
1868   case RET_BIG:
1869   case RET_VEC_BIG:
1870   case RET_DYN:
1871   case UPDATE_FRAME:
1872   case STOP_FRAME:
1873   case CATCH_FRAME:
1874   case CATCH_STM_FRAME:
1875   case CATCH_RETRY_FRAME:
1876   case ATOMICALLY_FRAME:
1877     // shouldn't see these
1878     barf("evacuate: stack frame at %p\n", q);
1879
1880   case PAP:
1881       return copy(q,pap_sizeW((StgPAP*)q),stp);
1882
1883   case AP:
1884       return copy(q,ap_sizeW((StgAP*)q),stp);
1885
1886   case AP_STACK:
1887       return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
1888
1889   case EVACUATED:
1890     /* Already evacuated, just return the forwarding address.
1891      * HOWEVER: if the requested destination generation (evac_gen) is
1892      * older than the actual generation (because the object was
1893      * already evacuated to a younger generation) then we have to
1894      * set the failed_to_evac flag to indicate that we couldn't
1895      * manage to promote the object to the desired generation.
1896      */
1897     if (evac_gen > 0) {         // optimisation
1898       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1899       if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
1900         failed_to_evac = rtsTrue;
1901         TICK_GC_FAILED_PROMOTION();
1902       }
1903     }
1904     return ((StgEvacuated*)q)->evacuee;
1905
1906   case ARR_WORDS:
1907       // just copy the block
1908       return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1909
1910   case MUT_ARR_PTRS:
1911   case MUT_ARR_PTRS_FROZEN:
1912   case MUT_ARR_PTRS_FROZEN0:
1913       // just copy the block
1914       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1915
1916   case TSO:
1917     {
1918       StgTSO *tso = (StgTSO *)q;
1919
1920       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1921        */
1922       if (tso->what_next == ThreadRelocated) {
1923         q = (StgClosure *)tso->link;
1924         goto loop;
1925       }
1926
1927       /* To evacuate a small TSO, we need to relocate the update frame
1928        * list it contains.
1929        */
1930       {
1931           StgTSO *new_tso;
1932           StgPtr p, q;
1933
1934           new_tso = (StgTSO *)copyPart((StgClosure *)tso,
1935                                        tso_sizeW(tso),
1936                                        sizeofW(StgTSO), stp);
1937           move_TSO(tso, new_tso);
1938           for (p = tso->sp, q = new_tso->sp;
1939                p < tso->stack+tso->stack_size;) {
1940               *q++ = *p++;
1941           }
1942
1943           return (StgClosure *)new_tso;
1944       }
1945     }
1946
1947 #if defined(PAR)
1948   case RBH:
1949     {
1950       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1951       to = copy(q,BLACKHOLE_sizeW(),stp);
1952       //ToDo: derive size etc from reverted IP
1953       //to = copy(q,size,stp);
1954       IF_DEBUG(gc,
1955                debugBelch("@@ evacuate: RBH %p (%s) to %p (%s)",
1956                      q, info_type(q), to, info_type(to)));
1957       return to;
1958     }
1959
1960   case BLOCKED_FETCH:
1961     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1962     to = copy(q,sizeofW(StgBlockedFetch),stp);
1963     IF_DEBUG(gc,
1964              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
1965                    q, info_type(q), to, info_type(to)));
1966     return to;
1967
1968 # ifdef DIST
1969   case REMOTE_REF:
1970 # endif
1971   case FETCH_ME:
1972     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1973     to = copy(q,sizeofW(StgFetchMe),stp);
1974     IF_DEBUG(gc,
1975              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
1976                    q, info_type(q), to, info_type(to)));
1977     return to;
1978
1979   case FETCH_ME_BQ:
1980     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1981     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1982     IF_DEBUG(gc,
1983              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
1984                    q, info_type(q), to, info_type(to)));
1985     return to;
1986 #endif
1987
1988   case TREC_HEADER:
1989     return copy(q,sizeofW(StgTRecHeader),stp);
1990
1991   case TVAR_WAIT_QUEUE:
1992     return copy(q,sizeofW(StgTVarWaitQueue),stp);
1993
1994   case TVAR:
1995     return copy(q,sizeofW(StgTVar),stp);
1996
1997   case TREC_CHUNK:
1998     return copy(q,sizeofW(StgTRecChunk),stp);
1999
2000   default:
2001     barf("evacuate: strange closure type %d", (int)(info->type));
2002   }
2003
2004   barf("evacuate");
2005 }
2006
2007 /* -----------------------------------------------------------------------------
2008    Evaluate a THUNK_SELECTOR if possible.
2009
2010    returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2011    a closure pointer if we evaluated it and this is the result.  Note
2012    that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2013    reducing it to HNF, just that we have eliminated the selection.
2014    The result might be another thunk, or even another THUNK_SELECTOR.
2015
2016    If the return value is non-NULL, the original selector thunk has
2017    been BLACKHOLE'd, and should be updated with an indirection or a
2018    forwarding pointer.  If the return value is NULL, then the selector
2019    thunk is unchanged.
2020
2021    ***
2022    ToDo: the treatment of THUNK_SELECTORS could be improved in the
2023    following way (from a suggestion by Ian Lynagh):
2024
2025    We can have a chain like this:
2026
2027       sel_0 --> (a,b)
2028                  |
2029                  |-----> sel_0 --> (a,b)
2030                                     |
2031                                     |-----> sel_0 --> ...
2032
2033    and the depth limit means we don't go all the way to the end of the
2034    chain, which results in a space leak.  This affects the recursive
2035    call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2036    the recursive call to eval_thunk_selector() in
2037    eval_thunk_selector().
2038
2039    We could eliminate the depth bound in this case, in the following
2040    way:
2041
2042       - traverse the chain once to discover the *value* of the
2043         THUNK_SELECTOR.  Mark all THUNK_SELECTORS that we
2044         visit on the way as having been visited already (somehow).
2045
2046       - in a second pass, traverse the chain again updating all
2047         THUNK_SEELCTORS that we find on the way with indirections to
2048         the value.
2049
2050       - if we encounter a "marked" THUNK_SELECTOR in a normal
2051         evacuate(), we konw it can't be updated so just evac it.
2052
2053    Program that illustrates the problem:
2054
2055         foo [] = ([], [])
2056         foo (x:xs) = let (ys, zs) = foo xs
2057                      in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2058
2059         main = bar [1..(100000000::Int)]
2060         bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2061
2062    -------------------------------------------------------------------------- */
2063
2064 static inline rtsBool
2065 is_to_space ( StgClosure *p )
2066 {
2067     bdescr *bd;
2068
2069     bd = Bdescr((StgPtr)p);
2070     if (HEAP_ALLOCED(p) &&
2071         ((bd->flags & BF_EVACUATED)
2072          || ((bd->flags & BF_COMPACTED) &&
2073              is_marked((P_)p,bd)))) {
2074         return rtsTrue;
2075     } else {
2076         return rtsFalse;
2077     }
2078 }
2079
2080 static StgClosure *
2081 eval_thunk_selector( nat field, StgSelector * p )
2082 {
2083     StgInfoTable *info;
2084     const StgInfoTable *info_ptr;
2085     StgClosure *selectee;
2086
2087     selectee = p->selectee;
2088
2089     // Save the real info pointer (NOTE: not the same as get_itbl()).
2090     info_ptr = p->header.info;
2091
2092     // If the THUNK_SELECTOR is in a generation that we are not
2093     // collecting, then bail out early.  We won't be able to save any
2094     // space in any case, and updating with an indirection is trickier
2095     // in an old gen.
2096     if (Bdescr((StgPtr)p)->gen_no > N) {
2097         return NULL;
2098     }
2099
2100     // BLACKHOLE the selector thunk, since it is now under evaluation.
2101     // This is important to stop us going into an infinite loop if
2102     // this selector thunk eventually refers to itself.
2103     SET_INFO(p,&stg_BLACKHOLE_info);
2104
2105 selector_loop:
2106
2107     // We don't want to end up in to-space, because this causes
2108     // problems when the GC later tries to evacuate the result of
2109     // eval_thunk_selector().  There are various ways this could
2110     // happen:
2111     //
2112     // 1. following an IND_STATIC
2113     //
2114     // 2. when the old generation is compacted, the mark phase updates
2115     //    from-space pointers to be to-space pointers, and we can't
2116     //    reliably tell which we're following (eg. from an IND_STATIC).
2117     //
2118     // 3. compacting GC again: if we're looking at a constructor in
2119     //    the compacted generation, it might point directly to objects
2120     //    in to-space.  We must bale out here, otherwise doing the selection
2121     //    will result in a to-space pointer being returned.
2122     //
2123     //  (1) is dealt with using a BF_EVACUATED test on the
2124     //  selectee. (2) and (3): we can tell if we're looking at an
2125     //  object in the compacted generation that might point to
2126     //  to-space objects by testing that (a) it is BF_COMPACTED, (b)
2127     //  the compacted generation is being collected, and (c) the
2128     //  object is marked.  Only a marked object may have pointers that
2129     //  point to to-space objects, because that happens when
2130     //  scavenging.
2131     //
2132     //  The to-space test is now embodied in the in_to_space() inline
2133     //  function, as it is re-used below.
2134     //
2135     if (is_to_space(selectee)) {
2136         goto bale_out;
2137     }
2138
2139     info = get_itbl(selectee);
2140     switch (info->type) {
2141       case CONSTR:
2142       case CONSTR_1_0:
2143       case CONSTR_0_1:
2144       case CONSTR_2_0:
2145       case CONSTR_1_1:
2146       case CONSTR_0_2:
2147       case CONSTR_STATIC:
2148       case CONSTR_NOCAF_STATIC:
2149           // check that the size is in range
2150           ASSERT(field <  (StgWord32)(info->layout.payload.ptrs +
2151                                       info->layout.payload.nptrs));
2152
2153           // Select the right field from the constructor, and check
2154           // that the result isn't in to-space.  It might be in
2155           // to-space if, for example, this constructor contains
2156           // pointers to younger-gen objects (and is on the mut-once
2157           // list).
2158           //
2159           {
2160               StgClosure *q;
2161               q = selectee->payload[field];
2162               if (is_to_space(q)) {
2163                   goto bale_out;
2164               } else {
2165                   return q;
2166               }
2167           }
2168
2169       case IND:
2170       case IND_PERM:
2171       case IND_OLDGEN:
2172       case IND_OLDGEN_PERM:
2173       case IND_STATIC:
2174           selectee = ((StgInd *)selectee)->indirectee;
2175           goto selector_loop;
2176
2177       case EVACUATED:
2178           // We don't follow pointers into to-space; the constructor
2179           // has already been evacuated, so we won't save any space
2180           // leaks by evaluating this selector thunk anyhow.
2181           break;
2182
2183       case THUNK_SELECTOR:
2184       {
2185           StgClosure *val;
2186
2187           // check that we don't recurse too much, re-using the
2188           // depth bound also used in evacuate().
2189           if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2190               break;
2191           }
2192           thunk_selector_depth++;
2193
2194           val = eval_thunk_selector(info->layout.selector_offset,
2195                                     (StgSelector *)selectee);
2196
2197           thunk_selector_depth--;
2198
2199           if (val == NULL) {
2200               break;
2201           } else {
2202               // We evaluated this selector thunk, so update it with
2203               // an indirection.  NOTE: we don't use UPD_IND here,
2204               // because we are guaranteed that p is in a generation
2205               // that we are collecting, and we never want to put the
2206               // indirection on a mutable list.
2207 #ifdef PROFILING
2208               // For the purposes of LDV profiling, we have destroyed
2209               // the original selector thunk.
2210               SET_INFO(p, info_ptr);
2211               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2212 #endif
2213               ((StgInd *)selectee)->indirectee = val;
2214               SET_INFO(selectee,&stg_IND_info);
2215
2216               // For the purposes of LDV profiling, we have created an
2217               // indirection.
2218               LDV_RECORD_CREATE(selectee);
2219
2220               selectee = val;
2221               goto selector_loop;
2222           }
2223       }
2224
2225       case AP:
2226       case AP_STACK:
2227       case THUNK:
2228       case THUNK_1_0:
2229       case THUNK_0_1:
2230       case THUNK_2_0:
2231       case THUNK_1_1:
2232       case THUNK_0_2:
2233       case THUNK_STATIC:
2234       case CAF_BLACKHOLE:
2235       case SE_CAF_BLACKHOLE:
2236       case SE_BLACKHOLE:
2237       case BLACKHOLE:
2238 #if defined(PAR)
2239       case RBH:
2240       case BLOCKED_FETCH:
2241 # ifdef DIST
2242       case REMOTE_REF:
2243 # endif
2244       case FETCH_ME:
2245       case FETCH_ME_BQ:
2246 #endif
2247           // not evaluated yet
2248           break;
2249
2250       default:
2251         barf("eval_thunk_selector: strange selectee %d",
2252              (int)(info->type));
2253     }
2254
2255 bale_out:
2256     // We didn't manage to evaluate this thunk; restore the old info pointer
2257     SET_INFO(p, info_ptr);
2258     return NULL;
2259 }
2260
2261 /* -----------------------------------------------------------------------------
2262    move_TSO is called to update the TSO structure after it has been
2263    moved from one place to another.
2264    -------------------------------------------------------------------------- */
2265
2266 void
2267 move_TSO (StgTSO *src, StgTSO *dest)
2268 {
2269     ptrdiff_t diff;
2270
2271     // relocate the stack pointer...
2272     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2273     dest->sp = (StgPtr)dest->sp + diff;
2274 }
2275
2276 /* Similar to scavenge_large_bitmap(), but we don't write back the
2277  * pointers we get back from evacuate().
2278  */
2279 static void
2280 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2281 {
2282     nat i, b, size;
2283     StgWord bitmap;
2284     StgClosure **p;
2285
2286     b = 0;
2287     bitmap = large_srt->l.bitmap[b];
2288     size   = (nat)large_srt->l.size;
2289     p      = (StgClosure **)large_srt->srt;
2290     for (i = 0; i < size; ) {
2291         if ((bitmap & 1) != 0) {
2292             evacuate(*p);
2293         }
2294         i++;
2295         p++;
2296         if (i % BITS_IN(W_) == 0) {
2297             b++;
2298             bitmap = large_srt->l.bitmap[b];
2299         } else {
2300             bitmap = bitmap >> 1;
2301         }
2302     }
2303 }
2304
2305 /* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
2306  * srt field in the info table.  That's ok, because we'll
2307  * never dereference it.
2308  */
2309 STATIC_INLINE void
2310 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2311 {
2312   nat bitmap;
2313   StgClosure **p;
2314
2315   bitmap = srt_bitmap;
2316   p = srt;
2317
2318   if (bitmap == (StgHalfWord)(-1)) {
2319       scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2320       return;
2321   }
2322
2323   while (bitmap != 0) {
2324       if ((bitmap & 1) != 0) {
2325 #ifdef ENABLE_WIN32_DLL_SUPPORT
2326           // Special-case to handle references to closures hiding out in DLLs, since
2327           // double indirections required to get at those. The code generator knows
2328           // which is which when generating the SRT, so it stores the (indirect)
2329           // reference to the DLL closure in the table by first adding one to it.
2330           // We check for this here, and undo the addition before evacuating it.
2331           //
2332           // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2333           // closure that's fixed at link-time, and no extra magic is required.
2334           if ( (unsigned long)(*srt) & 0x1 ) {
2335               evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2336           } else {
2337               evacuate(*p);
2338           }
2339 #else
2340           evacuate(*p);
2341 #endif
2342       }
2343       p++;
2344       bitmap = bitmap >> 1;
2345   }
2346 }
2347
2348
2349 STATIC_INLINE void
2350 scavenge_thunk_srt(const StgInfoTable *info)
2351 {
2352     StgThunkInfoTable *thunk_info;
2353
2354     thunk_info = itbl_to_thunk_itbl(info);
2355     scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2356 }
2357
2358 STATIC_INLINE void
2359 scavenge_fun_srt(const StgInfoTable *info)
2360 {
2361     StgFunInfoTable *fun_info;
2362
2363     fun_info = itbl_to_fun_itbl(info);
2364     scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2365 }
2366
2367 /* -----------------------------------------------------------------------------
2368    Scavenge a TSO.
2369    -------------------------------------------------------------------------- */
2370
2371 static void
2372 scavengeTSO (StgTSO *tso)
2373 {
2374     // We don't chase the link field: TSOs on the blackhole queue are
2375     // not automatically alive, so the link field is a "weak" pointer.
2376     // Queues of TSOs are traversed explicitly.
2377
2378     if (   tso->why_blocked == BlockedOnMVar
2379         || tso->why_blocked == BlockedOnBlackHole
2380         || tso->why_blocked == BlockedOnException
2381 #if defined(PAR)
2382         || tso->why_blocked == BlockedOnGA
2383         || tso->why_blocked == BlockedOnGA_NoSend
2384 #endif
2385         ) {
2386         tso->block_info.closure = evacuate(tso->block_info.closure);
2387     }
2388     if ( tso->blocked_exceptions != NULL ) {
2389         tso->blocked_exceptions =
2390             (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2391     }
2392
2393     // scavange current transaction record
2394     tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2395
2396     // scavenge this thread's stack
2397     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2398 }
2399
2400 /* -----------------------------------------------------------------------------
2401    Blocks of function args occur on the stack (at the top) and
2402    in PAPs.
2403    -------------------------------------------------------------------------- */
2404
2405 STATIC_INLINE StgPtr
2406 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2407 {
2408     StgPtr p;
2409     StgWord bitmap;
2410     nat size;
2411
2412     p = (StgPtr)args;
2413     switch (fun_info->f.fun_type) {
2414     case ARG_GEN:
2415         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2416         size = BITMAP_SIZE(fun_info->f.b.bitmap);
2417         goto small_bitmap;
2418     case ARG_GEN_BIG:
2419         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2420         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2421         p += size;
2422         break;
2423     default:
2424         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2425         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2426     small_bitmap:
2427         while (size > 0) {
2428             if ((bitmap & 1) == 0) {
2429                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2430             }
2431             p++;
2432             bitmap = bitmap >> 1;
2433             size--;
2434         }
2435         break;
2436     }
2437     return p;
2438 }
2439
2440 STATIC_INLINE StgPtr
2441 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2442 {
2443     StgPtr p;
2444     StgWord bitmap;
2445     StgFunInfoTable *fun_info;
2446
2447     fun_info = get_fun_itbl(fun);
2448     ASSERT(fun_info->i.type != PAP);
2449     p = (StgPtr)payload;
2450
2451     switch (fun_info->f.fun_type) {
2452     case ARG_GEN:
2453         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2454         goto small_bitmap;
2455     case ARG_GEN_BIG:
2456         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2457         p += size;
2458         break;
2459     case ARG_BCO:
2460         scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2461         p += size;
2462         break;
2463     default:
2464         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2465     small_bitmap:
2466         while (size > 0) {
2467             if ((bitmap & 1) == 0) {
2468                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2469             }
2470             p++;
2471             bitmap = bitmap >> 1;
2472             size--;
2473         }
2474         break;
2475     }
2476     return p;
2477 }
2478
2479 STATIC_INLINE StgPtr
2480 scavenge_PAP (StgPAP *pap)
2481 {
2482     pap->fun = evacuate(pap->fun);
2483     return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2484 }
2485
2486 STATIC_INLINE StgPtr
2487 scavenge_AP (StgAP *ap)
2488 {
2489     ap->fun = evacuate(ap->fun);
2490     return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2491 }
2492
2493 /* -----------------------------------------------------------------------------
2494    Scavenge a given step until there are no more objects in this step
2495    to scavenge.
2496
2497    evac_gen is set by the caller to be either zero (for a step in a
2498    generation < N) or G where G is the generation of the step being
2499    scavenged.
2500
2501    We sometimes temporarily change evac_gen back to zero if we're
2502    scavenging a mutable object where early promotion isn't such a good
2503    idea.
2504    -------------------------------------------------------------------------- */
2505
2506 static void
2507 scavenge(step *stp)
2508 {
2509   StgPtr p, q;
2510   StgInfoTable *info;
2511   bdescr *bd;
2512   nat saved_evac_gen = evac_gen;
2513
2514   p = stp->scan;
2515   bd = stp->scan_bd;
2516
2517   failed_to_evac = rtsFalse;
2518
2519   /* scavenge phase - standard breadth-first scavenging of the
2520    * evacuated objects
2521    */
2522
2523   while (bd != stp->hp_bd || p < stp->hp) {
2524
2525     // If we're at the end of this block, move on to the next block
2526     if (bd != stp->hp_bd && p == bd->free) {
2527       bd = bd->link;
2528       p = bd->start;
2529       continue;
2530     }
2531
2532     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2533     info = get_itbl((StgClosure *)p);
2534
2535     ASSERT(thunk_selector_depth == 0);
2536
2537     q = p;
2538     switch (info->type) {
2539
2540     case MVAR:
2541     {
2542         StgMVar *mvar = ((StgMVar *)p);
2543         evac_gen = 0;
2544         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2545         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2546         mvar->value = evacuate((StgClosure *)mvar->value);
2547         evac_gen = saved_evac_gen;
2548         failed_to_evac = rtsTrue; // mutable.
2549         p += sizeofW(StgMVar);
2550         break;
2551     }
2552
2553     case FUN_2_0:
2554         scavenge_fun_srt(info);
2555         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2556         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2557         p += sizeofW(StgHeader) + 2;
2558         break;
2559
2560     case THUNK_2_0:
2561         scavenge_thunk_srt(info);
2562         ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2563         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2564         p += sizeofW(StgThunk) + 2;
2565         break;
2566
2567     case CONSTR_2_0:
2568         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2569         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2570         p += sizeofW(StgHeader) + 2;
2571         break;
2572
2573     case THUNK_1_0:
2574         scavenge_thunk_srt(info);
2575         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2576         p += sizeofW(StgThunk) + 1;
2577         break;
2578
2579     case FUN_1_0:
2580         scavenge_fun_srt(info);
2581     case CONSTR_1_0:
2582         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2583         p += sizeofW(StgHeader) + 1;
2584         break;
2585
2586     case THUNK_0_1:
2587         scavenge_thunk_srt(info);
2588         p += sizeofW(StgThunk) + 1;
2589         break;
2590
2591     case FUN_0_1:
2592         scavenge_fun_srt(info);
2593     case CONSTR_0_1:
2594         p += sizeofW(StgHeader) + 1;
2595         break;
2596
2597     case THUNK_0_2:
2598         scavenge_thunk_srt(info);
2599         p += sizeofW(StgThunk) + 2;
2600         break;
2601
2602     case FUN_0_2:
2603         scavenge_fun_srt(info);
2604     case CONSTR_0_2:
2605         p += sizeofW(StgHeader) + 2;
2606         break;
2607
2608     case THUNK_1_1:
2609         scavenge_thunk_srt(info);
2610         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2611         p += sizeofW(StgThunk) + 2;
2612         break;
2613
2614     case FUN_1_1:
2615         scavenge_fun_srt(info);
2616     case CONSTR_1_1:
2617         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2618         p += sizeofW(StgHeader) + 2;
2619         break;
2620
2621     case FUN:
2622         scavenge_fun_srt(info);
2623         goto gen_obj;
2624
2625     case THUNK:
2626     {
2627         StgPtr end;
2628
2629         scavenge_thunk_srt(info);
2630         end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2631         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2632             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2633         }
2634         p += info->layout.payload.nptrs;
2635         break;
2636     }
2637
2638     gen_obj:
2639     case CONSTR:
2640     case WEAK:
2641     case FOREIGN:
2642     case STABLE_NAME:
2643     {
2644         StgPtr end;
2645
2646         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2647         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2648             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2649         }
2650         p += info->layout.payload.nptrs;
2651         break;
2652     }
2653
2654     case BCO: {
2655         StgBCO *bco = (StgBCO *)p;
2656         bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2657         bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2658         bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2659         bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2660         p += bco_sizeW(bco);
2661         break;
2662     }
2663
2664     case IND_PERM:
2665       if (stp->gen->no != 0) {
2666 #ifdef PROFILING
2667         // @LDV profiling
2668         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2669         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2670         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2671 #endif
2672         //
2673         // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2674         //
2675         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2676
2677         // We pretend that p has just been created.
2678         LDV_RECORD_CREATE((StgClosure *)p);
2679       }
2680         // fall through
2681     case IND_OLDGEN_PERM:
2682         ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2683         p += sizeofW(StgInd);
2684         break;
2685
2686     case MUT_VAR:
2687         evac_gen = 0;
2688         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2689         evac_gen = saved_evac_gen;
2690         failed_to_evac = rtsTrue; // mutable anyhow
2691         p += sizeofW(StgMutVar);
2692         break;
2693
2694     case CAF_BLACKHOLE:
2695     case SE_CAF_BLACKHOLE:
2696     case SE_BLACKHOLE:
2697     case BLACKHOLE:
2698         p += BLACKHOLE_sizeW();
2699         break;
2700
2701     case THUNK_SELECTOR:
2702     {
2703         StgSelector *s = (StgSelector *)p;
2704         s->selectee = evacuate(s->selectee);
2705         p += THUNK_SELECTOR_sizeW();
2706         break;
2707     }
2708
2709     // A chunk of stack saved in a heap object
2710     case AP_STACK:
2711     {
2712         StgAP_STACK *ap = (StgAP_STACK *)p;
2713
2714         ap->fun = evacuate(ap->fun);
2715         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2716         p = (StgPtr)ap->payload + ap->size;
2717         break;
2718     }
2719
2720     case PAP:
2721         p = scavenge_PAP((StgPAP *)p);
2722         break;
2723
2724     case AP:
2725         p = scavenge_AP((StgAP *)p);
2726         break;
2727
2728     case ARR_WORDS:
2729         // nothing to follow
2730         p += arr_words_sizeW((StgArrWords *)p);
2731         break;
2732
2733     case MUT_ARR_PTRS:
2734         // follow everything
2735     {
2736         StgPtr next;
2737
2738         evac_gen = 0;           // repeatedly mutable
2739         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2740         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2741             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2742         }
2743         evac_gen = saved_evac_gen;
2744         failed_to_evac = rtsTrue; // mutable anyhow.
2745         break;
2746     }
2747
2748     case MUT_ARR_PTRS_FROZEN:
2749     case MUT_ARR_PTRS_FROZEN0:
2750         // follow everything
2751     {
2752         StgPtr next;
2753
2754         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2755         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2756             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2757         }
2758         // it's tempting to recordMutable() if failed_to_evac is
2759         // false, but that breaks some assumptions (eg. every
2760         // closure on the mutable list is supposed to have the MUT
2761         // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2762         break;
2763     }
2764
2765     case TSO:
2766     {
2767         StgTSO *tso = (StgTSO *)p;
2768         evac_gen = 0;
2769         scavengeTSO(tso);
2770         evac_gen = saved_evac_gen;
2771         failed_to_evac = rtsTrue; // mutable anyhow.
2772         p += tso_sizeW(tso);
2773         break;
2774     }
2775
2776 #if defined(PAR)
2777     case RBH:
2778     {
2779 #if 0
2780         nat size, ptrs, nonptrs, vhs;
2781         char str[80];
2782         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2783 #endif
2784         StgRBH *rbh = (StgRBH *)p;
2785         (StgClosure *)rbh->blocking_queue =
2786             evacuate((StgClosure *)rbh->blocking_queue);
2787         failed_to_evac = rtsTrue;  // mutable anyhow.
2788         IF_DEBUG(gc,
2789                  debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2790                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2791         // ToDo: use size of reverted closure here!
2792         p += BLACKHOLE_sizeW();
2793         break;
2794     }
2795
2796     case BLOCKED_FETCH:
2797     {
2798         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2799         // follow the pointer to the node which is being demanded
2800         (StgClosure *)bf->node =
2801             evacuate((StgClosure *)bf->node);
2802         // follow the link to the rest of the blocking queue
2803         (StgClosure *)bf->link =
2804             evacuate((StgClosure *)bf->link);
2805         IF_DEBUG(gc,
2806                  debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2807                        bf, info_type((StgClosure *)bf),
2808                        bf->node, info_type(bf->node)));
2809         p += sizeofW(StgBlockedFetch);
2810         break;
2811     }
2812
2813 #ifdef DIST
2814     case REMOTE_REF:
2815 #endif
2816     case FETCH_ME:
2817         p += sizeofW(StgFetchMe);
2818         break; // nothing to do in this case
2819
2820     case FETCH_ME_BQ:
2821     {
2822         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2823         (StgClosure *)fmbq->blocking_queue =
2824             evacuate((StgClosure *)fmbq->blocking_queue);
2825         IF_DEBUG(gc,
2826                  debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
2827                        p, info_type((StgClosure *)p)));
2828         p += sizeofW(StgFetchMeBlockingQueue);
2829         break;
2830     }
2831 #endif
2832
2833     case TVAR_WAIT_QUEUE:
2834       {
2835         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
2836         evac_gen = 0;
2837         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
2838         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
2839         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
2840         evac_gen = saved_evac_gen;
2841         failed_to_evac = rtsTrue; // mutable
2842         p += sizeofW(StgTVarWaitQueue);
2843         break;
2844       }
2845
2846     case TVAR:
2847       {
2848         StgTVar *tvar = ((StgTVar *) p);
2849         evac_gen = 0;
2850         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
2851         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
2852         evac_gen = saved_evac_gen;
2853         failed_to_evac = rtsTrue; // mutable
2854         p += sizeofW(StgTVar);
2855         break;
2856       }
2857
2858     case TREC_HEADER:
2859       {
2860         StgTRecHeader *trec = ((StgTRecHeader *) p);
2861         evac_gen = 0;
2862         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
2863         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
2864         evac_gen = saved_evac_gen;
2865         failed_to_evac = rtsTrue; // mutable
2866         p += sizeofW(StgTRecHeader);
2867         break;
2868       }
2869
2870     case TREC_CHUNK:
2871       {
2872         StgWord i;
2873         StgTRecChunk *tc = ((StgTRecChunk *) p);
2874         TRecEntry *e = &(tc -> entries[0]);
2875         evac_gen = 0;
2876         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
2877         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
2878           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
2879           e->expected_value = evacuate((StgClosure*)e->expected_value);
2880           e->new_value = evacuate((StgClosure*)e->new_value);
2881         }
2882         evac_gen = saved_evac_gen;
2883         failed_to_evac = rtsTrue; // mutable
2884         p += sizeofW(StgTRecChunk);
2885         break;
2886       }
2887
2888     default:
2889         barf("scavenge: unimplemented/strange closure type %d @ %p",
2890              info->type, p);
2891     }
2892
2893     /*
2894      * We need to record the current object on the mutable list if
2895      *  (a) It is actually mutable, or
2896      *  (b) It contains pointers to a younger generation.
2897      * Case (b) arises if we didn't manage to promote everything that
2898      * the current object points to into the current generation.
2899      */
2900     if (failed_to_evac) {
2901         failed_to_evac = rtsFalse;
2902         recordMutableGen((StgClosure *)q, stp->gen);
2903     }
2904   }
2905
2906   stp->scan_bd = bd;
2907   stp->scan = p;
2908 }
2909
2910 /* -----------------------------------------------------------------------------
2911    Scavenge everything on the mark stack.
2912
2913    This is slightly different from scavenge():
2914       - we don't walk linearly through the objects, so the scavenger
2915         doesn't need to advance the pointer on to the next object.
2916    -------------------------------------------------------------------------- */
2917
2918 static void
2919 scavenge_mark_stack(void)
2920 {
2921     StgPtr p, q;
2922     StgInfoTable *info;
2923     nat saved_evac_gen;
2924
2925     evac_gen = oldest_gen->no;
2926     saved_evac_gen = evac_gen;
2927
2928 linear_scan:
2929     while (!mark_stack_empty()) {
2930         p = pop_mark_stack();
2931
2932         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2933         info = get_itbl((StgClosure *)p);
2934
2935         q = p;
2936         switch (info->type) {
2937
2938         case MVAR:
2939         {
2940             StgMVar *mvar = ((StgMVar *)p);
2941             evac_gen = 0;
2942             mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2943             mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2944             mvar->value = evacuate((StgClosure *)mvar->value);
2945             evac_gen = saved_evac_gen;
2946             failed_to_evac = rtsTrue; // mutable.
2947             break;
2948         }
2949
2950         case FUN_2_0:
2951             scavenge_fun_srt(info);
2952             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2953             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2954             break;
2955
2956         case THUNK_2_0:
2957             scavenge_thunk_srt(info);
2958             ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2959             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2960             break;
2961
2962         case CONSTR_2_0:
2963             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2964             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2965             break;
2966
2967         case FUN_1_0:
2968         case FUN_1_1:
2969             scavenge_fun_srt(info);
2970             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2971             break;
2972
2973         case THUNK_1_0:
2974         case THUNK_1_1:
2975             scavenge_thunk_srt(info);
2976             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2977             break;
2978
2979         case CONSTR_1_0:
2980         case CONSTR_1_1:
2981             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2982             break;
2983
2984         case FUN_0_1:
2985         case FUN_0_2:
2986             scavenge_fun_srt(info);
2987             break;
2988
2989         case THUNK_0_1:
2990         case THUNK_0_2:
2991             scavenge_thunk_srt(info);
2992             break;
2993
2994         case CONSTR_0_1:
2995         case CONSTR_0_2:
2996             break;
2997
2998         case FUN:
2999             scavenge_fun_srt(info);
3000             goto gen_obj;
3001
3002         case THUNK:
3003         {
3004             StgPtr end;
3005
3006             scavenge_thunk_srt(info);
3007             end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3008             for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3009                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3010             }
3011             break;
3012         }
3013
3014         gen_obj:
3015         case CONSTR:
3016         case WEAK:
3017         case FOREIGN:
3018         case STABLE_NAME:
3019         {
3020             StgPtr end;
3021
3022             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3023             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3024                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3025             }
3026             break;
3027         }
3028
3029         case BCO: {
3030             StgBCO *bco = (StgBCO *)p;
3031             bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3032             bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3033             bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3034             bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3035             break;
3036         }
3037
3038         case IND_PERM:
3039             // don't need to do anything here: the only possible case
3040             // is that we're in a 1-space compacting collector, with
3041             // no "old" generation.
3042             break;
3043
3044         case IND_OLDGEN:
3045         case IND_OLDGEN_PERM:
3046             ((StgInd *)p)->indirectee =
3047                 evacuate(((StgInd *)p)->indirectee);
3048             break;
3049
3050         case MUT_VAR:
3051             evac_gen = 0;
3052             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3053             evac_gen = saved_evac_gen;
3054             failed_to_evac = rtsTrue;
3055             break;
3056
3057         case CAF_BLACKHOLE:
3058         case SE_CAF_BLACKHOLE:
3059         case SE_BLACKHOLE:
3060         case BLACKHOLE:
3061         case ARR_WORDS:
3062             break;
3063
3064         case THUNK_SELECTOR:
3065         {
3066             StgSelector *s = (StgSelector *)p;
3067             s->selectee = evacuate(s->selectee);
3068             break;
3069         }
3070
3071         // A chunk of stack saved in a heap object
3072         case AP_STACK:
3073         {
3074             StgAP_STACK *ap = (StgAP_STACK *)p;
3075
3076             ap->fun = evacuate(ap->fun);
3077             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3078             break;
3079         }
3080
3081         case PAP:
3082             scavenge_PAP((StgPAP *)p);
3083             break;
3084
3085         case AP:
3086             scavenge_AP((StgAP *)p);
3087             break;
3088
3089         case MUT_ARR_PTRS:
3090             // follow everything
3091         {
3092             StgPtr next;
3093
3094             evac_gen = 0;               // repeatedly mutable
3095             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3096             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3097                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3098             }
3099             evac_gen = saved_evac_gen;
3100             failed_to_evac = rtsTrue; // mutable anyhow.
3101             break;
3102         }
3103
3104         case MUT_ARR_PTRS_FROZEN:
3105         case MUT_ARR_PTRS_FROZEN0:
3106             // follow everything
3107         {
3108             StgPtr next;
3109
3110             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3111             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3112                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3113             }
3114             break;
3115         }
3116
3117         case TSO:
3118         {
3119             StgTSO *tso = (StgTSO *)p;
3120             evac_gen = 0;
3121             scavengeTSO(tso);
3122             evac_gen = saved_evac_gen;
3123             failed_to_evac = rtsTrue;
3124             break;
3125         }
3126
3127 #if defined(PAR)
3128         case RBH:
3129         {
3130 #if 0
3131             nat size, ptrs, nonptrs, vhs;
3132             char str[80];
3133             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3134 #endif
3135             StgRBH *rbh = (StgRBH *)p;
3136             bh->blocking_queue =
3137                 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3138             failed_to_evac = rtsTrue;  // mutable anyhow.
3139             IF_DEBUG(gc,
3140                      debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3141                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
3142             break;
3143         }
3144
3145         case BLOCKED_FETCH:
3146         {
3147             StgBlockedFetch *bf = (StgBlockedFetch *)p;
3148             // follow the pointer to the node which is being demanded
3149             (StgClosure *)bf->node =
3150                 evacuate((StgClosure *)bf->node);
3151             // follow the link to the rest of the blocking queue
3152             (StgClosure *)bf->link =
3153                 evacuate((StgClosure *)bf->link);
3154             IF_DEBUG(gc,
3155                      debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3156                            bf, info_type((StgClosure *)bf),
3157                            bf->node, info_type(bf->node)));
3158             break;
3159         }
3160
3161 #ifdef DIST
3162         case REMOTE_REF:
3163 #endif
3164         case FETCH_ME:
3165             break; // nothing to do in this case
3166
3167         case FETCH_ME_BQ:
3168         {
3169             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3170             (StgClosure *)fmbq->blocking_queue =
3171                 evacuate((StgClosure *)fmbq->blocking_queue);
3172             IF_DEBUG(gc,
3173                      debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3174                            p, info_type((StgClosure *)p)));
3175             break;
3176         }
3177 #endif /* PAR */
3178
3179         case TVAR_WAIT_QUEUE:
3180           {
3181             StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3182             evac_gen = 0;
3183             wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3184             wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3185             wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3186             evac_gen = saved_evac_gen;
3187             failed_to_evac = rtsTrue; // mutable
3188             break;
3189           }
3190
3191         case TVAR:
3192           {
3193             StgTVar *tvar = ((StgTVar *) p);
3194             evac_gen = 0;
3195             tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3196             tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3197             evac_gen = saved_evac_gen;
3198             failed_to_evac = rtsTrue; // mutable
3199             break;
3200           }
3201
3202         case TREC_CHUNK:
3203           {
3204             StgWord i;
3205             StgTRecChunk *tc = ((StgTRecChunk *) p);
3206             TRecEntry *e = &(tc -> entries[0]);
3207             evac_gen = 0;
3208             tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3209             for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3210               e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3211               e->expected_value = evacuate((StgClosure*)e->expected_value);
3212               e->new_value = evacuate((StgClosure*)e->new_value);
3213             }
3214             evac_gen = saved_evac_gen;
3215             failed_to_evac = rtsTrue; // mutable
3216             break;
3217           }
3218
3219         case TREC_HEADER:
3220           {
3221             StgTRecHeader *trec = ((StgTRecHeader *) p);
3222             evac_gen = 0;
3223             trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3224             trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3225             evac_gen = saved_evac_gen;
3226             failed_to_evac = rtsTrue; // mutable
3227             break;
3228           }
3229
3230         default:
3231             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3232                  info->type, p);
3233         }
3234
3235         if (failed_to_evac) {
3236             failed_to_evac = rtsFalse;
3237             recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3238         }
3239
3240         // mark the next bit to indicate "scavenged"
3241         mark(q+1, Bdescr(q));
3242
3243     } // while (!mark_stack_empty())
3244
3245     // start a new linear scan if the mark stack overflowed at some point
3246     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3247         IF_DEBUG(gc, debugBelch("scavenge_mark_stack: starting linear scan"));
3248         mark_stack_overflowed = rtsFalse;
3249         oldgen_scan_bd = oldest_gen->steps[0].blocks;
3250         oldgen_scan = oldgen_scan_bd->start;
3251     }
3252
3253     if (oldgen_scan_bd) {
3254         // push a new thing on the mark stack
3255     loop:
3256         // find a closure that is marked but not scavenged, and start
3257         // from there.
3258         while (oldgen_scan < oldgen_scan_bd->free
3259                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3260             oldgen_scan++;
3261         }
3262
3263         if (oldgen_scan < oldgen_scan_bd->free) {
3264
3265             // already scavenged?
3266             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3267                 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3268                 goto loop;
3269             }
3270             push_mark_stack(oldgen_scan);
3271             // ToDo: bump the linear scan by the actual size of the object
3272             oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3273             goto linear_scan;
3274         }
3275
3276         oldgen_scan_bd = oldgen_scan_bd->link;
3277         if (oldgen_scan_bd != NULL) {
3278             oldgen_scan = oldgen_scan_bd->start;
3279             goto loop;
3280         }
3281     }
3282 }
3283
3284 /* -----------------------------------------------------------------------------
3285    Scavenge one object.
3286
3287    This is used for objects that are temporarily marked as mutable
3288    because they contain old-to-new generation pointers.  Only certain
3289    objects can have this property.
3290    -------------------------------------------------------------------------- */
3291
3292 static rtsBool
3293 scavenge_one(StgPtr p)
3294 {
3295     const StgInfoTable *info;
3296     nat saved_evac_gen = evac_gen;
3297     rtsBool no_luck;
3298
3299     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3300     info = get_itbl((StgClosure *)p);
3301
3302     switch (info->type) {
3303
3304     case MVAR:
3305     {
3306         StgMVar *mvar = ((StgMVar *)p);
3307         evac_gen = 0;
3308         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3309         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3310         mvar->value = evacuate((StgClosure *)mvar->value);
3311         evac_gen = saved_evac_gen;
3312         failed_to_evac = rtsTrue; // mutable.
3313         break;
3314     }
3315
3316     case THUNK:
3317     case THUNK_1_0:
3318     case THUNK_0_1:
3319     case THUNK_1_1:
3320     case THUNK_0_2:
3321     case THUNK_2_0:
3322     {
3323         StgPtr q, end;
3324
3325         end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3326         for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3327             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3328         }
3329         break;
3330     }
3331
3332     case FUN:
3333     case FUN_1_0:                       // hardly worth specialising these guys
3334     case FUN_0_1:
3335     case FUN_1_1:
3336     case FUN_0_2:
3337     case FUN_2_0:
3338     case CONSTR:
3339     case CONSTR_1_0:
3340     case CONSTR_0_1:
3341     case CONSTR_1_1:
3342     case CONSTR_0_2:
3343     case CONSTR_2_0:
3344     case WEAK:
3345     case FOREIGN:
3346     case IND_PERM:
3347     {
3348         StgPtr q, end;
3349
3350         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3351         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3352             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3353         }
3354         break;
3355     }
3356
3357     case MUT_VAR:
3358         evac_gen = 0;
3359         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3360         evac_gen = saved_evac_gen;
3361         failed_to_evac = rtsTrue; // mutable anyhow
3362         break;
3363
3364     case CAF_BLACKHOLE:
3365     case SE_CAF_BLACKHOLE:
3366     case SE_BLACKHOLE:
3367     case BLACKHOLE:
3368         break;
3369
3370     case THUNK_SELECTOR:
3371     {
3372         StgSelector *s = (StgSelector *)p;
3373         s->selectee = evacuate(s->selectee);
3374         break;
3375     }
3376
3377     case AP_STACK:
3378     {
3379         StgAP_STACK *ap = (StgAP_STACK *)p;
3380
3381         ap->fun = evacuate(ap->fun);
3382         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3383         p = (StgPtr)ap->payload + ap->size;
3384         break;
3385     }
3386
3387     case PAP:
3388         p = scavenge_PAP((StgPAP *)p);
3389         break;
3390
3391     case AP:
3392         p = scavenge_AP((StgAP *)p);
3393         break;
3394
3395     case ARR_WORDS:
3396         // nothing to follow
3397         break;
3398
3399     case MUT_ARR_PTRS:
3400     {
3401         // follow everything
3402         StgPtr next;
3403
3404         evac_gen = 0;           // repeatedly mutable
3405         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3406         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3407             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3408         }
3409         evac_gen = saved_evac_gen;
3410         failed_to_evac = rtsTrue;
3411         break;
3412     }
3413
3414     case MUT_ARR_PTRS_FROZEN:
3415     case MUT_ARR_PTRS_FROZEN0:
3416     {
3417         // follow everything
3418         StgPtr next;
3419
3420         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3421         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3422             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3423         }
3424         break;
3425     }
3426
3427     case TSO:
3428     {
3429         StgTSO *tso = (StgTSO *)p;
3430
3431         evac_gen = 0;           // repeatedly mutable
3432         scavengeTSO(tso);
3433         evac_gen = saved_evac_gen;
3434         failed_to_evac = rtsTrue;
3435         break;
3436     }
3437
3438 #if defined(PAR)
3439     case RBH:
3440     {
3441 #if 0
3442         nat size, ptrs, nonptrs, vhs;
3443         char str[80];
3444         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3445 #endif
3446         StgRBH *rbh = (StgRBH *)p;
3447         (StgClosure *)rbh->blocking_queue =
3448             evacuate((StgClosure *)rbh->blocking_queue);
3449         failed_to_evac = rtsTrue;  // mutable anyhow.
3450         IF_DEBUG(gc,
3451                  debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3452                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
3453         // ToDo: use size of reverted closure here!
3454         break;
3455     }
3456
3457     case BLOCKED_FETCH:
3458     {
3459         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3460         // follow the pointer to the node which is being demanded
3461         (StgClosure *)bf->node =
3462             evacuate((StgClosure *)bf->node);
3463         // follow the link to the rest of the blocking queue
3464         (StgClosure *)bf->link =
3465             evacuate((StgClosure *)bf->link);
3466         IF_DEBUG(gc,
3467                  debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3468                        bf, info_type((StgClosure *)bf),
3469                        bf->node, info_type(bf->node)));
3470         break;
3471     }
3472
3473 #ifdef DIST
3474     case REMOTE_REF:
3475 #endif
3476     case FETCH_ME:
3477         break; // nothing to do in this case
3478
3479     case FETCH_ME_BQ:
3480     {
3481         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3482         (StgClosure *)fmbq->blocking_queue =
3483             evacuate((StgClosure *)fmbq->blocking_queue);
3484         IF_DEBUG(gc,
3485                  debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3486                        p, info_type((StgClosure *)p)));
3487         break;
3488     }
3489 #endif
3490
3491     case TVAR_WAIT_QUEUE:
3492       {
3493         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3494         evac_gen = 0;
3495         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3496         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3497         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3498         evac_gen = saved_evac_gen;
3499         failed_to_evac = rtsTrue; // mutable
3500         break;
3501       }
3502
3503     case TVAR:
3504       {
3505         StgTVar *tvar = ((StgTVar *) p);
3506         evac_gen = 0;
3507         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3508         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3509         evac_gen = saved_evac_gen;
3510         failed_to_evac = rtsTrue; // mutable
3511         break;
3512       }
3513
3514     case TREC_HEADER:
3515       {
3516         StgTRecHeader *trec = ((StgTRecHeader *) p);
3517         evac_gen = 0;
3518         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3519         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3520         evac_gen = saved_evac_gen;
3521         failed_to_evac = rtsTrue; // mutable
3522         break;
3523       }
3524
3525     case TREC_CHUNK:
3526       {
3527         StgWord i;
3528         StgTRecChunk *tc = ((StgTRecChunk *) p);
3529         TRecEntry *e = &(tc -> entries[0]);
3530         evac_gen = 0;
3531         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3532         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3533           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3534           e->expected_value = evacuate((StgClosure*)e->expected_value);
3535           e->new_value = evacuate((StgClosure*)e->new_value);
3536         }
3537         evac_gen = saved_evac_gen;
3538         failed_to_evac = rtsTrue; // mutable
3539         break;
3540       }
3541
3542     case IND_OLDGEN:
3543     case IND_OLDGEN_PERM:
3544     case IND_STATIC:
3545     {
3546         /* Careful here: a THUNK can be on the mutable list because
3547          * it contains pointers to young gen objects.  If such a thunk
3548          * is updated, the IND_OLDGEN will be added to the mutable
3549          * list again, and we'll scavenge it twice.  evacuate()
3550          * doesn't check whether the object has already been
3551          * evacuated, so we perform that check here.
3552          */
3553         StgClosure *q = ((StgInd *)p)->indirectee;
3554         if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
3555             break;
3556         }
3557         ((StgInd *)p)->indirectee = evacuate(q);
3558     }
3559
3560 #if 0 && defined(DEBUG)
3561       if (RtsFlags.DebugFlags.gc)
3562       /* Debugging code to print out the size of the thing we just
3563        * promoted
3564        */
3565       {
3566         StgPtr start = gen->steps[0].scan;
3567         bdescr *start_bd = gen->steps[0].scan_bd;
3568         nat size = 0;
3569         scavenge(&gen->steps[0]);
3570         if (start_bd != gen->steps[0].scan_bd) {
3571           size += (P_)BLOCK_ROUND_UP(start) - start;
3572           start_bd = start_bd->link;
3573           while (start_bd != gen->steps[0].scan_bd) {
3574             size += BLOCK_SIZE_W;
3575             start_bd = start_bd->link;
3576           }
3577           size += gen->steps[0].scan -
3578             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3579         } else {
3580           size = gen->steps[0].scan - start;
3581         }
3582         debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3583       }
3584 #endif
3585       break;
3586
3587     default:
3588         barf("scavenge_one: strange object %d", (int)(info->type));
3589     }
3590
3591     no_luck = failed_to_evac;
3592     failed_to_evac = rtsFalse;
3593     return (no_luck);
3594 }
3595
3596 /* -----------------------------------------------------------------------------
3597    Scavenging mutable lists.
3598
3599    We treat the mutable list of each generation > N (i.e. all the
3600    generations older than the one being collected) as roots.  We also
3601    remove non-mutable objects from the mutable list at this point.
3602    -------------------------------------------------------------------------- */
3603
3604 static void
3605 scavenge_mutable_list(generation *gen)
3606 {
3607     bdescr *bd;
3608     StgPtr p, q;
3609
3610     bd = gen->saved_mut_list;
3611
3612     evac_gen = gen->no;
3613     for (; bd != NULL; bd = bd->link) {
3614         for (q = bd->start; q < bd->free; q++) {
3615             p = (StgPtr)*q;
3616             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3617             if (scavenge_one(p)) {
3618                 /* didn't manage to promote everything, so put the
3619                  * object back on the list.
3620                  */
3621                 recordMutableGen((StgClosure *)p,gen);
3622             }
3623         }
3624     }
3625
3626     // free the old mut_list
3627     freeChain(gen->saved_mut_list);
3628     gen->saved_mut_list = NULL;
3629 }
3630
3631
3632 static void
3633 scavenge_static(void)
3634 {
3635   StgClosure* p = static_objects;
3636   const StgInfoTable *info;
3637
3638   /* Always evacuate straight to the oldest generation for static
3639    * objects */
3640   evac_gen = oldest_gen->no;
3641
3642   /* keep going until we've scavenged all the objects on the linked
3643      list... */
3644   while (p != END_OF_STATIC_LIST) {
3645
3646     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3647     info = get_itbl(p);
3648     /*
3649     if (info->type==RBH)
3650       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3651     */
3652     // make sure the info pointer is into text space
3653
3654     /* Take this object *off* the static_objects list,
3655      * and put it on the scavenged_static_objects list.
3656      */
3657     static_objects = *STATIC_LINK(info,p);
3658     *STATIC_LINK(info,p) = scavenged_static_objects;
3659     scavenged_static_objects = p;
3660
3661     switch (info -> type) {
3662
3663     case IND_STATIC:
3664       {
3665         StgInd *ind = (StgInd *)p;
3666         ind->indirectee = evacuate(ind->indirectee);
3667
3668         /* might fail to evacuate it, in which case we have to pop it
3669          * back on the mutable list of the oldest generation.  We
3670          * leave it *on* the scavenged_static_objects list, though,
3671          * in case we visit this object again.
3672          */
3673         if (failed_to_evac) {
3674           failed_to_evac = rtsFalse;
3675           recordMutableGen((StgClosure *)p,oldest_gen);
3676         }
3677         break;
3678       }
3679
3680     case THUNK_STATIC:
3681       scavenge_thunk_srt(info);
3682       break;
3683
3684     case FUN_STATIC:
3685       scavenge_fun_srt(info);
3686       break;
3687
3688     case CONSTR_STATIC:
3689       {
3690         StgPtr q, next;
3691
3692         next = (P_)p->payload + info->layout.payload.ptrs;
3693         // evacuate the pointers
3694         for (q = (P_)p->payload; q < next; q++) {
3695             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3696         }
3697         break;
3698       }
3699
3700     default:
3701       barf("scavenge_static: strange closure %d", (int)(info->type));
3702     }
3703
3704     ASSERT(failed_to_evac == rtsFalse);
3705
3706     /* get the next static object from the list.  Remember, there might
3707      * be more stuff on this list now that we've done some evacuating!
3708      * (static_objects is a global)
3709      */
3710     p = static_objects;
3711   }
3712 }
3713
3714 /* -----------------------------------------------------------------------------
3715    scavenge a chunk of memory described by a bitmap
3716    -------------------------------------------------------------------------- */
3717
3718 static void
3719 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
3720 {
3721     nat i, b;
3722     StgWord bitmap;
3723
3724     b = 0;
3725     bitmap = large_bitmap->bitmap[b];
3726     for (i = 0; i < size; ) {
3727         if ((bitmap & 1) == 0) {
3728             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3729         }
3730         i++;
3731         p++;
3732         if (i % BITS_IN(W_) == 0) {
3733             b++;
3734             bitmap = large_bitmap->bitmap[b];
3735         } else {
3736             bitmap = bitmap >> 1;
3737         }
3738     }
3739 }
3740
3741 STATIC_INLINE StgPtr
3742 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
3743 {
3744     while (size > 0) {
3745         if ((bitmap & 1) == 0) {
3746             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3747         }
3748         p++;
3749         bitmap = bitmap >> 1;
3750         size--;
3751     }
3752     return p;
3753 }
3754
3755 /* -----------------------------------------------------------------------------
3756    scavenge_stack walks over a section of stack and evacuates all the
3757    objects pointed to by it.  We can use the same code for walking
3758    AP_STACK_UPDs, since these are just sections of copied stack.
3759    -------------------------------------------------------------------------- */
3760
3761
3762 static void
3763 scavenge_stack(StgPtr p, StgPtr stack_end)
3764 {
3765   const StgRetInfoTable* info;
3766   StgWord bitmap;
3767   nat size;
3768
3769   //IF_DEBUG(sanity, debugBelch("  scavenging stack between %p and %p", p, stack_end));
3770
3771   /*
3772    * Each time around this loop, we are looking at a chunk of stack
3773    * that starts with an activation record.
3774    */
3775
3776   while (p < stack_end) {
3777     info  = get_ret_itbl((StgClosure *)p);
3778
3779     switch (info->i.type) {
3780
3781     case UPDATE_FRAME:
3782         ((StgUpdateFrame *)p)->updatee
3783             = evacuate(((StgUpdateFrame *)p)->updatee);
3784         p += sizeofW(StgUpdateFrame);
3785         continue;
3786
3787       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3788     case CATCH_STM_FRAME:
3789     case CATCH_RETRY_FRAME:
3790     case ATOMICALLY_FRAME:
3791     case STOP_FRAME:
3792     case CATCH_FRAME:
3793     case RET_SMALL:
3794     case RET_VEC_SMALL:
3795         bitmap = BITMAP_BITS(info->i.layout.bitmap);
3796         size   = BITMAP_SIZE(info->i.layout.bitmap);
3797         // NOTE: the payload starts immediately after the info-ptr, we
3798         // don't have an StgHeader in the same sense as a heap closure.
3799         p++;
3800         p = scavenge_small_bitmap(p, size, bitmap);
3801
3802     follow_srt:
3803         scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
3804         continue;
3805
3806     case RET_BCO: {
3807         StgBCO *bco;
3808         nat size;
3809
3810         p++;
3811         *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3812         bco = (StgBCO *)*p;
3813         p++;
3814         size = BCO_BITMAP_SIZE(bco);
3815         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
3816         p += size;
3817         continue;
3818     }
3819
3820       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3821     case RET_BIG:
3822     case RET_VEC_BIG:
3823     {
3824         nat size;
3825
3826         size = GET_LARGE_BITMAP(&info->i)->size;
3827         p++;
3828         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
3829         p += size;
3830         // and don't forget to follow the SRT
3831         goto follow_srt;
3832     }
3833
3834       // Dynamic bitmap: the mask is stored on the stack, and
3835       // there are a number of non-pointers followed by a number
3836       // of pointers above the bitmapped area.  (see StgMacros.h,
3837       // HEAP_CHK_GEN).
3838     case RET_DYN:
3839     {
3840         StgWord dyn;
3841         dyn = ((StgRetDyn *)p)->liveness;
3842
3843         // traverse the bitmap first
3844         bitmap = RET_DYN_LIVENESS(dyn);
3845         p      = (P_)&((StgRetDyn *)p)->payload[0];
3846         size   = RET_DYN_BITMAP_SIZE;
3847         p = scavenge_small_bitmap(p, size, bitmap);
3848
3849         // skip over the non-ptr words
3850         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
3851
3852         // follow the ptr words
3853         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
3854             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3855             p++;
3856         }
3857         continue;
3858     }
3859
3860     case RET_FUN:
3861     {
3862         StgRetFun *ret_fun = (StgRetFun *)p;
3863         StgFunInfoTable *fun_info;
3864
3865         ret_fun->fun = evacuate(ret_fun->fun);
3866         fun_info = get_fun_itbl(ret_fun->fun);
3867         p = scavenge_arg_block(fun_info, ret_fun->payload);
3868         goto follow_srt;
3869     }
3870
3871     default:
3872         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
3873     }
3874   }
3875 }
3876
3877 /*-----------------------------------------------------------------------------
3878   scavenge the large object list.
3879
3880   evac_gen set by caller; similar games played with evac_gen as with
3881   scavenge() - see comment at the top of scavenge().  Most large
3882   objects are (repeatedly) mutable, so most of the time evac_gen will
3883   be zero.
3884   --------------------------------------------------------------------------- */
3885
3886 static void
3887 scavenge_large(step *stp)
3888 {
3889   bdescr *bd;
3890   StgPtr p;
3891
3892   bd = stp->new_large_objects;
3893
3894   for (; bd != NULL; bd = stp->new_large_objects) {
3895
3896     /* take this object *off* the large objects list and put it on
3897      * the scavenged large objects list.  This is so that we can
3898      * treat new_large_objects as a stack and push new objects on
3899      * the front when evacuating.
3900      */
3901     stp->new_large_objects = bd->link;
3902     dbl_link_onto(bd, &stp->scavenged_large_objects);
3903
3904     // update the block count in this step.
3905     stp->n_scavenged_large_blocks += bd->blocks;
3906
3907     p = bd->start;
3908     if (scavenge_one(p)) {
3909         recordMutableGen((StgClosure *)p, stp->gen);
3910     }
3911   }
3912 }
3913
3914 /* -----------------------------------------------------------------------------
3915    Initialising the static object & mutable lists
3916    -------------------------------------------------------------------------- */
3917
3918 static void
3919 zero_static_object_list(StgClosure* first_static)
3920 {
3921   StgClosure* p;
3922   StgClosure* link;
3923   const StgInfoTable *info;
3924
3925   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3926     info = get_itbl(p);
3927     link = *STATIC_LINK(info, p);
3928     *STATIC_LINK(info,p) = NULL;
3929   }
3930 }
3931
3932 /* -----------------------------------------------------------------------------
3933    Reverting CAFs
3934    -------------------------------------------------------------------------- */
3935
3936 void
3937 revertCAFs( void )
3938 {
3939     StgIndStatic *c;
3940
3941     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
3942          c = (StgIndStatic *)c->static_link)
3943     {
3944         SET_INFO(c, c->saved_info);
3945         c->saved_info = NULL;
3946         // could, but not necessary: c->static_link = NULL;
3947     }
3948     revertible_caf_list = NULL;
3949 }
3950
3951 void
3952 markCAFs( evac_fn evac )
3953 {
3954     StgIndStatic *c;
3955
3956     for (c = (StgIndStatic *)caf_list; c != NULL;
3957          c = (StgIndStatic *)c->static_link)
3958     {
3959         evac(&c->indirectee);
3960     }
3961     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
3962          c = (StgIndStatic *)c->static_link)
3963     {
3964         evac(&c->indirectee);
3965     }
3966 }
3967
3968 /* -----------------------------------------------------------------------------
3969    Sanity code for CAF garbage collection.
3970
3971    With DEBUG turned on, we manage a CAF list in addition to the SRT
3972    mechanism.  After GC, we run down the CAF list and blackhole any
3973    CAFs which have been garbage collected.  This means we get an error
3974    whenever the program tries to enter a garbage collected CAF.
3975
3976    Any garbage collected CAFs are taken off the CAF list at the same
3977    time.
3978    -------------------------------------------------------------------------- */
3979
3980 #if 0 && defined(DEBUG)
3981
3982 static void
3983 gcCAFs(void)
3984 {
3985   StgClosure*  p;
3986   StgClosure** pp;
3987   const StgInfoTable *info;
3988   nat i;
3989
3990   i = 0;
3991   p = caf_list;
3992   pp = &caf_list;
3993
3994   while (p != NULL) {
3995
3996     info = get_itbl(p);
3997
3998     ASSERT(info->type == IND_STATIC);
3999
4000     if (STATIC_LINK(info,p) == NULL) {
4001       IF_DEBUG(gccafs, debugBelch("CAF gc'd at 0x%04lx", (long)p));
4002       // black hole it
4003       SET_INFO(p,&stg_BLACKHOLE_info);
4004       p = STATIC_LINK2(info,p);
4005       *pp = p;
4006     }
4007     else {
4008       pp = &STATIC_LINK2(info,p);
4009       p = *pp;
4010       i++;
4011     }
4012
4013   }
4014
4015   //  debugBelch("%d CAFs live", i);
4016 }
4017 #endif
4018
4019
4020 /* -----------------------------------------------------------------------------
4021    Lazy black holing.
4022
4023    Whenever a thread returns to the scheduler after possibly doing
4024    some work, we have to run down the stack and black-hole all the
4025    closures referred to by update frames.
4026    -------------------------------------------------------------------------- */
4027
4028 static void
4029 threadLazyBlackHole(StgTSO *tso)
4030 {
4031     StgClosure *frame;
4032     StgRetInfoTable *info;
4033     StgClosure *bh;
4034     StgPtr stack_end;
4035
4036     stack_end = &tso->stack[tso->stack_size];
4037
4038     frame = (StgClosure *)tso->sp;
4039
4040     while (1) {
4041         info = get_ret_itbl(frame);
4042
4043         switch (info->i.type) {
4044
4045         case UPDATE_FRAME:
4046             bh = ((StgUpdateFrame *)frame)->updatee;
4047
4048             /* if the thunk is already blackholed, it means we've also
4049              * already blackholed the rest of the thunks on this stack,
4050              * so we can stop early.
4051              *
4052              * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
4053              * don't interfere with this optimisation.
4054              */
4055             if (bh->header.info == &stg_BLACKHOLE_info) {
4056                 return;
4057             }
4058
4059             if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
4060 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4061                 debugBelch("Unexpected lazy BHing required at 0x%04x\n",(int)bh);
4062 #endif
4063 #ifdef PROFILING
4064                 // @LDV profiling
4065                 // We pretend that bh is now dead.
4066                 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4067 #endif
4068                 SET_INFO(bh,&stg_BLACKHOLE_info);
4069
4070                 // We pretend that bh has just been created.
4071                 LDV_RECORD_CREATE(bh);
4072             }
4073
4074             frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4075             break;
4076
4077         case STOP_FRAME:
4078             return;
4079
4080             // normal stack frames; do nothing except advance the pointer
4081         default:
4082             frame = (StgClosure *)((StgPtr)frame + stack_frame_sizeW(frame));
4083         }
4084     }
4085 }
4086
4087
4088 /* -----------------------------------------------------------------------------
4089  * Stack squeezing
4090  *
4091  * Code largely pinched from old RTS, then hacked to bits.  We also do
4092  * lazy black holing here.
4093  *
4094  * -------------------------------------------------------------------------- */
4095
4096 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4097
4098 static void
4099 threadSqueezeStack(StgTSO *tso)
4100 {
4101     StgPtr frame;
4102     rtsBool prev_was_update_frame;
4103     StgClosure *updatee = NULL;
4104     StgPtr bottom;
4105     StgRetInfoTable *info;
4106     StgWord current_gap_size;
4107     struct stack_gap *gap;
4108
4109     // Stage 1:
4110     //    Traverse the stack upwards, replacing adjacent update frames
4111     //    with a single update frame and a "stack gap".  A stack gap
4112     //    contains two values: the size of the gap, and the distance
4113     //    to the next gap (or the stack top).
4114
4115     bottom = &(tso->stack[tso->stack_size]);
4116
4117     frame = tso->sp;
4118
4119     ASSERT(frame < bottom);
4120
4121     prev_was_update_frame = rtsFalse;
4122     current_gap_size = 0;
4123     gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4124
4125     while (frame < bottom) {
4126
4127         info = get_ret_itbl((StgClosure *)frame);
4128         switch (info->i.type) {
4129
4130         case UPDATE_FRAME:
4131         {
4132             StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4133
4134             if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
4135
4136                 // found a BLACKHOLE'd update frame; we've been here
4137                 // before, in a previous GC, so just break out.
4138
4139                 // Mark the end of the gap, if we're in one.
4140                 if (current_gap_size != 0) {
4141                     gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
4142                 }
4143
4144                 frame += sizeofW(StgUpdateFrame);
4145                 goto done_traversing;
4146             }
4147
4148             if (prev_was_update_frame) {
4149
4150                 TICK_UPD_SQUEEZED();
4151                 /* wasn't there something about update squeezing and ticky to be
4152                  * sorted out?  oh yes: we aren't counting each enter properly
4153                  * in this case.  See the log somewhere.  KSW 1999-04-21
4154                  *
4155                  * Check two things: that the two update frames don't point to
4156                  * the same object, and that the updatee_bypass isn't already an
4157                  * indirection.  Both of these cases only happen when we're in a
4158                  * block hole-style loop (and there are multiple update frames
4159                  * on the stack pointing to the same closure), but they can both
4160                  * screw us up if we don't check.
4161                  */
4162                 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4163                     UPD_IND_NOLOCK(upd->updatee, updatee);
4164                 }
4165
4166                 // now mark this update frame as a stack gap.  The gap
4167                 // marker resides in the bottom-most update frame of
4168                 // the series of adjacent frames, and covers all the
4169                 // frames in this series.
4170                 current_gap_size += sizeofW(StgUpdateFrame);
4171                 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4172                 ((struct stack_gap *)frame)->next_gap = gap;
4173
4174                 frame += sizeofW(StgUpdateFrame);
4175                 continue;
4176             }
4177
4178             // single update frame, or the topmost update frame in a series
4179             else {
4180                 StgClosure *bh = upd->updatee;
4181
4182                 // Do lazy black-holing
4183                 if (bh->header.info != &stg_BLACKHOLE_info &&
4184                     bh->header.info != &stg_CAF_BLACKHOLE_info) {
4185 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4186                     debugBelch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4187 #endif
4188 #ifdef DEBUG
4189                     /* zero out the slop so that the sanity checker can tell
4190                      * where the next closure is.
4191                      */
4192                     {
4193                         StgInfoTable *bh_info = get_itbl(bh);
4194                         nat np = bh_info->layout.payload.ptrs,
4195                             nw = bh_info->layout.payload.nptrs, i;
4196                         /* don't zero out slop for a THUNK_SELECTOR,
4197                          * because its layout info is used for a
4198                          * different purpose, and it's exactly the
4199                          * same size as a BLACKHOLE in any case.
4200                          */
4201                         if (bh_info->type != THUNK_SELECTOR) {
4202                             for (i = 0; i < np + nw; i++) {
4203                                 ((StgClosure *)bh)->payload[i] = INVALID_OBJECT;
4204                             }
4205                         }
4206                     }
4207 #endif
4208 #ifdef PROFILING
4209                     // We pretend that bh is now dead.
4210                     LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4211 #endif
4212                     // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
4213                     SET_INFO(bh,&stg_BLACKHOLE_info);
4214
4215                     // We pretend that bh has just been created.
4216                     LDV_RECORD_CREATE(bh);
4217                 }
4218
4219                 prev_was_update_frame = rtsTrue;
4220                 updatee = upd->updatee;
4221                 frame += sizeofW(StgUpdateFrame);
4222                 continue;
4223             }
4224         }
4225
4226         default:
4227             prev_was_update_frame = rtsFalse;
4228
4229             // we're not in a gap... check whether this is the end of a gap
4230             // (an update frame can't be the end of a gap).
4231             if (current_gap_size != 0) {
4232                 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4233             }
4234             current_gap_size = 0;
4235
4236             frame += stack_frame_sizeW((StgClosure *)frame);
4237             continue;
4238         }
4239     }
4240
4241 done_traversing:
4242
4243     // Now we have a stack with gaps in it, and we have to walk down
4244     // shoving the stack up to fill in the gaps.  A diagram might
4245     // help:
4246     //
4247     //    +| ********* |
4248     //     | ********* | <- sp
4249     //     |           |
4250     //     |           | <- gap_start
4251     //     | ......... |                |
4252     //     | stack_gap | <- gap         | chunk_size
4253     //     | ......... |                |
4254     //     | ......... | <- gap_end     v
4255     //     | ********* |
4256     //     | ********* |
4257     //     | ********* |
4258     //    -| ********* |
4259     //
4260     // 'sp'  points the the current top-of-stack
4261     // 'gap' points to the stack_gap structure inside the gap
4262     // *****   indicates real stack data
4263     // .....   indicates gap
4264     // <empty> indicates unused
4265     //
4266     {
4267         void *sp;
4268         void *gap_start, *next_gap_start, *gap_end;
4269         nat chunk_size;
4270
4271         next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4272         sp = next_gap_start;
4273
4274         while ((StgPtr)gap > tso->sp) {
4275
4276             // we're working in *bytes* now...
4277             gap_start = next_gap_start;
4278             gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4279
4280             gap = gap->next_gap;
4281             next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4282
4283             chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4284             sp -= chunk_size;
4285             memmove(sp, next_gap_start, chunk_size);
4286         }
4287
4288         tso->sp = (StgPtr)sp;
4289     }
4290 }
4291
4292 /* -----------------------------------------------------------------------------
4293  * Pausing a thread
4294  *
4295  * We have to prepare for GC - this means doing lazy black holing
4296  * here.  We also take the opportunity to do stack squeezing if it's
4297  * turned on.
4298  * -------------------------------------------------------------------------- */
4299 void
4300 threadPaused(StgTSO *tso)
4301 {
4302   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4303     threadSqueezeStack(tso);    // does black holing too
4304   else
4305     threadLazyBlackHole(tso);
4306 }
4307
4308 /* -----------------------------------------------------------------------------
4309  * Debugging
4310  * -------------------------------------------------------------------------- */
4311
4312 #if DEBUG
4313 void
4314 printMutableList(generation *gen)
4315 {
4316     bdescr *bd;
4317     StgPtr p;
4318
4319     debugBelch("@@ Mutable list %p: ", gen->mut_list);
4320
4321     for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
4322         for (p = bd->start; p < bd->free; p++) {
4323             debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
4324         }
4325     }
4326     debugBelch("\n");
4327 }
4328 #endif /* DEBUG */