ghc/rts/GC.c

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