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