ghc/rts/GC.c

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