ghc/rts/GC.c

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