ghc/rts/GC.c

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