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