ghc/rts/GC.c

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