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             StgClosure *val;
1981             // q is still BLACKHOLE'd.
1982             thunk_selector_depth++;
1983             val = evacuate(p);
1984             thunk_selector_depth--;
1985
1986             // Update the THUNK_SELECTOR with an indirection to the
1987             // EVACUATED closure now at p.  Why do this rather than
1988             // upd_evacuee(q,p)?  Because we have an invariant that an
1989             // EVACUATED closure always points to an object in the
1990             // same or an older generation (required by the short-cut
1991             // test in the EVACUATED case, below).
1992             SET_INFO(q, &stg_IND_info);
1993             ((StgInd *)q)->indirectee = p;
1994
1995 #ifdef PROFILING
1996             // We store the size of the just evacuated object in the
1997             // LDV word so that the profiler can guess the position of
1998             // the next object later.
1999             SET_EVACUAEE_FOR_LDV(q, THUNK_SELECTOR_sizeW());
2000 #endif
2001             return val;
2002         }
2003     }
2004
2005   case IND:
2006   case IND_OLDGEN:
2007     // follow chains of indirections, don't evacuate them
2008     q = ((StgInd*)q)->indirectee;
2009     goto loop;
2010
2011   case RET_BCO:
2012   case RET_SMALL:
2013   case RET_VEC_SMALL:
2014   case RET_BIG:
2015   case RET_VEC_BIG:
2016   case RET_DYN:
2017   case UPDATE_FRAME:
2018   case STOP_FRAME:
2019   case CATCH_FRAME:
2020   case CATCH_STM_FRAME:
2021   case CATCH_RETRY_FRAME:
2022   case ATOMICALLY_FRAME:
2023     // shouldn't see these
2024     barf("evacuate: stack frame at %p\n", q);
2025
2026   case PAP:
2027       return copy(q,pap_sizeW((StgPAP*)q),stp);
2028
2029   case AP:
2030       return copy(q,ap_sizeW((StgAP*)q),stp);
2031
2032   case AP_STACK:
2033       return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
2034
2035   case EVACUATED:
2036     /* Already evacuated, just return the forwarding address.
2037      * HOWEVER: if the requested destination generation (evac_gen) is
2038      * older than the actual generation (because the object was
2039      * already evacuated to a younger generation) then we have to
2040      * set the failed_to_evac flag to indicate that we couldn't
2041      * manage to promote the object to the desired generation.
2042      */
2043     /*
2044      * Optimisation: the check is fairly expensive, but we can often
2045      * shortcut it if either the required generation is 0, or the
2046      * current object (the EVACUATED) is in a high enough generation.
2047      * We know that an EVACUATED always points to an object in the
2048      * same or an older generation.  stp is the lowest step that the
2049      * current object would be evacuated to, so we only do the full
2050      * check if stp is too low.
2051      */
2052     if (evac_gen > 0 && stp->gen_no < evac_gen) {  // optimisation
2053       StgClosure *p = ((StgEvacuated*)q)->evacuee;
2054       if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
2055         failed_to_evac = rtsTrue;
2056         TICK_GC_FAILED_PROMOTION();
2057       }
2058     }
2059     return ((StgEvacuated*)q)->evacuee;
2060
2061   case ARR_WORDS:
2062       // just copy the block
2063       return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp);
2064
2065   case MUT_ARR_PTRS:
2066   case MUT_ARR_PTRS_FROZEN:
2067   case MUT_ARR_PTRS_FROZEN0:
2068       // just copy the block
2069       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
2070
2071   case TSO:
2072     {
2073       StgTSO *tso = (StgTSO *)q;
2074
2075       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
2076        */
2077       if (tso->what_next == ThreadRelocated) {
2078         q = (StgClosure *)tso->link;
2079         goto loop;
2080       }
2081
2082       /* To evacuate a small TSO, we need to relocate the update frame
2083        * list it contains.
2084        */
2085       {
2086           StgTSO *new_tso;
2087           StgPtr p, q;
2088
2089           new_tso = (StgTSO *)copyPart((StgClosure *)tso,
2090                                        tso_sizeW(tso),
2091                                        sizeofW(StgTSO), stp);
2092           move_TSO(tso, new_tso);
2093           for (p = tso->sp, q = new_tso->sp;
2094                p < tso->stack+tso->stack_size;) {
2095               *q++ = *p++;
2096           }
2097
2098           return (StgClosure *)new_tso;
2099       }
2100     }
2101
2102 #if defined(PAR)
2103   case RBH:
2104     {
2105       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
2106       to = copy(q,BLACKHOLE_sizeW(),stp);
2107       //ToDo: derive size etc from reverted IP
2108       //to = copy(q,size,stp);
2109       IF_DEBUG(gc,
2110                debugBelch("@@ evacuate: RBH %p (%s) to %p (%s)",
2111                      q, info_type(q), to, info_type(to)));
2112       return to;
2113     }
2114
2115   case BLOCKED_FETCH:
2116     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
2117     to = copy(q,sizeofW(StgBlockedFetch),stp);
2118     IF_DEBUG(gc,
2119              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2120                    q, info_type(q), to, info_type(to)));
2121     return to;
2122
2123 # ifdef DIST
2124   case REMOTE_REF:
2125 # endif
2126   case FETCH_ME:
2127     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
2128     to = copy(q,sizeofW(StgFetchMe),stp);
2129     IF_DEBUG(gc,
2130              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2131                    q, info_type(q), to, info_type(to)));
2132     return to;
2133
2134   case FETCH_ME_BQ:
2135     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
2136     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2137     IF_DEBUG(gc,
2138              debugBelch("@@ evacuate: %p (%s) to %p (%s)",
2139                    q, info_type(q), to, info_type(to)));
2140     return to;
2141 #endif
2142
2143   case TREC_HEADER:
2144     return copy(q,sizeofW(StgTRecHeader),stp);
2145
2146   case TVAR_WAIT_QUEUE:
2147     return copy(q,sizeofW(StgTVarWaitQueue),stp);
2148
2149   case TVAR:
2150     return copy(q,sizeofW(StgTVar),stp);
2151
2152   case TREC_CHUNK:
2153     return copy(q,sizeofW(StgTRecChunk),stp);
2154
2155   default:
2156     barf("evacuate: strange closure type %d", (int)(info->type));
2157   }
2158
2159   barf("evacuate");
2160 }
2161
2162 /* -----------------------------------------------------------------------------
2163    Evaluate a THUNK_SELECTOR if possible.
2164
2165    returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2166    a closure pointer if we evaluated it and this is the result.  Note
2167    that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2168    reducing it to HNF, just that we have eliminated the selection.
2169    The result might be another thunk, or even another THUNK_SELECTOR.
2170
2171    If the return value is non-NULL, the original selector thunk has
2172    been BLACKHOLE'd, and should be updated with an indirection or a
2173    forwarding pointer.  If the return value is NULL, then the selector
2174    thunk is unchanged.
2175
2176    ***
2177    ToDo: the treatment of THUNK_SELECTORS could be improved in the
2178    following way (from a suggestion by Ian Lynagh):
2179
2180    We can have a chain like this:
2181
2182       sel_0 --> (a,b)
2183                  |
2184                  |-----> sel_0 --> (a,b)
2185                                     |
2186                                     |-----> sel_0 --> ...
2187
2188    and the depth limit means we don't go all the way to the end of the
2189    chain, which results in a space leak.  This affects the recursive
2190    call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2191    the recursive call to eval_thunk_selector() in
2192    eval_thunk_selector().
2193
2194    We could eliminate the depth bound in this case, in the following
2195    way:
2196
2197       - traverse the chain once to discover the *value* of the
2198         THUNK_SELECTOR.  Mark all THUNK_SELECTORS that we
2199         visit on the way as having been visited already (somehow).
2200
2201       - in a second pass, traverse the chain again updating all
2202         THUNK_SEELCTORS that we find on the way with indirections to
2203         the value.
2204
2205       - if we encounter a "marked" THUNK_SELECTOR in a normal
2206         evacuate(), we konw it can't be updated so just evac it.
2207
2208    Program that illustrates the problem:
2209
2210         foo [] = ([], [])
2211         foo (x:xs) = let (ys, zs) = foo xs
2212                      in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2213
2214         main = bar [1..(100000000::Int)]
2215         bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2216
2217    -------------------------------------------------------------------------- */
2218
2219 static inline rtsBool
2220 is_to_space ( StgClosure *p )
2221 {
2222     bdescr *bd;
2223
2224     bd = Bdescr((StgPtr)p);
2225     if (HEAP_ALLOCED(p) &&
2226         ((bd->flags & BF_EVACUATED)
2227          || ((bd->flags & BF_COMPACTED) &&
2228              is_marked((P_)p,bd)))) {
2229         return rtsTrue;
2230     } else {
2231         return rtsFalse;
2232     }
2233 }
2234
2235 static StgClosure *
2236 eval_thunk_selector( nat field, StgSelector * p )
2237 {
2238     StgInfoTable *info;
2239     const StgInfoTable *info_ptr;
2240     StgClosure *selectee;
2241
2242     selectee = p->selectee;
2243
2244     // Save the real info pointer (NOTE: not the same as get_itbl()).
2245     info_ptr = p->header.info;
2246
2247     // If the THUNK_SELECTOR is in a generation that we are not
2248     // collecting, then bail out early.  We won't be able to save any
2249     // space in any case, and updating with an indirection is trickier
2250     // in an old gen.
2251     if (Bdescr((StgPtr)p)->gen_no > N) {
2252         return NULL;
2253     }
2254
2255     // BLACKHOLE the selector thunk, since it is now under evaluation.
2256     // This is important to stop us going into an infinite loop if
2257     // this selector thunk eventually refers to itself.
2258     SET_INFO(p,&stg_BLACKHOLE_info);
2259
2260 selector_loop:
2261
2262     // We don't want to end up in to-space, because this causes
2263     // problems when the GC later tries to evacuate the result of
2264     // eval_thunk_selector().  There are various ways this could
2265     // happen:
2266     //
2267     // 1. following an IND_STATIC
2268     //
2269     // 2. when the old generation is compacted, the mark phase updates
2270     //    from-space pointers to be to-space pointers, and we can't
2271     //    reliably tell which we're following (eg. from an IND_STATIC).
2272     //
2273     // 3. compacting GC again: if we're looking at a constructor in
2274     //    the compacted generation, it might point directly to objects
2275     //    in to-space.  We must bale out here, otherwise doing the selection
2276     //    will result in a to-space pointer being returned.
2277     //
2278     //  (1) is dealt with using a BF_EVACUATED test on the
2279     //  selectee. (2) and (3): we can tell if we're looking at an
2280     //  object in the compacted generation that might point to
2281     //  to-space objects by testing that (a) it is BF_COMPACTED, (b)
2282     //  the compacted generation is being collected, and (c) the
2283     //  object is marked.  Only a marked object may have pointers that
2284     //  point to to-space objects, because that happens when
2285     //  scavenging.
2286     //
2287     //  The to-space test is now embodied in the in_to_space() inline
2288     //  function, as it is re-used below.
2289     //
2290     if (is_to_space(selectee)) {
2291         goto bale_out;
2292     }
2293
2294     info = get_itbl(selectee);
2295     switch (info->type) {
2296       case CONSTR:
2297       case CONSTR_1_0:
2298       case CONSTR_0_1:
2299       case CONSTR_2_0:
2300       case CONSTR_1_1:
2301       case CONSTR_0_2:
2302       case CONSTR_STATIC:
2303       case CONSTR_NOCAF_STATIC:
2304           // check that the size is in range
2305           ASSERT(field <  (StgWord32)(info->layout.payload.ptrs +
2306                                       info->layout.payload.nptrs));
2307
2308           // Select the right field from the constructor, and check
2309           // that the result isn't in to-space.  It might be in
2310           // to-space if, for example, this constructor contains
2311           // pointers to younger-gen objects (and is on the mut-once
2312           // list).
2313           //
2314           {
2315               StgClosure *q;
2316               q = selectee->payload[field];
2317               if (is_to_space(q)) {
2318                   goto bale_out;
2319               } else {
2320                   return q;
2321               }
2322           }
2323
2324       case IND:
2325       case IND_PERM:
2326       case IND_OLDGEN:
2327       case IND_OLDGEN_PERM:
2328       case IND_STATIC:
2329           selectee = ((StgInd *)selectee)->indirectee;
2330           goto selector_loop;
2331
2332       case EVACUATED:
2333           // We don't follow pointers into to-space; the constructor
2334           // has already been evacuated, so we won't save any space
2335           // leaks by evaluating this selector thunk anyhow.
2336           break;
2337
2338       case THUNK_SELECTOR:
2339       {
2340           StgClosure *val;
2341
2342           // check that we don't recurse too much, re-using the
2343           // depth bound also used in evacuate().
2344           if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2345               break;
2346           }
2347           thunk_selector_depth++;
2348
2349           val = eval_thunk_selector(info->layout.selector_offset,
2350                                     (StgSelector *)selectee);
2351
2352           thunk_selector_depth--;
2353
2354           if (val == NULL) {
2355               break;
2356           } else {
2357               // We evaluated this selector thunk, so update it with
2358               // an indirection.  NOTE: we don't use UPD_IND here,
2359               // because we are guaranteed that p is in a generation
2360               // that we are collecting, and we never want to put the
2361               // indirection on a mutable list.
2362 #ifdef PROFILING
2363               // For the purposes of LDV profiling, we have destroyed
2364               // the original selector thunk.
2365               SET_INFO(p, info_ptr);
2366               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2367 #endif
2368               ((StgInd *)selectee)->indirectee = val;
2369               SET_INFO(selectee,&stg_IND_info);
2370
2371               // For the purposes of LDV profiling, we have created an
2372               // indirection.
2373               LDV_RECORD_CREATE(selectee);
2374
2375               selectee = val;
2376               goto selector_loop;
2377           }
2378       }
2379
2380       case AP:
2381       case AP_STACK:
2382       case THUNK:
2383       case THUNK_1_0:
2384       case THUNK_0_1:
2385       case THUNK_2_0:
2386       case THUNK_1_1:
2387       case THUNK_0_2:
2388       case THUNK_STATIC:
2389       case CAF_BLACKHOLE:
2390       case SE_CAF_BLACKHOLE:
2391       case SE_BLACKHOLE:
2392       case BLACKHOLE:
2393 #if defined(PAR)
2394       case RBH:
2395       case BLOCKED_FETCH:
2396 # ifdef DIST
2397       case REMOTE_REF:
2398 # endif
2399       case FETCH_ME:
2400       case FETCH_ME_BQ:
2401 #endif
2402           // not evaluated yet
2403           break;
2404
2405       default:
2406         barf("eval_thunk_selector: strange selectee %d",
2407              (int)(info->type));
2408     }
2409
2410 bale_out:
2411     // We didn't manage to evaluate this thunk; restore the old info pointer
2412     SET_INFO(p, info_ptr);
2413     return NULL;
2414 }
2415
2416 /* -----------------------------------------------------------------------------
2417    move_TSO is called to update the TSO structure after it has been
2418    moved from one place to another.
2419    -------------------------------------------------------------------------- */
2420
2421 void
2422 move_TSO (StgTSO *src, StgTSO *dest)
2423 {
2424     ptrdiff_t diff;
2425
2426     // relocate the stack pointer...
2427     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2428     dest->sp = (StgPtr)dest->sp + diff;
2429 }
2430
2431 /* Similar to scavenge_large_bitmap(), but we don't write back the
2432  * pointers we get back from evacuate().
2433  */
2434 static void
2435 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2436 {
2437     nat i, b, size;
2438     StgWord bitmap;
2439     StgClosure **p;
2440
2441     b = 0;
2442     bitmap = large_srt->l.bitmap[b];
2443     size   = (nat)large_srt->l.size;
2444     p      = (StgClosure **)large_srt->srt;
2445     for (i = 0; i < size; ) {
2446         if ((bitmap & 1) != 0) {
2447             evacuate(*p);
2448         }
2449         i++;
2450         p++;
2451         if (i % BITS_IN(W_) == 0) {
2452             b++;
2453             bitmap = large_srt->l.bitmap[b];
2454         } else {
2455             bitmap = bitmap >> 1;
2456         }
2457     }
2458 }
2459
2460 /* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
2461  * srt field in the info table.  That's ok, because we'll
2462  * never dereference it.
2463  */
2464 STATIC_INLINE void
2465 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2466 {
2467   nat bitmap;
2468   StgClosure **p;
2469
2470   bitmap = srt_bitmap;
2471   p = srt;
2472
2473   if (bitmap == (StgHalfWord)(-1)) {
2474       scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2475       return;
2476   }
2477
2478   while (bitmap != 0) {
2479       if ((bitmap & 1) != 0) {
2480 #ifdef ENABLE_WIN32_DLL_SUPPORT
2481           // Special-case to handle references to closures hiding out in DLLs, since
2482           // double indirections required to get at those. The code generator knows
2483           // which is which when generating the SRT, so it stores the (indirect)
2484           // reference to the DLL closure in the table by first adding one to it.
2485           // We check for this here, and undo the addition before evacuating it.
2486           //
2487           // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2488           // closure that's fixed at link-time, and no extra magic is required.
2489           if ( (unsigned long)(*srt) & 0x1 ) {
2490               evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2491           } else {
2492               evacuate(*p);
2493           }
2494 #else
2495           evacuate(*p);
2496 #endif
2497       }
2498       p++;
2499       bitmap = bitmap >> 1;
2500   }
2501 }
2502
2503
2504 STATIC_INLINE void
2505 scavenge_thunk_srt(const StgInfoTable *info)
2506 {
2507     StgThunkInfoTable *thunk_info;
2508
2509     if (!major_gc) return;
2510
2511     thunk_info = itbl_to_thunk_itbl(info);
2512     scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2513 }
2514
2515 STATIC_INLINE void
2516 scavenge_fun_srt(const StgInfoTable *info)
2517 {
2518     StgFunInfoTable *fun_info;
2519
2520     if (!major_gc) return;
2521
2522     fun_info = itbl_to_fun_itbl(info);
2523     scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2524 }
2525
2526 /* -----------------------------------------------------------------------------
2527    Scavenge a TSO.
2528    -------------------------------------------------------------------------- */
2529
2530 static void
2531 scavengeTSO (StgTSO *tso)
2532 {
2533     if (   tso->why_blocked == BlockedOnMVar
2534         || tso->why_blocked == BlockedOnBlackHole
2535         || tso->why_blocked == BlockedOnException
2536 #if defined(PAR)
2537         || tso->why_blocked == BlockedOnGA
2538         || tso->why_blocked == BlockedOnGA_NoSend
2539 #endif
2540         ) {
2541         tso->block_info.closure = evacuate(tso->block_info.closure);
2542     }
2543     if ( tso->blocked_exceptions != NULL ) {
2544         tso->blocked_exceptions =
2545             (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2546     }
2547
2548     // We don't always chase the link field: TSOs on the blackhole
2549     // queue are not automatically alive, so the link field is a
2550     // "weak" pointer in that case.
2551     if (tso->why_blocked != BlockedOnBlackHole) {
2552         tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
2553     }
2554
2555     // scavange current transaction record
2556     tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2557
2558     // scavenge this thread's stack
2559     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2560 }
2561
2562 /* -----------------------------------------------------------------------------
2563    Blocks of function args occur on the stack (at the top) and
2564    in PAPs.
2565    -------------------------------------------------------------------------- */
2566
2567 STATIC_INLINE StgPtr
2568 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2569 {
2570     StgPtr p;
2571     StgWord bitmap;
2572     nat size;
2573
2574     p = (StgPtr)args;
2575     switch (fun_info->f.fun_type) {
2576     case ARG_GEN:
2577         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2578         size = BITMAP_SIZE(fun_info->f.b.bitmap);
2579         goto small_bitmap;
2580     case ARG_GEN_BIG:
2581         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2582         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2583         p += size;
2584         break;
2585     default:
2586         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2587         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2588     small_bitmap:
2589         while (size > 0) {
2590             if ((bitmap & 1) == 0) {
2591                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2592             }
2593             p++;
2594             bitmap = bitmap >> 1;
2595             size--;
2596         }
2597         break;
2598     }
2599     return p;
2600 }
2601
2602 STATIC_INLINE StgPtr
2603 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2604 {
2605     StgPtr p;
2606     StgWord bitmap;
2607     StgFunInfoTable *fun_info;
2608
2609     fun_info = get_fun_itbl(fun);
2610     ASSERT(fun_info->i.type != PAP);
2611     p = (StgPtr)payload;
2612
2613     switch (fun_info->f.fun_type) {
2614     case ARG_GEN:
2615         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2616         goto small_bitmap;
2617     case ARG_GEN_BIG:
2618         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2619         p += size;
2620         break;
2621     case ARG_BCO:
2622         scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2623         p += size;
2624         break;
2625     default:
2626         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2627     small_bitmap:
2628         while (size > 0) {
2629             if ((bitmap & 1) == 0) {
2630                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2631             }
2632             p++;
2633             bitmap = bitmap >> 1;
2634             size--;
2635         }
2636         break;
2637     }
2638     return p;
2639 }
2640
2641 STATIC_INLINE StgPtr
2642 scavenge_PAP (StgPAP *pap)
2643 {
2644     pap->fun = evacuate(pap->fun);
2645     return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2646 }
2647
2648 STATIC_INLINE StgPtr
2649 scavenge_AP (StgAP *ap)
2650 {
2651     ap->fun = evacuate(ap->fun);
2652     return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2653 }
2654
2655 /* -----------------------------------------------------------------------------
2656    Scavenge a given step until there are no more objects in this step
2657    to scavenge.
2658
2659    evac_gen is set by the caller to be either zero (for a step in a
2660    generation < N) or G where G is the generation of the step being
2661    scavenged.
2662
2663    We sometimes temporarily change evac_gen back to zero if we're
2664    scavenging a mutable object where early promotion isn't such a good
2665    idea.
2666    -------------------------------------------------------------------------- */
2667
2668 static void
2669 scavenge(step *stp)
2670 {
2671   StgPtr p, q;
2672   StgInfoTable *info;
2673   bdescr *bd;
2674   nat saved_evac_gen = evac_gen;
2675
2676   p = stp->scan;
2677   bd = stp->scan_bd;
2678
2679   failed_to_evac = rtsFalse;
2680
2681   /* scavenge phase - standard breadth-first scavenging of the
2682    * evacuated objects
2683    */
2684
2685   while (bd != stp->hp_bd || p < stp->hp) {
2686
2687     // If we're at the end of this block, move on to the next block
2688     if (bd != stp->hp_bd && p == bd->free) {
2689       bd = bd->link;
2690       p = bd->start;
2691       continue;
2692     }
2693
2694     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2695     info = get_itbl((StgClosure *)p);
2696
2697     ASSERT(thunk_selector_depth == 0);
2698
2699     q = p;
2700     switch (info->type) {
2701
2702     case MVAR:
2703     {
2704         StgMVar *mvar = ((StgMVar *)p);
2705         evac_gen = 0;
2706         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2707         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2708         mvar->value = evacuate((StgClosure *)mvar->value);
2709         evac_gen = saved_evac_gen;
2710         failed_to_evac = rtsTrue; // mutable.
2711         p += sizeofW(StgMVar);
2712         break;
2713     }
2714
2715     case FUN_2_0:
2716         scavenge_fun_srt(info);
2717         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2718         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2719         p += sizeofW(StgHeader) + 2;
2720         break;
2721
2722     case THUNK_2_0:
2723         scavenge_thunk_srt(info);
2724         ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2725         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2726         p += sizeofW(StgThunk) + 2;
2727         break;
2728
2729     case CONSTR_2_0:
2730         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2731         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2732         p += sizeofW(StgHeader) + 2;
2733         break;
2734
2735     case THUNK_1_0:
2736         scavenge_thunk_srt(info);
2737         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2738         p += sizeofW(StgThunk) + 1;
2739         break;
2740
2741     case FUN_1_0:
2742         scavenge_fun_srt(info);
2743     case CONSTR_1_0:
2744         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2745         p += sizeofW(StgHeader) + 1;
2746         break;
2747
2748     case THUNK_0_1:
2749         scavenge_thunk_srt(info);
2750         p += sizeofW(StgThunk) + 1;
2751         break;
2752
2753     case FUN_0_1:
2754         scavenge_fun_srt(info);
2755     case CONSTR_0_1:
2756         p += sizeofW(StgHeader) + 1;
2757         break;
2758
2759     case THUNK_0_2:
2760         scavenge_thunk_srt(info);
2761         p += sizeofW(StgThunk) + 2;
2762         break;
2763
2764     case FUN_0_2:
2765         scavenge_fun_srt(info);
2766     case CONSTR_0_2:
2767         p += sizeofW(StgHeader) + 2;
2768         break;
2769
2770     case THUNK_1_1:
2771         scavenge_thunk_srt(info);
2772         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2773         p += sizeofW(StgThunk) + 2;
2774         break;
2775
2776     case FUN_1_1:
2777         scavenge_fun_srt(info);
2778     case CONSTR_1_1:
2779         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2780         p += sizeofW(StgHeader) + 2;
2781         break;
2782
2783     case FUN:
2784         scavenge_fun_srt(info);
2785         goto gen_obj;
2786
2787     case THUNK:
2788     {
2789         StgPtr end;
2790
2791         scavenge_thunk_srt(info);
2792         end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2793         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2794             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2795         }
2796         p += info->layout.payload.nptrs;
2797         break;
2798     }
2799
2800     gen_obj:
2801     case CONSTR:
2802     case WEAK:
2803     case STABLE_NAME:
2804     {
2805         StgPtr end;
2806
2807         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2808         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2809             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2810         }
2811         p += info->layout.payload.nptrs;
2812         break;
2813     }
2814
2815     case BCO: {
2816         StgBCO *bco = (StgBCO *)p;
2817         bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2818         bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2819         bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2820         bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2821         p += bco_sizeW(bco);
2822         break;
2823     }
2824
2825     case IND_PERM:
2826       if (stp->gen->no != 0) {
2827 #ifdef PROFILING
2828         // @LDV profiling
2829         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2830         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2831         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2832 #endif
2833         //
2834         // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2835         //
2836         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2837
2838         // We pretend that p has just been created.
2839         LDV_RECORD_CREATE((StgClosure *)p);
2840       }
2841         // fall through
2842     case IND_OLDGEN_PERM:
2843         ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2844         p += sizeofW(StgInd);
2845         break;
2846
2847     case MUT_VAR:
2848         evac_gen = 0;
2849         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2850         evac_gen = saved_evac_gen;
2851         failed_to_evac = rtsTrue; // mutable anyhow
2852         p += sizeofW(StgMutVar);
2853         break;
2854
2855     case CAF_BLACKHOLE:
2856     case SE_CAF_BLACKHOLE:
2857     case SE_BLACKHOLE:
2858     case BLACKHOLE:
2859         p += BLACKHOLE_sizeW();
2860         break;
2861
2862     case THUNK_SELECTOR:
2863     {
2864         StgSelector *s = (StgSelector *)p;
2865         s->selectee = evacuate(s->selectee);
2866         p += THUNK_SELECTOR_sizeW();
2867         break;
2868     }
2869
2870     // A chunk of stack saved in a heap object
2871     case AP_STACK:
2872     {
2873         StgAP_STACK *ap = (StgAP_STACK *)p;
2874
2875         ap->fun = evacuate(ap->fun);
2876         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2877         p = (StgPtr)ap->payload + ap->size;
2878         break;
2879     }
2880
2881     case PAP:
2882         p = scavenge_PAP((StgPAP *)p);
2883         break;
2884
2885     case AP:
2886         p = scavenge_AP((StgAP *)p);
2887         break;
2888
2889     case ARR_WORDS:
2890         // nothing to follow
2891         p += arr_words_sizeW((StgArrWords *)p);
2892         break;
2893
2894     case MUT_ARR_PTRS:
2895         // follow everything
2896     {
2897         StgPtr next;
2898
2899         evac_gen = 0;           // repeatedly mutable
2900         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2901         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2902             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2903         }
2904         evac_gen = saved_evac_gen;
2905         failed_to_evac = rtsTrue; // mutable anyhow.
2906         break;
2907     }
2908
2909     case MUT_ARR_PTRS_FROZEN:
2910     case MUT_ARR_PTRS_FROZEN0:
2911         // follow everything
2912     {
2913         StgPtr next;
2914
2915         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2916         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2917             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2918         }
2919         // it's tempting to recordMutable() if failed_to_evac is
2920         // false, but that breaks some assumptions (eg. every
2921         // closure on the mutable list is supposed to have the MUT
2922         // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2923         break;
2924     }
2925
2926     case TSO:
2927     {
2928         StgTSO *tso = (StgTSO *)p;
2929         evac_gen = 0;
2930         scavengeTSO(tso);
2931         evac_gen = saved_evac_gen;
2932         failed_to_evac = rtsTrue; // mutable anyhow.
2933         p += tso_sizeW(tso);
2934         break;
2935     }
2936
2937 #if defined(PAR)
2938     case RBH:
2939     {
2940 #if 0
2941         nat size, ptrs, nonptrs, vhs;
2942         char str[80];
2943         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2944 #endif
2945         StgRBH *rbh = (StgRBH *)p;
2946         (StgClosure *)rbh->blocking_queue =
2947             evacuate((StgClosure *)rbh->blocking_queue);
2948         failed_to_evac = rtsTrue;  // mutable anyhow.
2949         IF_DEBUG(gc,
2950                  debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2951                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2952         // ToDo: use size of reverted closure here!
2953         p += BLACKHOLE_sizeW();
2954         break;
2955     }
2956
2957     case BLOCKED_FETCH:
2958     {
2959         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2960         // follow the pointer to the node which is being demanded
2961         (StgClosure *)bf->node =
2962             evacuate((StgClosure *)bf->node);
2963         // follow the link to the rest of the blocking queue
2964         (StgClosure *)bf->link =
2965             evacuate((StgClosure *)bf->link);
2966         IF_DEBUG(gc,
2967                  debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2968                        bf, info_type((StgClosure *)bf),
2969                        bf->node, info_type(bf->node)));
2970         p += sizeofW(StgBlockedFetch);
2971         break;
2972     }
2973
2974 #ifdef DIST
2975     case REMOTE_REF:
2976 #endif
2977     case FETCH_ME:
2978         p += sizeofW(StgFetchMe);
2979         break; // nothing to do in this case
2980
2981     case FETCH_ME_BQ:
2982     {
2983         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2984         (StgClosure *)fmbq->blocking_queue =
2985             evacuate((StgClosure *)fmbq->blocking_queue);
2986         IF_DEBUG(gc,
2987                  debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
2988                        p, info_type((StgClosure *)p)));
2989         p += sizeofW(StgFetchMeBlockingQueue);
2990         break;
2991     }
2992 #endif
2993
2994     case TVAR_WAIT_QUEUE:
2995       {
2996         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
2997         evac_gen = 0;
2998         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
2999         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3000         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3001         evac_gen = saved_evac_gen;
3002         failed_to_evac = rtsTrue; // mutable
3003         p += sizeofW(StgTVarWaitQueue);
3004         break;
3005       }
3006
3007     case TVAR:
3008       {
3009         StgTVar *tvar = ((StgTVar *) p);
3010         evac_gen = 0;
3011         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3012         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3013 #if defined(SMP)
3014         tvar->last_update_by = (StgTRecHeader *)evacuate((StgClosure*)tvar->last_update_by);
3015 #endif
3016         evac_gen = saved_evac_gen;
3017         failed_to_evac = rtsTrue; // mutable
3018         p += sizeofW(StgTVar);
3019         break;
3020       }
3021
3022     case TREC_HEADER:
3023       {
3024         StgTRecHeader *trec = ((StgTRecHeader *) p);
3025         evac_gen = 0;
3026         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3027         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3028         evac_gen = saved_evac_gen;
3029         failed_to_evac = rtsTrue; // mutable
3030         p += sizeofW(StgTRecHeader);
3031         break;
3032       }
3033
3034     case TREC_CHUNK:
3035       {
3036         StgWord i;
3037         StgTRecChunk *tc = ((StgTRecChunk *) p);
3038         TRecEntry *e = &(tc -> entries[0]);
3039         evac_gen = 0;
3040         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3041         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3042           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3043           e->expected_value = evacuate((StgClosure*)e->expected_value);
3044           e->new_value = evacuate((StgClosure*)e->new_value);
3045         }
3046         evac_gen = saved_evac_gen;
3047         failed_to_evac = rtsTrue; // mutable
3048         p += sizeofW(StgTRecChunk);
3049         break;
3050       }
3051
3052     default:
3053         barf("scavenge: unimplemented/strange closure type %d @ %p",
3054              info->type, p);
3055     }
3056
3057     /*
3058      * We need to record the current object on the mutable list if
3059      *  (a) It is actually mutable, or
3060      *  (b) It contains pointers to a younger generation.
3061      * Case (b) arises if we didn't manage to promote everything that
3062      * the current object points to into the current generation.
3063      */
3064     if (failed_to_evac) {
3065         failed_to_evac = rtsFalse;
3066         if (stp->gen_no > 0) {
3067             recordMutableGen((StgClosure *)q, stp->gen);
3068         }
3069     }
3070   }
3071
3072   stp->scan_bd = bd;
3073   stp->scan = p;
3074 }
3075
3076 /* -----------------------------------------------------------------------------
3077    Scavenge everything on the mark stack.
3078
3079    This is slightly different from scavenge():
3080       - we don't walk linearly through the objects, so the scavenger
3081         doesn't need to advance the pointer on to the next object.
3082    -------------------------------------------------------------------------- */
3083
3084 static void
3085 scavenge_mark_stack(void)
3086 {
3087     StgPtr p, q;
3088     StgInfoTable *info;
3089     nat saved_evac_gen;
3090
3091     evac_gen = oldest_gen->no;
3092     saved_evac_gen = evac_gen;
3093
3094 linear_scan:
3095     while (!mark_stack_empty()) {
3096         p = pop_mark_stack();
3097
3098         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3099         info = get_itbl((StgClosure *)p);
3100
3101         q = p;
3102         switch (info->type) {
3103
3104         case MVAR:
3105         {
3106             StgMVar *mvar = ((StgMVar *)p);
3107             evac_gen = 0;
3108             mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3109             mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3110             mvar->value = evacuate((StgClosure *)mvar->value);
3111             evac_gen = saved_evac_gen;
3112             failed_to_evac = rtsTrue; // mutable.
3113             break;
3114         }
3115
3116         case FUN_2_0:
3117             scavenge_fun_srt(info);
3118             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3119             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3120             break;
3121
3122         case THUNK_2_0:
3123             scavenge_thunk_srt(info);
3124             ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
3125             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3126             break;
3127
3128         case CONSTR_2_0:
3129             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3130             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3131             break;
3132
3133         case FUN_1_0:
3134         case FUN_1_1:
3135             scavenge_fun_srt(info);
3136             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3137             break;
3138
3139         case THUNK_1_0:
3140         case THUNK_1_1:
3141             scavenge_thunk_srt(info);
3142             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3143             break;
3144
3145         case CONSTR_1_0:
3146         case CONSTR_1_1:
3147             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3148             break;
3149
3150         case FUN_0_1:
3151         case FUN_0_2:
3152             scavenge_fun_srt(info);
3153             break;
3154
3155         case THUNK_0_1:
3156         case THUNK_0_2:
3157             scavenge_thunk_srt(info);
3158             break;
3159
3160         case CONSTR_0_1:
3161         case CONSTR_0_2:
3162             break;
3163
3164         case FUN:
3165             scavenge_fun_srt(info);
3166             goto gen_obj;
3167
3168         case THUNK:
3169         {
3170             StgPtr end;
3171
3172             scavenge_thunk_srt(info);
3173             end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3174             for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3175                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3176             }
3177             break;
3178         }
3179
3180         gen_obj:
3181         case CONSTR:
3182         case WEAK:
3183         case STABLE_NAME:
3184         {
3185             StgPtr end;
3186
3187             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3188             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3189                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3190             }
3191             break;
3192         }
3193
3194         case BCO: {
3195             StgBCO *bco = (StgBCO *)p;
3196             bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3197             bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3198             bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3199             bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3200             break;
3201         }
3202
3203         case IND_PERM:
3204             // don't need to do anything here: the only possible case
3205             // is that we're in a 1-space compacting collector, with
3206             // no "old" generation.
3207             break;
3208
3209         case IND_OLDGEN:
3210         case IND_OLDGEN_PERM:
3211             ((StgInd *)p)->indirectee =
3212                 evacuate(((StgInd *)p)->indirectee);
3213             break;
3214
3215         case MUT_VAR:
3216             evac_gen = 0;
3217             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3218             evac_gen = saved_evac_gen;
3219             failed_to_evac = rtsTrue;
3220             break;
3221
3222         case CAF_BLACKHOLE:
3223         case SE_CAF_BLACKHOLE:
3224         case SE_BLACKHOLE:
3225         case BLACKHOLE:
3226         case ARR_WORDS:
3227             break;
3228
3229         case THUNK_SELECTOR:
3230         {
3231             StgSelector *s = (StgSelector *)p;
3232             s->selectee = evacuate(s->selectee);
3233             break;
3234         }
3235
3236         // A chunk of stack saved in a heap object
3237         case AP_STACK:
3238         {
3239             StgAP_STACK *ap = (StgAP_STACK *)p;
3240
3241             ap->fun = evacuate(ap->fun);
3242             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3243             break;
3244         }
3245
3246         case PAP:
3247             scavenge_PAP((StgPAP *)p);
3248             break;
3249
3250         case AP:
3251             scavenge_AP((StgAP *)p);
3252             break;
3253
3254         case MUT_ARR_PTRS:
3255             // follow everything
3256         {
3257             StgPtr next;
3258
3259             evac_gen = 0;               // repeatedly mutable
3260             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3261             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3262                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3263             }
3264             evac_gen = saved_evac_gen;
3265             failed_to_evac = rtsTrue; // mutable anyhow.
3266             break;
3267         }
3268
3269         case MUT_ARR_PTRS_FROZEN:
3270         case MUT_ARR_PTRS_FROZEN0:
3271             // follow everything
3272         {
3273             StgPtr next;
3274
3275             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3276             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3277                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3278             }
3279             break;
3280         }
3281
3282         case TSO:
3283         {
3284             StgTSO *tso = (StgTSO *)p;
3285             evac_gen = 0;
3286             scavengeTSO(tso);
3287             evac_gen = saved_evac_gen;
3288             failed_to_evac = rtsTrue;
3289             break;
3290         }
3291
3292 #if defined(PAR)
3293         case RBH:
3294         {
3295 #if 0
3296             nat size, ptrs, nonptrs, vhs;
3297             char str[80];
3298             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3299 #endif
3300             StgRBH *rbh = (StgRBH *)p;
3301             bh->blocking_queue =
3302                 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3303             failed_to_evac = rtsTrue;  // mutable anyhow.
3304             IF_DEBUG(gc,
3305                      debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3306                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
3307             break;
3308         }
3309
3310         case BLOCKED_FETCH:
3311         {
3312             StgBlockedFetch *bf = (StgBlockedFetch *)p;
3313             // follow the pointer to the node which is being demanded
3314             (StgClosure *)bf->node =
3315                 evacuate((StgClosure *)bf->node);
3316             // follow the link to the rest of the blocking queue
3317             (StgClosure *)bf->link =
3318                 evacuate((StgClosure *)bf->link);
3319             IF_DEBUG(gc,
3320                      debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3321                            bf, info_type((StgClosure *)bf),
3322                            bf->node, info_type(bf->node)));
3323             break;
3324         }
3325
3326 #ifdef DIST
3327         case REMOTE_REF:
3328 #endif
3329         case FETCH_ME:
3330             break; // nothing to do in this case
3331
3332         case FETCH_ME_BQ:
3333         {
3334             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3335             (StgClosure *)fmbq->blocking_queue =
3336                 evacuate((StgClosure *)fmbq->blocking_queue);
3337             IF_DEBUG(gc,
3338                      debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3339                            p, info_type((StgClosure *)p)));
3340             break;
3341         }
3342 #endif /* PAR */
3343
3344         case TVAR_WAIT_QUEUE:
3345           {
3346             StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3347             evac_gen = 0;
3348             wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3349             wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3350             wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3351             evac_gen = saved_evac_gen;
3352             failed_to_evac = rtsTrue; // mutable
3353             break;
3354           }
3355
3356         case TVAR:
3357           {
3358             StgTVar *tvar = ((StgTVar *) p);
3359             evac_gen = 0;
3360             tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3361             tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3362 #if defined(SMP)
3363             tvar->last_update_by = (StgTRecHeader *)evacuate((StgClosure*)tvar->last_update_by);
3364 #endif
3365             evac_gen = saved_evac_gen;
3366             failed_to_evac = rtsTrue; // mutable
3367             break;
3368           }
3369
3370         case TREC_CHUNK:
3371           {
3372             StgWord i;
3373             StgTRecChunk *tc = ((StgTRecChunk *) p);
3374             TRecEntry *e = &(tc -> entries[0]);
3375             evac_gen = 0;
3376             tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3377             for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3378               e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3379               e->expected_value = evacuate((StgClosure*)e->expected_value);
3380               e->new_value = evacuate((StgClosure*)e->new_value);
3381             }
3382             evac_gen = saved_evac_gen;
3383             failed_to_evac = rtsTrue; // mutable
3384             break;
3385           }
3386
3387         case TREC_HEADER:
3388           {
3389             StgTRecHeader *trec = ((StgTRecHeader *) p);
3390             evac_gen = 0;
3391             trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3392             trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3393             evac_gen = saved_evac_gen;
3394             failed_to_evac = rtsTrue; // mutable
3395             break;
3396           }
3397
3398         default:
3399             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3400                  info->type, p);
3401         }
3402
3403         if (failed_to_evac) {
3404             failed_to_evac = rtsFalse;
3405             if (evac_gen > 0) {
3406                 recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3407             }
3408         }
3409
3410         // mark the next bit to indicate "scavenged"
3411         mark(q+1, Bdescr(q));
3412
3413     } // while (!mark_stack_empty())
3414
3415     // start a new linear scan if the mark stack overflowed at some point
3416     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3417         IF_DEBUG(gc, debugBelch("scavenge_mark_stack: starting linear scan"));
3418         mark_stack_overflowed = rtsFalse;
3419         oldgen_scan_bd = oldest_gen->steps[0].blocks;
3420         oldgen_scan = oldgen_scan_bd->start;
3421     }
3422
3423     if (oldgen_scan_bd) {
3424         // push a new thing on the mark stack
3425     loop:
3426         // find a closure that is marked but not scavenged, and start
3427         // from there.
3428         while (oldgen_scan < oldgen_scan_bd->free
3429                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3430             oldgen_scan++;
3431         }
3432
3433         if (oldgen_scan < oldgen_scan_bd->free) {
3434
3435             // already scavenged?
3436             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3437                 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3438                 goto loop;
3439             }
3440             push_mark_stack(oldgen_scan);
3441             // ToDo: bump the linear scan by the actual size of the object
3442             oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3443             goto linear_scan;
3444         }
3445
3446         oldgen_scan_bd = oldgen_scan_bd->link;
3447         if (oldgen_scan_bd != NULL) {
3448             oldgen_scan = oldgen_scan_bd->start;
3449             goto loop;
3450         }
3451     }
3452 }
3453
3454 /* -----------------------------------------------------------------------------
3455    Scavenge one object.
3456
3457    This is used for objects that are temporarily marked as mutable
3458    because they contain old-to-new generation pointers.  Only certain
3459    objects can have this property.
3460    -------------------------------------------------------------------------- */
3461
3462 static rtsBool
3463 scavenge_one(StgPtr p)
3464 {
3465     const StgInfoTable *info;
3466     nat saved_evac_gen = evac_gen;
3467     rtsBool no_luck;
3468
3469     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3470     info = get_itbl((StgClosure *)p);
3471
3472     switch (info->type) {
3473
3474     case MVAR:
3475     {
3476         StgMVar *mvar = ((StgMVar *)p);
3477         evac_gen = 0;
3478         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3479         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3480         mvar->value = evacuate((StgClosure *)mvar->value);
3481         evac_gen = saved_evac_gen;
3482         failed_to_evac = rtsTrue; // mutable.
3483         break;
3484     }
3485
3486     case THUNK:
3487     case THUNK_1_0:
3488     case THUNK_0_1:
3489     case THUNK_1_1:
3490     case THUNK_0_2:
3491     case THUNK_2_0:
3492     {
3493         StgPtr q, end;
3494
3495         end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3496         for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3497             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3498         }
3499         break;
3500     }
3501
3502     case FUN:
3503     case FUN_1_0:                       // hardly worth specialising these guys
3504     case FUN_0_1:
3505     case FUN_1_1:
3506     case FUN_0_2:
3507     case FUN_2_0:
3508     case CONSTR:
3509     case CONSTR_1_0:
3510     case CONSTR_0_1:
3511     case CONSTR_1_1:
3512     case CONSTR_0_2:
3513     case CONSTR_2_0:
3514     case WEAK:
3515     case IND_PERM:
3516     {
3517         StgPtr q, end;
3518
3519         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3520         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3521             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3522         }
3523         break;
3524     }
3525
3526     case MUT_VAR:
3527         evac_gen = 0;
3528         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3529         evac_gen = saved_evac_gen;
3530         failed_to_evac = rtsTrue; // mutable anyhow
3531         break;
3532
3533     case CAF_BLACKHOLE:
3534     case SE_CAF_BLACKHOLE:
3535     case SE_BLACKHOLE:
3536     case BLACKHOLE:
3537         break;
3538
3539     case THUNK_SELECTOR:
3540     {
3541         StgSelector *s = (StgSelector *)p;
3542         s->selectee = evacuate(s->selectee);
3543         break;
3544     }
3545
3546     case AP_STACK:
3547     {
3548         StgAP_STACK *ap = (StgAP_STACK *)p;
3549
3550         ap->fun = evacuate(ap->fun);
3551         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3552         p = (StgPtr)ap->payload + ap->size;
3553         break;
3554     }
3555
3556     case PAP:
3557         p = scavenge_PAP((StgPAP *)p);
3558         break;
3559
3560     case AP:
3561         p = scavenge_AP((StgAP *)p);
3562         break;
3563
3564     case ARR_WORDS:
3565         // nothing to follow
3566         break;
3567
3568     case MUT_ARR_PTRS:
3569     {
3570         // follow everything
3571         StgPtr next;
3572
3573         evac_gen = 0;           // repeatedly mutable
3574         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3575         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3576             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3577         }
3578         evac_gen = saved_evac_gen;
3579         failed_to_evac = rtsTrue;
3580         break;
3581     }
3582
3583     case MUT_ARR_PTRS_FROZEN:
3584     case MUT_ARR_PTRS_FROZEN0:
3585     {
3586         // follow everything
3587         StgPtr next;
3588
3589         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3590         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3591             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3592         }
3593         break;
3594     }
3595
3596     case TSO:
3597     {
3598         StgTSO *tso = (StgTSO *)p;
3599
3600         evac_gen = 0;           // repeatedly mutable
3601         scavengeTSO(tso);
3602         evac_gen = saved_evac_gen;
3603         failed_to_evac = rtsTrue;
3604         break;
3605     }
3606
3607 #if defined(PAR)
3608     case RBH:
3609     {
3610 #if 0
3611         nat size, ptrs, nonptrs, vhs;
3612         char str[80];
3613         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3614 #endif
3615         StgRBH *rbh = (StgRBH *)p;
3616         (StgClosure *)rbh->blocking_queue =
3617             evacuate((StgClosure *)rbh->blocking_queue);
3618         failed_to_evac = rtsTrue;  // mutable anyhow.
3619         IF_DEBUG(gc,
3620                  debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3621                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
3622         // ToDo: use size of reverted closure here!
3623         break;
3624     }
3625
3626     case BLOCKED_FETCH:
3627     {
3628         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3629         // follow the pointer to the node which is being demanded
3630         (StgClosure *)bf->node =
3631             evacuate((StgClosure *)bf->node);
3632         // follow the link to the rest of the blocking queue
3633         (StgClosure *)bf->link =
3634             evacuate((StgClosure *)bf->link);
3635         IF_DEBUG(gc,
3636                  debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
3637                        bf, info_type((StgClosure *)bf),
3638                        bf->node, info_type(bf->node)));
3639         break;
3640     }
3641
3642 #ifdef DIST
3643     case REMOTE_REF:
3644 #endif
3645     case FETCH_ME:
3646         break; // nothing to do in this case
3647
3648     case FETCH_ME_BQ:
3649     {
3650         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3651         (StgClosure *)fmbq->blocking_queue =
3652             evacuate((StgClosure *)fmbq->blocking_queue);
3653         IF_DEBUG(gc,
3654                  debugBelch("@@ scavenge: %p (%s) exciting, isn't it",
3655                        p, info_type((StgClosure *)p)));
3656         break;
3657     }
3658 #endif
3659
3660     case TVAR_WAIT_QUEUE:
3661       {
3662         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3663         evac_gen = 0;
3664         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3665         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3666         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3667         evac_gen = saved_evac_gen;
3668         failed_to_evac = rtsTrue; // mutable
3669         break;
3670       }
3671
3672     case TVAR:
3673       {
3674         StgTVar *tvar = ((StgTVar *) p);
3675         evac_gen = 0;
3676         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3677         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3678 #if defined(SMP)
3679         tvar->last_update_by = (StgTRecHeader *)evacuate((StgClosure*)tvar->last_update_by);
3680 #endif
3681         evac_gen = saved_evac_gen;
3682         failed_to_evac = rtsTrue; // mutable
3683         break;
3684       }
3685
3686     case TREC_HEADER:
3687       {
3688         StgTRecHeader *trec = ((StgTRecHeader *) p);
3689         evac_gen = 0;
3690         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3691         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3692         evac_gen = saved_evac_gen;
3693         failed_to_evac = rtsTrue; // mutable
3694         break;
3695       }
3696
3697     case TREC_CHUNK:
3698       {
3699         StgWord i;
3700         StgTRecChunk *tc = ((StgTRecChunk *) p);
3701         TRecEntry *e = &(tc -> entries[0]);
3702         evac_gen = 0;
3703         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3704         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3705           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3706           e->expected_value = evacuate((StgClosure*)e->expected_value);
3707           e->new_value = evacuate((StgClosure*)e->new_value);
3708         }
3709         evac_gen = saved_evac_gen;
3710         failed_to_evac = rtsTrue; // mutable
3711         break;
3712       }
3713
3714     case IND_OLDGEN:
3715     case IND_OLDGEN_PERM:
3716     case IND_STATIC:
3717     {
3718         /* Careful here: a THUNK can be on the mutable list because
3719          * it contains pointers to young gen objects.  If such a thunk
3720          * is updated, the IND_OLDGEN will be added to the mutable
3721          * list again, and we'll scavenge it twice.  evacuate()
3722          * doesn't check whether the object has already been
3723          * evacuated, so we perform that check here.
3724          */
3725         StgClosure *q = ((StgInd *)p)->indirectee;
3726         if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
3727             break;
3728         }
3729         ((StgInd *)p)->indirectee = evacuate(q);
3730     }
3731
3732 #if 0 && defined(DEBUG)
3733       if (RtsFlags.DebugFlags.gc)
3734       /* Debugging code to print out the size of the thing we just
3735        * promoted
3736        */
3737       {
3738         StgPtr start = gen->steps[0].scan;
3739         bdescr *start_bd = gen->steps[0].scan_bd;
3740         nat size = 0;
3741         scavenge(&gen->steps[0]);
3742         if (start_bd != gen->steps[0].scan_bd) {
3743           size += (P_)BLOCK_ROUND_UP(start) - start;
3744           start_bd = start_bd->link;
3745           while (start_bd != gen->steps[0].scan_bd) {
3746             size += BLOCK_SIZE_W;
3747             start_bd = start_bd->link;
3748           }
3749           size += gen->steps[0].scan -
3750             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3751         } else {
3752           size = gen->steps[0].scan - start;
3753         }
3754         debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3755       }
3756 #endif
3757       break;
3758
3759     default:
3760         barf("scavenge_one: strange object %d", (int)(info->type));
3761     }
3762
3763     no_luck = failed_to_evac;
3764     failed_to_evac = rtsFalse;
3765     return (no_luck);
3766 }
3767
3768 /* -----------------------------------------------------------------------------
3769    Scavenging mutable lists.
3770
3771    We treat the mutable list of each generation > N (i.e. all the
3772    generations older than the one being collected) as roots.  We also
3773    remove non-mutable objects from the mutable list at this point.
3774    -------------------------------------------------------------------------- */
3775
3776 static void
3777 scavenge_mutable_list(generation *gen)
3778 {
3779     bdescr *bd;
3780     StgPtr p, q;
3781
3782     bd = gen->saved_mut_list;
3783
3784     evac_gen = gen->no;
3785     for (; bd != NULL; bd = bd->link) {
3786         for (q = bd->start; q < bd->free; q++) {
3787             p = (StgPtr)*q;
3788             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3789             if (scavenge_one(p)) {
3790                 /* didn't manage to promote everything, so put the
3791                  * object back on the list.
3792                  */
3793                 recordMutableGen((StgClosure *)p,gen);
3794             }
3795         }
3796     }
3797
3798     // free the old mut_list
3799     freeChain(gen->saved_mut_list);
3800     gen->saved_mut_list = NULL;
3801 }
3802
3803
3804 static void
3805 scavenge_static(void)
3806 {
3807   StgClosure* p = static_objects;
3808   const StgInfoTable *info;
3809
3810   /* Always evacuate straight to the oldest generation for static
3811    * objects */
3812   evac_gen = oldest_gen->no;
3813
3814   /* keep going until we've scavenged all the objects on the linked
3815      list... */
3816   while (p != END_OF_STATIC_LIST) {
3817
3818     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3819     info = get_itbl(p);
3820     /*
3821     if (info->type==RBH)
3822       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3823     */
3824     // make sure the info pointer is into text space
3825
3826     /* Take this object *off* the static_objects list,
3827      * and put it on the scavenged_static_objects list.
3828      */
3829     static_objects = *STATIC_LINK(info,p);
3830     *STATIC_LINK(info,p) = scavenged_static_objects;
3831     scavenged_static_objects = p;
3832
3833     switch (info -> type) {
3834
3835     case IND_STATIC:
3836       {
3837         StgInd *ind = (StgInd *)p;
3838         ind->indirectee = evacuate(ind->indirectee);
3839
3840         /* might fail to evacuate it, in which case we have to pop it
3841          * back on the mutable list of the oldest generation.  We
3842          * leave it *on* the scavenged_static_objects list, though,
3843          * in case we visit this object again.
3844          */
3845         if (failed_to_evac) {
3846           failed_to_evac = rtsFalse;
3847           recordMutableGen((StgClosure *)p,oldest_gen);
3848         }
3849         break;
3850       }
3851
3852     case THUNK_STATIC:
3853       scavenge_thunk_srt(info);
3854       break;
3855
3856     case FUN_STATIC:
3857       scavenge_fun_srt(info);
3858       break;
3859
3860     case CONSTR_STATIC:
3861       {
3862         StgPtr q, next;
3863
3864         next = (P_)p->payload + info->layout.payload.ptrs;
3865         // evacuate the pointers
3866         for (q = (P_)p->payload; q < next; q++) {
3867             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3868         }
3869         break;
3870       }
3871
3872     default:
3873       barf("scavenge_static: strange closure %d", (int)(info->type));
3874     }
3875
3876     ASSERT(failed_to_evac == rtsFalse);
3877
3878     /* get the next static object from the list.  Remember, there might
3879      * be more stuff on this list now that we've done some evacuating!
3880      * (static_objects is a global)
3881      */
3882     p = static_objects;
3883   }
3884 }
3885
3886 /* -----------------------------------------------------------------------------
3887    scavenge a chunk of memory described by a bitmap
3888    -------------------------------------------------------------------------- */
3889
3890 static void
3891 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
3892 {
3893     nat i, b;
3894     StgWord bitmap;
3895
3896     b = 0;
3897     bitmap = large_bitmap->bitmap[b];
3898     for (i = 0; i < size; ) {
3899         if ((bitmap & 1) == 0) {
3900             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3901         }
3902         i++;
3903         p++;
3904         if (i % BITS_IN(W_) == 0) {
3905             b++;
3906             bitmap = large_bitmap->bitmap[b];
3907         } else {
3908             bitmap = bitmap >> 1;
3909         }
3910     }
3911 }
3912
3913 STATIC_INLINE StgPtr
3914 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
3915 {
3916     while (size > 0) {
3917         if ((bitmap & 1) == 0) {
3918             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3919         }
3920         p++;
3921         bitmap = bitmap >> 1;
3922         size--;
3923     }
3924     return p;
3925 }
3926
3927 /* -----------------------------------------------------------------------------
3928    scavenge_stack walks over a section of stack and evacuates all the
3929    objects pointed to by it.  We can use the same code for walking
3930    AP_STACK_UPDs, since these are just sections of copied stack.
3931    -------------------------------------------------------------------------- */
3932
3933
3934 static void
3935 scavenge_stack(StgPtr p, StgPtr stack_end)
3936 {
3937   const StgRetInfoTable* info;
3938   StgWord bitmap;
3939   nat size;
3940
3941   //IF_DEBUG(sanity, debugBelch("  scavenging stack between %p and %p", p, stack_end));
3942
3943   /*
3944    * Each time around this loop, we are looking at a chunk of stack
3945    * that starts with an activation record.
3946    */
3947
3948   while (p < stack_end) {
3949     info  = get_ret_itbl((StgClosure *)p);
3950
3951     switch (info->i.type) {
3952
3953     case UPDATE_FRAME:
3954         ((StgUpdateFrame *)p)->updatee
3955             = evacuate(((StgUpdateFrame *)p)->updatee);
3956         p += sizeofW(StgUpdateFrame);
3957         continue;
3958
3959       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3960     case CATCH_STM_FRAME:
3961     case CATCH_RETRY_FRAME:
3962     case ATOMICALLY_FRAME:
3963     case STOP_FRAME:
3964     case CATCH_FRAME:
3965     case RET_SMALL:
3966     case RET_VEC_SMALL:
3967         bitmap = BITMAP_BITS(info->i.layout.bitmap);
3968         size   = BITMAP_SIZE(info->i.layout.bitmap);
3969         // NOTE: the payload starts immediately after the info-ptr, we
3970         // don't have an StgHeader in the same sense as a heap closure.
3971         p++;
3972         p = scavenge_small_bitmap(p, size, bitmap);
3973
3974     follow_srt:
3975         if (major_gc)
3976             scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
3977         continue;
3978
3979     case RET_BCO: {
3980         StgBCO *bco;
3981         nat size;
3982
3983         p++;
3984         *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3985         bco = (StgBCO *)*p;
3986         p++;
3987         size = BCO_BITMAP_SIZE(bco);
3988         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
3989         p += size;
3990         continue;
3991     }
3992
3993       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3994     case RET_BIG:
3995     case RET_VEC_BIG:
3996     {
3997         nat size;
3998
3999         size = GET_LARGE_BITMAP(&info->i)->size;
4000         p++;
4001         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
4002         p += size;
4003         // and don't forget to follow the SRT
4004         goto follow_srt;
4005     }
4006
4007       // Dynamic bitmap: the mask is stored on the stack, and
4008       // there are a number of non-pointers followed by a number
4009       // of pointers above the bitmapped area.  (see StgMacros.h,
4010       // HEAP_CHK_GEN).
4011     case RET_DYN:
4012     {
4013         StgWord dyn;
4014         dyn = ((StgRetDyn *)p)->liveness;
4015
4016         // traverse the bitmap first
4017         bitmap = RET_DYN_LIVENESS(dyn);
4018         p      = (P_)&((StgRetDyn *)p)->payload[0];
4019         size   = RET_DYN_BITMAP_SIZE;
4020         p = scavenge_small_bitmap(p, size, bitmap);
4021
4022         // skip over the non-ptr words
4023         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
4024
4025         // follow the ptr words
4026         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
4027             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4028             p++;
4029         }
4030         continue;
4031     }
4032
4033     case RET_FUN:
4034     {
4035         StgRetFun *ret_fun = (StgRetFun *)p;
4036         StgFunInfoTable *fun_info;
4037
4038         ret_fun->fun = evacuate(ret_fun->fun);
4039         fun_info = get_fun_itbl(ret_fun->fun);
4040         p = scavenge_arg_block(fun_info, ret_fun->payload);
4041         goto follow_srt;
4042     }
4043
4044     default:
4045         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
4046     }
4047   }
4048 }
4049
4050 /*-----------------------------------------------------------------------------
4051   scavenge the large object list.
4052
4053   evac_gen set by caller; similar games played with evac_gen as with
4054   scavenge() - see comment at the top of scavenge().  Most large
4055   objects are (repeatedly) mutable, so most of the time evac_gen will
4056   be zero.
4057   --------------------------------------------------------------------------- */
4058
4059 static void
4060 scavenge_large(step *stp)
4061 {
4062   bdescr *bd;
4063   StgPtr p;
4064
4065   bd = stp->new_large_objects;
4066
4067   for (; bd != NULL; bd = stp->new_large_objects) {
4068
4069     /* take this object *off* the large objects list and put it on
4070      * the scavenged large objects list.  This is so that we can
4071      * treat new_large_objects as a stack and push new objects on
4072      * the front when evacuating.
4073      */
4074     stp->new_large_objects = bd->link;
4075     dbl_link_onto(bd, &stp->scavenged_large_objects);
4076
4077     // update the block count in this step.
4078     stp->n_scavenged_large_blocks += bd->blocks;
4079
4080     p = bd->start;
4081     if (scavenge_one(p)) {
4082         if (stp->gen_no > 0) {
4083             recordMutableGen((StgClosure *)p, stp->gen);
4084         }
4085     }
4086   }
4087 }
4088
4089 /* -----------------------------------------------------------------------------
4090    Initialising the static object & mutable lists
4091    -------------------------------------------------------------------------- */
4092
4093 static void
4094 zero_static_object_list(StgClosure* first_static)
4095 {
4096   StgClosure* p;
4097   StgClosure* link;
4098   const StgInfoTable *info;
4099
4100   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
4101     info = get_itbl(p);
4102     link = *STATIC_LINK(info, p);
4103     *STATIC_LINK(info,p) = NULL;
4104   }
4105 }
4106
4107 /* -----------------------------------------------------------------------------
4108    Reverting CAFs
4109    -------------------------------------------------------------------------- */
4110
4111 void
4112 revertCAFs( void )
4113 {
4114     StgIndStatic *c;
4115
4116     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4117          c = (StgIndStatic *)c->static_link)
4118     {
4119         SET_INFO(c, c->saved_info);
4120         c->saved_info = NULL;
4121         // could, but not necessary: c->static_link = NULL;
4122     }
4123     revertible_caf_list = NULL;
4124 }
4125
4126 void
4127 markCAFs( evac_fn evac )
4128 {
4129     StgIndStatic *c;
4130
4131     for (c = (StgIndStatic *)caf_list; c != NULL;
4132          c = (StgIndStatic *)c->static_link)
4133     {
4134         evac(&c->indirectee);
4135     }
4136     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4137          c = (StgIndStatic *)c->static_link)
4138     {
4139         evac(&c->indirectee);
4140     }
4141 }
4142
4143 /* -----------------------------------------------------------------------------
4144    Sanity code for CAF garbage collection.
4145
4146    With DEBUG turned on, we manage a CAF list in addition to the SRT
4147    mechanism.  After GC, we run down the CAF list and blackhole any
4148    CAFs which have been garbage collected.  This means we get an error
4149    whenever the program tries to enter a garbage collected CAF.
4150
4151    Any garbage collected CAFs are taken off the CAF list at the same
4152    time.
4153    -------------------------------------------------------------------------- */
4154
4155 #if 0 && defined(DEBUG)
4156
4157 static void
4158 gcCAFs(void)
4159 {
4160   StgClosure*  p;
4161   StgClosure** pp;
4162   const StgInfoTable *info;
4163   nat i;
4164
4165   i = 0;
4166   p = caf_list;
4167   pp = &caf_list;
4168
4169   while (p != NULL) {
4170
4171     info = get_itbl(p);
4172
4173     ASSERT(info->type == IND_STATIC);
4174
4175     if (STATIC_LINK(info,p) == NULL) {
4176       IF_DEBUG(gccafs, debugBelch("CAF gc'd at 0x%04lx", (long)p));
4177       // black hole it
4178       SET_INFO(p,&stg_BLACKHOLE_info);
4179       p = STATIC_LINK2(info,p);
4180       *pp = p;
4181     }
4182     else {
4183       pp = &STATIC_LINK2(info,p);
4184       p = *pp;
4185       i++;
4186     }
4187
4188   }
4189
4190   //  debugBelch("%d CAFs live", i);
4191 }
4192 #endif
4193
4194
4195 /* -----------------------------------------------------------------------------
4196    Lazy black holing.
4197
4198    Whenever a thread returns to the scheduler after possibly doing
4199    some work, we have to run down the stack and black-hole all the
4200    closures referred to by update frames.
4201    -------------------------------------------------------------------------- */
4202
4203 static void
4204 threadLazyBlackHole(StgTSO *tso)
4205 {
4206     StgClosure *frame;
4207     StgRetInfoTable *info;
4208     StgClosure *bh;
4209     StgPtr stack_end;
4210
4211     stack_end = &tso->stack[tso->stack_size];
4212
4213     frame = (StgClosure *)tso->sp;
4214
4215     while (1) {
4216         info = get_ret_itbl(frame);
4217
4218         switch (info->i.type) {
4219
4220         case UPDATE_FRAME:
4221             bh = ((StgUpdateFrame *)frame)->updatee;
4222
4223             /* if the thunk is already blackholed, it means we've also
4224              * already blackholed the rest of the thunks on this stack,
4225              * so we can stop early.
4226              *
4227              * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
4228              * don't interfere with this optimisation.
4229              */
4230             if (bh->header.info == &stg_BLACKHOLE_info) {
4231                 return;
4232             }
4233
4234             if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
4235 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4236                 debugBelch("Unexpected lazy BHing required at 0x%04x\n",(int)bh);
4237 #endif
4238 #ifdef PROFILING
4239                 // @LDV profiling
4240                 // We pretend that bh is now dead.
4241                 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4242 #endif
4243                 SET_INFO(bh,&stg_BLACKHOLE_info);
4244
4245                 // We pretend that bh has just been created.
4246                 LDV_RECORD_CREATE(bh);
4247             }
4248
4249             frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4250             break;
4251
4252         case STOP_FRAME:
4253             return;
4254
4255             // normal stack frames; do nothing except advance the pointer
4256         default:
4257             frame = (StgClosure *)((StgPtr)frame + stack_frame_sizeW(frame));
4258         }
4259     }
4260 }
4261
4262
4263 /* -----------------------------------------------------------------------------
4264  * Stack squeezing
4265  *
4266  * Code largely pinched from old RTS, then hacked to bits.  We also do
4267  * lazy black holing here.
4268  *
4269  * -------------------------------------------------------------------------- */
4270
4271 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4272
4273 static void
4274 threadSqueezeStack(StgTSO *tso)
4275 {
4276     StgPtr frame;
4277     rtsBool prev_was_update_frame;
4278     StgClosure *updatee = NULL;
4279     StgPtr bottom;
4280     StgRetInfoTable *info;
4281     StgWord current_gap_size;
4282     struct stack_gap *gap;
4283
4284     // Stage 1:
4285     //    Traverse the stack upwards, replacing adjacent update frames
4286     //    with a single update frame and a "stack gap".  A stack gap
4287     //    contains two values: the size of the gap, and the distance
4288     //    to the next gap (or the stack top).
4289
4290     bottom = &(tso->stack[tso->stack_size]);
4291
4292     frame = tso->sp;
4293
4294     ASSERT(frame < bottom);
4295
4296     prev_was_update_frame = rtsFalse;
4297     current_gap_size = 0;
4298     gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4299
4300     while (frame < bottom) {
4301
4302         info = get_ret_itbl((StgClosure *)frame);
4303         switch (info->i.type) {
4304
4305         case UPDATE_FRAME:
4306         {
4307             StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4308
4309             if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
4310
4311                 // found a BLACKHOLE'd update frame; we've been here
4312                 // before, in a previous GC, so just break out.
4313
4314                 // Mark the end of the gap, if we're in one.
4315                 if (current_gap_size != 0) {
4316                     gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
4317                 }
4318
4319                 frame += sizeofW(StgUpdateFrame);
4320                 goto done_traversing;
4321             }
4322
4323             if (prev_was_update_frame) {
4324
4325                 TICK_UPD_SQUEEZED();
4326                 /* wasn't there something about update squeezing and ticky to be
4327                  * sorted out?  oh yes: we aren't counting each enter properly
4328                  * in this case.  See the log somewhere.  KSW 1999-04-21
4329                  *
4330                  * Check two things: that the two update frames don't point to
4331                  * the same object, and that the updatee_bypass isn't already an
4332                  * indirection.  Both of these cases only happen when we're in a
4333                  * block hole-style loop (and there are multiple update frames
4334                  * on the stack pointing to the same closure), but they can both
4335                  * screw us up if we don't check.
4336                  */
4337                 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4338                     UPD_IND_NOLOCK(upd->updatee, updatee);
4339                 }
4340
4341                 // now mark this update frame as a stack gap.  The gap
4342                 // marker resides in the bottom-most update frame of
4343                 // the series of adjacent frames, and covers all the
4344                 // frames in this series.
4345                 current_gap_size += sizeofW(StgUpdateFrame);
4346                 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4347                 ((struct stack_gap *)frame)->next_gap = gap;
4348
4349                 frame += sizeofW(StgUpdateFrame);
4350                 continue;
4351             }
4352
4353             // single update frame, or the topmost update frame in a series
4354             else {
4355                 StgClosure *bh = upd->updatee;
4356
4357                 // Do lazy black-holing
4358                 if (bh->header.info != &stg_BLACKHOLE_info &&
4359                     bh->header.info != &stg_CAF_BLACKHOLE_info) {
4360 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4361                     debugBelch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4362 #endif
4363 #ifdef DEBUG
4364                     // zero out the slop so that the sanity checker can tell
4365                     // where the next closure is.
4366                     DEBUG_FILL_SLOP(bh);
4367 #endif
4368 #ifdef PROFILING
4369                     // We pretend that bh is now dead.
4370                     // ToDo: is the slop filling the same as DEBUG_FILL_SLOP?
4371                     LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4372 #endif
4373                     // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
4374                     SET_INFO(bh,&stg_BLACKHOLE_info);
4375
4376                     // We pretend that bh has just been created.
4377                     LDV_RECORD_CREATE(bh);
4378                 }
4379
4380                 prev_was_update_frame = rtsTrue;
4381                 updatee = upd->updatee;
4382                 frame += sizeofW(StgUpdateFrame);
4383                 continue;
4384             }
4385         }
4386
4387         default:
4388             prev_was_update_frame = rtsFalse;
4389
4390             // we're not in a gap... check whether this is the end of a gap
4391             // (an update frame can't be the end of a gap).
4392             if (current_gap_size != 0) {
4393                 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4394             }
4395             current_gap_size = 0;
4396
4397             frame += stack_frame_sizeW((StgClosure *)frame);
4398             continue;
4399         }
4400     }
4401
4402 done_traversing:
4403
4404     // Now we have a stack with gaps in it, and we have to walk down
4405     // shoving the stack up to fill in the gaps.  A diagram might
4406     // help:
4407     //
4408     //    +| ********* |
4409     //     | ********* | <- sp
4410     //     |           |
4411     //     |           | <- gap_start
4412     //     | ......... |                |
4413     //     | stack_gap | <- gap         | chunk_size
4414     //     | ......... |                |
4415     //     | ......... | <- gap_end     v
4416     //     | ********* |
4417     //     | ********* |
4418     //     | ********* |
4419     //    -| ********* |
4420     //
4421     // 'sp'  points the the current top-of-stack
4422     // 'gap' points to the stack_gap structure inside the gap
4423     // *****   indicates real stack data
4424     // .....   indicates gap
4425     // <empty> indicates unused
4426     //
4427     {
4428         void *sp;
4429         void *gap_start, *next_gap_start, *gap_end;
4430         nat chunk_size;
4431
4432         next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4433         sp = next_gap_start;
4434
4435         while ((StgPtr)gap > tso->sp) {
4436
4437             // we're working in *bytes* now...
4438             gap_start = next_gap_start;
4439             gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4440
4441             gap = gap->next_gap;
4442             next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4443
4444             chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4445             sp -= chunk_size;
4446             memmove(sp, next_gap_start, chunk_size);
4447         }
4448
4449         tso->sp = (StgPtr)sp;
4450     }
4451 }
4452
4453 /* -----------------------------------------------------------------------------
4454  * Pausing a thread
4455  *
4456  * We have to prepare for GC - this means doing lazy black holing
4457  * here.  We also take the opportunity to do stack squeezing if it's
4458  * turned on.
4459  * -------------------------------------------------------------------------- */
4460 void
4461 threadPaused(StgTSO *tso)
4462 {
4463   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4464     threadSqueezeStack(tso);    // does black holing too
4465   else
4466     threadLazyBlackHole(tso);
4467 }
4468
4469 /* -----------------------------------------------------------------------------
4470  * Debugging
4471  * -------------------------------------------------------------------------- */
4472
4473 #if DEBUG
4474 void
4475 printMutableList(generation *gen)
4476 {
4477     bdescr *bd;
4478     StgPtr p;
4479
4480     debugBelch("@@ Mutable list %p: ", gen->mut_list);
4481
4482     for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
4483         for (p = bd->start; p < bd->free; p++) {
4484             debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
4485         }
4486     }
4487     debugBelch("\n");
4488 }
4489 #endif /* DEBUG */