ghc/rts/GC.c

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