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