ghc/rts/GC.c

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