ghc/rts/GC.c

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