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