ghc/rts/GC.c

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