ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.144 2002/09/25 14:46:34 simonmar Exp $
   3  *
   4  * (c) The GHC Team 1998-1999
   5  *
   6  * Generational garbage collector
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "PosixSource.h"
  11 #include "Rts.h"
  12 #include "RtsFlags.h"
  13 #include "RtsUtils.h"
  14 #include "Storage.h"
  15 #include "StoragePriv.h"
  16 #include "Stats.h"
  17 #include "Schedule.h"
  18 #include "SchedAPI.h"           // for ReverCAFs prototype
  19 #include "Sanity.h"
  20 #include "BlockAlloc.h"
  21 #include "MBlock.h"
  22 #include "Main.h"
  23 #include "ProfHeap.h"
  24 #include "SchedAPI.h"
  25 #include "Weak.h"
  26 #include "StablePriv.h"
  27 #include "Prelude.h"
  28 #include "ParTicky.h"           // ToDo: move into Rts.h
  29 #include "GCCompact.h"
  30 #include "Signals.h"
  31 #if defined(GRAN) || defined(PAR)
  32 # include "GranSimRts.h"
  33 # include "ParallelRts.h"
  34 # include "FetchMe.h"
  35 # if defined(DEBUG)
  36 #  include "Printer.h"
  37 #  include "ParallelDebug.h"
  38 # endif
  39 #endif
  40 #include "HsFFI.h"
  41 #include "Linker.h"
  42 #if defined(RTS_GTK_FRONTPANEL)
  43 #include "FrontPanel.h"
  44 #endif
  45
  46 #include "RetainerProfile.h"
  47 #include "LdvProfile.h"
  48
  49 #include <string.h>
  50
  51 /* STATIC OBJECT LIST.
  52  *
  53  * During GC:
  54  * We maintain a linked list of static objects that are still live.
  55  * The requirements for this list are:
  56  *
  57  *  - we need to scan the list while adding to it, in order to
  58  *    scavenge all the static objects (in the same way that
  59  *    breadth-first scavenging works for dynamic objects).
  60  *
  61  *  - we need to be able to tell whether an object is already on
  62  *    the list, to break loops.
  63  *
  64  * Each static object has a "static link field", which we use for
  65  * linking objects on to the list.  We use a stack-type list, consing
  66  * objects on the front as they are added (this means that the
  67  * scavenge phase is depth-first, not breadth-first, but that
  68  * shouldn't matter).
  69  *
  70  * A separate list is kept for objects that have been scavenged
  71  * already - this is so that we can zero all the marks afterwards.
  72  *
  73  * An object is on the list if its static link field is non-zero; this
  74  * means that we have to mark the end of the list with '1', not NULL.
  75  *
  76  * Extra notes for generational GC:
  77  *
  78  * Each generation has a static object list associated with it.  When
  79  * collecting generations up to N, we treat the static object lists
  80  * from generations > N as roots.
  81  *
  82  * We build up a static object list while collecting generations 0..N,
  83  * which is then appended to the static object list of generation N+1.
  84  */
  85 static StgClosure* static_objects;      // live static objects
  86 StgClosure* scavenged_static_objects;   // static objects scavenged so far
  87
  88 /* N is the oldest generation being collected, where the generations
  89  * are numbered starting at 0.  A major GC (indicated by the major_gc
  90  * flag) is when we're collecting all generations.  We only attempt to
  91  * deal with static objects and GC CAFs when doing a major GC.
  92  */
  93 static nat N;
  94 static rtsBool major_gc;
  95
  96 /* Youngest generation that objects should be evacuated to in
  97  * evacuate().  (Logically an argument to evacuate, but it's static
  98  * a lot of the time so we optimise it into a global variable).
  99  */
 100 static nat evac_gen;
 101
 102 /* Weak pointers
 103  */
 104 StgWeak *old_weak_ptr_list; // also pending finaliser list
 105
 106 /* Which stage of processing various kinds of weak pointer are we at?
 107  * (see traverse_weak_ptr_list() below for discussion).
 108  */
 109 typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage;
 110 static WeakStage weak_stage;
 111
 112 /* List of all threads during GC
 113  */
 114 static StgTSO *old_all_threads;
 115 StgTSO *resurrected_threads;
 116
 117 /* Flag indicating failure to evacuate an object to the desired
 118  * generation.
 119  */
 120 static rtsBool failed_to_evac;
 121
 122 /* Old to-space (used for two-space collector only)
 123  */
 124 static bdescr *old_to_blocks;
 125
 126 /* Data used for allocation area sizing.
 127  */
 128 static lnat new_blocks;          // blocks allocated during this GC
 129 static lnat g0s0_pcnt_kept = 30; // percentage of g0s0 live at last minor GC
 130
 131 /* Used to avoid long recursion due to selector thunks
 132  */
 133 static lnat thunk_selector_depth = 0;
 134 #define MAX_THUNK_SELECTOR_DEPTH 8
 135
 136 /* -----------------------------------------------------------------------------
 137    Static function declarations
 138    -------------------------------------------------------------------------- */
 139
 140 static void         mark_root               ( StgClosure **root );
 141 static StgClosure * evacuate                ( StgClosure *q );
 142 static void         zero_static_object_list ( StgClosure* first_static );
 143 static void         zero_mutable_list       ( StgMutClosure *first );
 144
 145 static rtsBool      traverse_weak_ptr_list  ( void );
 146 static void         mark_weak_ptr_list      ( StgWeak **list );
 147
 148 static StgClosure * eval_thunk_selector     ( nat field, StgSelector * p );
 149
 150 static void         scavenge                ( step * );
 151 static void         scavenge_mark_stack     ( void );
 152 static void         scavenge_stack          ( StgPtr p, StgPtr stack_end );
 153 static rtsBool      scavenge_one            ( StgPtr p );
 154 static void         scavenge_large          ( step * );
 155 static void         scavenge_static         ( void );
 156 static void         scavenge_mutable_list   ( generation *g );
 157 static void         scavenge_mut_once_list  ( generation *g );
 158
 159 #if 0 && defined(DEBUG)
 160 static void         gcCAFs                  ( void );
 161 #endif
 162
 163 /* -----------------------------------------------------------------------------
 164    inline functions etc. for dealing with the mark bitmap & stack.
 165    -------------------------------------------------------------------------- */
 166
 167 #define MARK_STACK_BLOCKS 4
 168
 169 static bdescr *mark_stack_bdescr;
 170 static StgPtr *mark_stack;
 171 static StgPtr *mark_sp;
 172 static StgPtr *mark_splim;
 173
 174 // Flag and pointers used for falling back to a linear scan when the
 175 // mark stack overflows.
 176 static rtsBool mark_stack_overflowed;
 177 static bdescr *oldgen_scan_bd;
 178 static StgPtr  oldgen_scan;
 179
 180 static inline rtsBool
 181 mark_stack_empty(void)
 182 {
 183     return mark_sp == mark_stack;
 184 }
 185
 186 static inline rtsBool
 187 mark_stack_full(void)
 188 {
 189     return mark_sp >= mark_splim;
 190 }
 191
 192 static inline void
 193 reset_mark_stack(void)
 194 {
 195     mark_sp = mark_stack;
 196 }
 197
 198 static inline void
 199 push_mark_stack(StgPtr p)
 200 {
 201     *mark_sp++ = p;
 202 }
 203
 204 static inline StgPtr
 205 pop_mark_stack(void)
 206 {
 207     return *--mark_sp;
 208 }
 209
 210 /* -----------------------------------------------------------------------------
 211    GarbageCollect
 212
 213    For garbage collecting generation N (and all younger generations):
 214
 215      - follow all pointers in the root set.  the root set includes all
 216        mutable objects in all steps in all generations.
 217
 218      - for each pointer, evacuate the object it points to into either
 219        + to-space in the next higher step in that generation, if one exists,
 220        + if the object's generation == N, then evacuate it to the next
 221          generation if one exists, or else to-space in the current
 222          generation.
 223        + if the object's generation < N, then evacuate it to to-space
 224          in the next generation.
 225
 226      - repeatedly scavenge to-space from each step in each generation
 227        being collected until no more objects can be evacuated.
 228
 229      - free from-space in each step, and set from-space = to-space.
 230
 231    Locks held: sched_mutex
 232
 233    -------------------------------------------------------------------------- */
 234
 235 void
 236 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 237 {
 238   bdescr *bd;
 239   step *stp;
 240   lnat live, allocated, collected = 0, copied = 0;
 241   lnat oldgen_saved_blocks = 0;
 242   nat g, s;
 243
 244 #ifdef PROFILING
 245   CostCentreStack *prev_CCS;
 246 #endif
 247
 248 #if defined(DEBUG) && defined(GRAN)
 249   IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n",
 250                      Now, Now));
 251 #endif
 252
 253 #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
1310     // if it's a pointer into to-space, then we're done
1311     if (bd->flags & BF_EVACUATED) {
1312         return p;
1313     }
1314
1315     // large objects use the evacuated flag
1316     if (bd->flags & BF_LARGE) {
1317         return NULL;
1318     }
1319
1320     // check the mark bit for compacted steps
1321     if (bd->step->is_compacted && is_marked((P_)p,bd)) {
1322         return p;
1323     }
1324
1325     switch (info->type) {
1326
1327     case IND:
1328     case IND_STATIC:
1329     case IND_PERM:
1330     case IND_OLDGEN:            // rely on compatible layout with StgInd
1331     case IND_OLDGEN_PERM:
1332       // follow indirections
1333       p = ((StgInd *)p)->indirectee;
1334       continue;
1335
1336     case EVACUATED:
1337       // alive!
1338       return ((StgEvacuated *)p)->evacuee;
1339
1340     case TSO:
1341       if (((StgTSO *)p)->what_next == ThreadRelocated) {
1342         p = (StgClosure *)((StgTSO *)p)->link;
1343         goto loop;
1344       }
1345
1346     default:
1347       // dead.
1348       return NULL;
1349     }
1350   }
1351 }
1352
1353 static void
1354 mark_root(StgClosure **root)
1355 {
1356   *root = evacuate(*root);
1357 }
1358
1359 static void
1360 addBlock(step *stp)
1361 {
1362   bdescr *bd = allocBlock();
1363   bd->gen_no = stp->gen_no;
1364   bd->step = stp;
1365
1366   if (stp->gen_no <= N) {
1367     bd->flags = BF_EVACUATED;
1368   } else {
1369     bd->flags = 0;
1370   }
1371
1372   stp->hp_bd->free = stp->hp;
1373   stp->hp_bd->link = bd;
1374   stp->hp = bd->start;
1375   stp->hpLim = stp->hp + BLOCK_SIZE_W;
1376   stp->hp_bd = bd;
1377   stp->n_to_blocks++;
1378   new_blocks++;
1379 }
1380
1381
1382 static __inline__ void
1383 upd_evacuee(StgClosure *p, StgClosure *dest)
1384 {
1385   p->header.info = &stg_EVACUATED_info;
1386   ((StgEvacuated *)p)->evacuee = dest;
1387 }
1388
1389
1390 static __inline__ StgClosure *
1391 copy(StgClosure *src, nat size, step *stp)
1392 {
1393   P_ to, from, dest;
1394 #ifdef PROFILING
1395   // @LDV profiling
1396   nat size_org = size;
1397 #endif
1398
1399   TICK_GC_WORDS_COPIED(size);
1400   /* Find out where we're going, using the handy "to" pointer in
1401    * the step of the source object.  If it turns out we need to
1402    * evacuate to an older generation, adjust it here (see comment
1403    * by evacuate()).
1404    */
1405   if (stp->gen_no < evac_gen) {
1406 #ifdef NO_EAGER_PROMOTION
1407     failed_to_evac = rtsTrue;
1408 #else
1409     stp = &generations[evac_gen].steps[0];
1410 #endif
1411   }
1412
1413   /* chain a new block onto the to-space for the destination step if
1414    * necessary.
1415    */
1416   if (stp->hp + size >= stp->hpLim) {
1417     addBlock(stp);
1418   }
1419
1420   for(to = stp->hp, from = (P_)src; size>0; --size) {
1421     *to++ = *from++;
1422   }
1423
1424   dest = stp->hp;
1425   stp->hp = to;
1426   upd_evacuee(src,(StgClosure *)dest);
1427 #ifdef PROFILING
1428   // We store the size of the just evacuated object in the LDV word so that
1429   // the profiler can guess the position of the next object later.
1430   SET_EVACUAEE_FOR_LDV(src, size_org);
1431 #endif
1432   return (StgClosure *)dest;
1433 }
1434
1435 /* Special version of copy() for when we only want to copy the info
1436  * pointer of an object, but reserve some padding after it.  This is
1437  * used to optimise evacuation of BLACKHOLEs.
1438  */
1439
1440
1441 static StgClosure *
1442 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1443 {
1444   P_ dest, to, from;
1445 #ifdef PROFILING
1446   // @LDV profiling
1447   nat size_to_copy_org = size_to_copy;
1448 #endif
1449
1450   TICK_GC_WORDS_COPIED(size_to_copy);
1451   if (stp->gen_no < evac_gen) {
1452 #ifdef NO_EAGER_PROMOTION
1453     failed_to_evac = rtsTrue;
1454 #else
1455     stp = &generations[evac_gen].steps[0];
1456 #endif
1457   }
1458
1459   if (stp->hp + size_to_reserve >= stp->hpLim) {
1460     addBlock(stp);
1461   }
1462
1463   for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1464     *to++ = *from++;
1465   }
1466
1467   dest = stp->hp;
1468   stp->hp += size_to_reserve;
1469   upd_evacuee(src,(StgClosure *)dest);
1470 #ifdef PROFILING
1471   // We store the size of the just evacuated object in the LDV word so that
1472   // the profiler can guess the position of the next object later.
1473   // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1474   // words.
1475   SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1476   // fill the slop
1477   if (size_to_reserve - size_to_copy_org > 0)
1478     FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1479 #endif
1480   return (StgClosure *)dest;
1481 }
1482
1483
1484 /* -----------------------------------------------------------------------------
1485    Evacuate a large object
1486
1487    This just consists of removing the object from the (doubly-linked)
1488    step->large_objects list, and linking it on to the (singly-linked)
1489    step->new_large_objects list, from where it will be scavenged later.
1490
1491    Convention: bd->flags has BF_EVACUATED set for a large object
1492    that has been evacuated, or unset otherwise.
1493    -------------------------------------------------------------------------- */
1494
1495
1496 static inline void
1497 evacuate_large(StgPtr p)
1498 {
1499   bdescr *bd = Bdescr(p);
1500   step *stp;
1501
1502   // object must be at the beginning of the block (or be a ByteArray)
1503   ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1504          (((W_)p & BLOCK_MASK) == 0));
1505
1506   // already evacuated?
1507   if (bd->flags & BF_EVACUATED) {
1508     /* Don't forget to set the failed_to_evac flag if we didn't get
1509      * the desired destination (see comments in evacuate()).
1510      */
1511     if (bd->gen_no < evac_gen) {
1512       failed_to_evac = rtsTrue;
1513       TICK_GC_FAILED_PROMOTION();
1514     }
1515     return;
1516   }
1517
1518   stp = bd->step;
1519   // remove from large_object list
1520   if (bd->u.back) {
1521     bd->u.back->link = bd->link;
1522   } else { // first object in the list
1523     stp->large_objects = bd->link;
1524   }
1525   if (bd->link) {
1526     bd->link->u.back = bd->u.back;
1527   }
1528
1529   /* link it on to the evacuated large object list of the destination step
1530    */
1531   stp = bd->step->to;
1532   if (stp->gen_no < evac_gen) {
1533 #ifdef NO_EAGER_PROMOTION
1534     failed_to_evac = rtsTrue;
1535 #else
1536     stp = &generations[evac_gen].steps[0];
1537 #endif
1538   }
1539
1540   bd->step = stp;
1541   bd->gen_no = stp->gen_no;
1542   bd->link = stp->new_large_objects;
1543   stp->new_large_objects = bd;
1544   bd->flags |= BF_EVACUATED;
1545 }
1546
1547 /* -----------------------------------------------------------------------------
1548    Adding a MUT_CONS to an older generation.
1549
1550    This is necessary from time to time when we end up with an
1551    old-to-new generation pointer in a non-mutable object.  We defer
1552    the promotion until the next GC.
1553    -------------------------------------------------------------------------- */
1554
1555
1556 static StgClosure *
1557 mkMutCons(StgClosure *ptr, generation *gen)
1558 {
1559   StgMutVar *q;
1560   step *stp;
1561
1562   stp = &gen->steps[0];
1563
1564   /* chain a new block onto the to-space for the destination step if
1565    * necessary.
1566    */
1567   if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
1568     addBlock(stp);
1569   }
1570
1571   q = (StgMutVar *)stp->hp;
1572   stp->hp += sizeofW(StgMutVar);
1573
1574   SET_HDR(q,&stg_MUT_CONS_info,CCS_GC);
1575   q->var = ptr;
1576   recordOldToNewPtrs((StgMutClosure *)q);
1577
1578   return (StgClosure *)q;
1579 }
1580
1581 /* -----------------------------------------------------------------------------
1582    Evacuate
1583
1584    This is called (eventually) for every live object in the system.
1585
1586    The caller to evacuate specifies a desired generation in the
1587    evac_gen global variable.  The following conditions apply to
1588    evacuating an object which resides in generation M when we're
1589    collecting up to generation N
1590
1591    if  M >= evac_gen
1592            if  M > N     do nothing
1593            else          evac to step->to
1594
1595    if  M < evac_gen      evac to evac_gen, step 0
1596
1597    if the object is already evacuated, then we check which generation
1598    it now resides in.
1599
1600    if  M >= evac_gen     do nothing
1601    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1602                          didn't manage to evacuate this object into evac_gen.
1603
1604    -------------------------------------------------------------------------- */
1605
1606 static StgClosure *
1607 evacuate(StgClosure *q)
1608 {
1609   StgClosure *to;
1610   bdescr *bd = NULL;
1611   step *stp;
1612   const StgInfoTable *info;
1613
1614 loop:
1615   if (HEAP_ALLOCED(q)) {
1616     bd = Bdescr((P_)q);
1617
1618     if (bd->gen_no > N) {
1619         /* Can't evacuate this object, because it's in a generation
1620          * older than the ones we're collecting.  Let's hope that it's
1621          * in evac_gen or older, or we will have to arrange to track
1622          * this pointer using the mutable list.
1623          */
1624         if (bd->gen_no < evac_gen) {
1625             // nope
1626             failed_to_evac = rtsTrue;
1627             TICK_GC_FAILED_PROMOTION();
1628         }
1629         return q;
1630     }
1631
1632     /* evacuate large objects by re-linking them onto a different list.
1633      */
1634     if (bd->flags & BF_LARGE) {
1635         info = get_itbl(q);
1636         if (info->type == TSO &&
1637             ((StgTSO *)q)->what_next == ThreadRelocated) {
1638             q = (StgClosure *)((StgTSO *)q)->link;
1639             goto loop;
1640         }
1641         evacuate_large((P_)q);
1642         return q;
1643     }
1644
1645     /* If the object is in a step that we're compacting, then we
1646      * need to use an alternative evacuate procedure.
1647      */
1648     if (bd->step->is_compacted) {
1649         if (!is_marked((P_)q,bd)) {
1650             mark((P_)q,bd);
1651             if (mark_stack_full()) {
1652                 mark_stack_overflowed = rtsTrue;
1653                 reset_mark_stack();
1654             }
1655             push_mark_stack((P_)q);
1656         }
1657         return q;
1658     }
1659
1660     stp = bd->step->to;
1661   }
1662 #ifdef DEBUG
1663   else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1664 #endif
1665
1666   // make sure the info pointer is into text space
1667   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1668                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1669   info = get_itbl(q);
1670
1671   switch (info -> type) {
1672
1673   case MUT_VAR:
1674   case MVAR:
1675       to = copy(q,sizeW_fromITBL(info),stp);
1676       return to;
1677
1678   case CONSTR_0_1:
1679   {
1680       StgWord w = (StgWord)q->payload[0];
1681       if (q->header.info == Czh_con_info &&
1682           // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&
1683           (StgChar)w <= MAX_CHARLIKE) {
1684           return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1685       }
1686       if (q->header.info == Izh_con_info &&
1687           (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1688           return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1689       }
1690       // else, fall through ...
1691   }
1692
1693   case FUN_1_0:
1694   case FUN_0_1:
1695   case CONSTR_1_0:
1696     return copy(q,sizeofW(StgHeader)+1,stp);
1697
1698   case THUNK_1_0:               // here because of MIN_UPD_SIZE
1699   case THUNK_0_1:
1700   case THUNK_1_1:
1701   case THUNK_0_2:
1702   case THUNK_2_0:
1703 #ifdef NO_PROMOTE_THUNKS
1704     if (bd->gen_no == 0 &&
1705         bd->step->no != 0 &&
1706         bd->step->no == generations[bd->gen_no].n_steps-1) {
1707       stp = bd->step;
1708     }
1709 #endif
1710     return copy(q,sizeofW(StgHeader)+2,stp);
1711
1712   case FUN_1_1:
1713   case FUN_0_2:
1714   case FUN_2_0:
1715   case CONSTR_1_1:
1716   case CONSTR_0_2:
1717   case CONSTR_2_0:
1718     return copy(q,sizeofW(StgHeader)+2,stp);
1719
1720   case FUN:
1721   case THUNK:
1722   case CONSTR:
1723   case IND_PERM:
1724   case IND_OLDGEN_PERM:
1725   case WEAK:
1726   case FOREIGN:
1727   case STABLE_NAME:
1728   case BCO:
1729     return copy(q,sizeW_fromITBL(info),stp);
1730
1731   case CAF_BLACKHOLE:
1732   case SE_CAF_BLACKHOLE:
1733   case SE_BLACKHOLE:
1734   case BLACKHOLE:
1735     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1736
1737   case BLACKHOLE_BQ:
1738     to = copy(q,BLACKHOLE_sizeW(),stp);
1739     return to;
1740
1741   case THUNK_SELECTOR:
1742     {
1743         StgClosure *p;
1744
1745         if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
1746             return copy(q,THUNK_SELECTOR_sizeW(),stp);
1747         }
1748
1749         p = eval_thunk_selector(info->layout.selector_offset,
1750                                 (StgSelector *)q);
1751
1752         if (p == NULL) {
1753             return copy(q,THUNK_SELECTOR_sizeW(),stp);
1754         } else {
1755             // q is still BLACKHOLE'd.
1756             thunk_selector_depth++;
1757             p = evacuate(p);
1758             thunk_selector_depth--;
1759             upd_evacuee(q,p);
1760             return p;
1761         }
1762     }
1763
1764   case IND:
1765   case IND_OLDGEN:
1766     // follow chains of indirections, don't evacuate them
1767     q = ((StgInd*)q)->indirectee;
1768     goto loop;
1769
1770   case THUNK_STATIC:
1771     if (info->srt_len > 0 && major_gc &&
1772         THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1773       THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1774       static_objects = (StgClosure *)q;
1775     }
1776     return q;
1777
1778   case FUN_STATIC:
1779     if (info->srt_len > 0 && major_gc &&
1780         FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1781       FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1782       static_objects = (StgClosure *)q;
1783     }
1784     return q;
1785
1786   case IND_STATIC:
1787     /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1788      * on the CAF list, so don't do anything with it here (we'll
1789      * scavenge it later).
1790      */
1791     if (major_gc
1792           && ((StgIndStatic *)q)->saved_info == NULL
1793           && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1794         IND_STATIC_LINK((StgClosure *)q) = static_objects;
1795         static_objects = (StgClosure *)q;
1796     }
1797     return q;
1798
1799   case CONSTR_STATIC:
1800     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1801       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1802       static_objects = (StgClosure *)q;
1803     }
1804     return q;
1805
1806   case CONSTR_INTLIKE:
1807   case CONSTR_CHARLIKE:
1808   case CONSTR_NOCAF_STATIC:
1809     /* no need to put these on the static linked list, they don't need
1810      * to be scavenged.
1811      */
1812     return q;
1813
1814   case RET_BCO:
1815   case RET_SMALL:
1816   case RET_VEC_SMALL:
1817   case RET_BIG:
1818   case RET_VEC_BIG:
1819   case RET_DYN:
1820   case UPDATE_FRAME:
1821   case STOP_FRAME:
1822   case CATCH_FRAME:
1823   case SEQ_FRAME:
1824     // shouldn't see these
1825     barf("evacuate: stack frame at %p\n", q);
1826
1827   case AP_UPD:
1828   case PAP:
1829     /* PAPs and AP_UPDs are special - the payload is a copy of a chunk
1830      * of stack, tagging and all.
1831      */
1832       return copy(q,pap_sizeW((StgPAP*)q),stp);
1833
1834   case EVACUATED:
1835     /* Already evacuated, just return the forwarding address.
1836      * HOWEVER: if the requested destination generation (evac_gen) is
1837      * older than the actual generation (because the object was
1838      * already evacuated to a younger generation) then we have to
1839      * set the failed_to_evac flag to indicate that we couldn't
1840      * manage to promote the object to the desired generation.
1841      */
1842     if (evac_gen > 0) {         // optimisation
1843       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1844       if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
1845         failed_to_evac = rtsTrue;
1846         TICK_GC_FAILED_PROMOTION();
1847       }
1848     }
1849     return ((StgEvacuated*)q)->evacuee;
1850
1851   case ARR_WORDS:
1852       // just copy the block
1853       return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1854
1855   case MUT_ARR_PTRS:
1856   case MUT_ARR_PTRS_FROZEN:
1857       // just copy the block
1858       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1859
1860   case TSO:
1861     {
1862       StgTSO *tso = (StgTSO *)q;
1863
1864       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1865        */
1866       if (tso->what_next == ThreadRelocated) {
1867         q = (StgClosure *)tso->link;
1868         goto loop;
1869       }
1870
1871       /* To evacuate a small TSO, we need to relocate the update frame
1872        * list it contains.
1873        */
1874       {
1875           StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),stp);
1876           move_TSO(tso, new_tso);
1877           return (StgClosure *)new_tso;
1878       }
1879     }
1880
1881 #if defined(PAR)
1882   case RBH: // cf. BLACKHOLE_BQ
1883     {
1884       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1885       to = copy(q,BLACKHOLE_sizeW(),stp);
1886       //ToDo: derive size etc from reverted IP
1887       //to = copy(q,size,stp);
1888       IF_DEBUG(gc,
1889                belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1890                      q, info_type(q), to, info_type(to)));
1891       return to;
1892     }
1893
1894   case BLOCKED_FETCH:
1895     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1896     to = copy(q,sizeofW(StgBlockedFetch),stp);
1897     IF_DEBUG(gc,
1898              belch("@@ evacuate: %p (%s) to %p (%s)",
1899                    q, info_type(q), to, info_type(to)));
1900     return to;
1901
1902 # ifdef DIST
1903   case REMOTE_REF:
1904 # endif
1905   case FETCH_ME:
1906     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1907     to = copy(q,sizeofW(StgFetchMe),stp);
1908     IF_DEBUG(gc,
1909              belch("@@ evacuate: %p (%s) to %p (%s)",
1910                    q, info_type(q), to, info_type(to)));
1911     return to;
1912
1913   case FETCH_ME_BQ:
1914     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1915     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1916     IF_DEBUG(gc,
1917              belch("@@ evacuate: %p (%s) to %p (%s)",
1918                    q, info_type(q), to, info_type(to)));
1919     return to;
1920 #endif
1921
1922   default:
1923     barf("evacuate: strange closure type %d", (int)(info->type));
1924   }
1925
1926   barf("evacuate");
1927 }
1928
1929 /* -----------------------------------------------------------------------------
1930    Evaluate a THUNK_SELECTOR if possible.
1931
1932    returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
1933    a closure pointer if we evaluated it and this is the result.  Note
1934    that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
1935    reducing it to HNF, just that we have eliminated the selection.
1936    The result might be another thunk, or even another THUNK_SELECTOR.
1937
1938    If the return value is non-NULL, the original selector thunk has
1939    been BLACKHOLE'd, and should be updated with an indirection or a
1940    forwarding pointer.  If the return value is NULL, then the selector
1941    thunk is unchanged.
1942    -------------------------------------------------------------------------- */
1943
1944 static StgClosure *
1945 eval_thunk_selector( nat field, StgSelector * p )
1946 {
1947     StgInfoTable *info;
1948     const StgInfoTable *info_ptr;
1949     StgClosure *selectee;
1950
1951     selectee = p->selectee;
1952
1953     // Save the real info pointer (NOTE: not the same as get_itbl()).
1954     info_ptr = p->header.info;
1955
1956     // If the THUNK_SELECTOR is in a generation that we are not
1957     // collecting, then bail out early.  We won't be able to save any
1958     // space in any case, and updating with an indirection is trickier
1959     // in an old gen.
1960     if (Bdescr((StgPtr)p)->gen_no > N) {
1961         return NULL;
1962     }
1963
1964     // BLACKHOLE the selector thunk, since it is now under evaluation.
1965     // This is important to stop us going into an infinite loop if
1966     // this selector thunk eventually refers to itself.
1967     SET_INFO(p,&stg_BLACKHOLE_info);
1968
1969 selector_loop:
1970
1971     info = get_itbl(selectee);
1972     switch (info->type) {
1973       case CONSTR:
1974       case CONSTR_1_0:
1975       case CONSTR_0_1:
1976       case CONSTR_2_0:
1977       case CONSTR_1_1:
1978       case CONSTR_0_2:
1979       case CONSTR_STATIC:
1980       case CONSTR_NOCAF_STATIC:
1981           // check that the size is in range
1982           ASSERT(field <  (StgWord32)(info->layout.payload.ptrs +
1983                                       info->layout.payload.nptrs));
1984
1985           return selectee->payload[field];
1986
1987       case IND:
1988       case IND_STATIC:
1989       case IND_PERM:
1990       case IND_OLDGEN:
1991       case IND_OLDGEN_PERM:
1992           selectee = ((StgInd *)selectee)->indirectee;
1993           goto selector_loop;
1994
1995       case EVACUATED:
1996           // We don't follow pointers into to-space; the constructor
1997           // has already been evacuated, so we won't save any space
1998           // leaks by evaluating this selector thunk anyhow.
1999           break;
2000
2001       case THUNK_SELECTOR:
2002       {
2003           StgClosure *val;
2004
2005           // check that we don't recurse too much, re-using the
2006           // depth bound also used in evacuate().
2007           thunk_selector_depth++;
2008           if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2009               break;
2010           }
2011
2012           val = eval_thunk_selector(info->layout.selector_offset,
2013                                     (StgSelector *)selectee);
2014
2015           thunk_selector_depth--;
2016
2017           if (val == NULL) {
2018               break;
2019           } else {
2020               // We evaluated this selector thunk, so update it with
2021               // an indirection.  NOTE: we don't use UPD_IND here,
2022               // because we are guaranteed that p is in a generation
2023               // that we are collecting, and we never want to put the
2024               // indirection on a mutable list.
2025               ((StgInd *)selectee)->indirectee = val;
2026               SET_INFO(selectee,&stg_IND_info);
2027               selectee = val;
2028               goto selector_loop;
2029           }
2030       }
2031
2032       case AP_UPD:
2033       case THUNK:
2034       case THUNK_1_0:
2035       case THUNK_0_1:
2036       case THUNK_2_0:
2037       case THUNK_1_1:
2038       case THUNK_0_2:
2039       case THUNK_STATIC:
2040       case CAF_BLACKHOLE:
2041       case SE_CAF_BLACKHOLE:
2042       case SE_BLACKHOLE:
2043       case BLACKHOLE:
2044       case BLACKHOLE_BQ:
2045 #if defined(PAR)
2046       case RBH:
2047       case BLOCKED_FETCH:
2048 # ifdef DIST
2049       case REMOTE_REF:
2050 # endif
2051       case FETCH_ME:
2052       case FETCH_ME_BQ:
2053 #endif
2054           // not evaluated yet
2055           break;
2056
2057       default:
2058         barf("eval_thunk_selector: strange selectee %d",
2059              (int)(info->type));
2060     }
2061
2062     // We didn't manage to evaluate this thunk; restore the old info pointer
2063     SET_INFO(p, info_ptr);
2064     return NULL;
2065 }
2066
2067 /* -----------------------------------------------------------------------------
2068    move_TSO is called to update the TSO structure after it has been
2069    moved from one place to another.
2070    -------------------------------------------------------------------------- */
2071
2072 void
2073 move_TSO(StgTSO *src, StgTSO *dest)
2074 {
2075     ptrdiff_t diff;
2076
2077     // relocate the stack pointers...
2078     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2079     dest->sp = (StgPtr)dest->sp + diff;
2080     dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
2081
2082     relocate_stack(dest, diff);
2083 }
2084
2085 /* -----------------------------------------------------------------------------
2086    relocate_stack is called to update the linkage between
2087    UPDATE_FRAMEs (and SEQ_FRAMEs etc.) when a stack is moved from one
2088    place to another.
2089    -------------------------------------------------------------------------- */
2090
2091 StgTSO *
2092 relocate_stack(StgTSO *dest, ptrdiff_t diff)
2093 {
2094   StgUpdateFrame *su;
2095   StgCatchFrame  *cf;
2096   StgSeqFrame    *sf;
2097
2098   su = dest->su;
2099
2100   while ((P_)su < dest->stack + dest->stack_size) {
2101     switch (get_itbl(su)->type) {
2102
2103       // GCC actually manages to common up these three cases!
2104
2105     case UPDATE_FRAME:
2106       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
2107       su = su->link;
2108       continue;
2109
2110     case CATCH_FRAME:
2111       cf = (StgCatchFrame *)su;
2112       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
2113       su = cf->link;
2114       continue;
2115
2116     case SEQ_FRAME:
2117       sf = (StgSeqFrame *)su;
2118       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
2119       su = sf->link;
2120       continue;
2121
2122     case STOP_FRAME:
2123       // all done!
2124       break;
2125
2126     default:
2127       barf("relocate_stack %d", (int)(get_itbl(su)->type));
2128     }
2129     break;
2130   }
2131
2132   return dest;
2133 }
2134
2135
2136
2137 static inline void
2138 scavenge_srt(const StgInfoTable *info)
2139 {
2140   StgClosure **srt, **srt_end;
2141
2142   /* evacuate the SRT.  If srt_len is zero, then there isn't an
2143    * srt field in the info table.  That's ok, because we'll
2144    * never dereference it.
2145    */
2146   srt = (StgClosure **)(info->srt);
2147   srt_end = srt + info->srt_len;
2148   for (; srt < srt_end; srt++) {
2149     /* Special-case to handle references to closures hiding out in DLLs, since
2150        double indirections required to get at those. The code generator knows
2151        which is which when generating the SRT, so it stores the (indirect)
2152        reference to the DLL closure in the table by first adding one to it.
2153        We check for this here, and undo the addition before evacuating it.
2154
2155        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2156        closure that's fixed at link-time, and no extra magic is required.
2157     */
2158 #ifdef ENABLE_WIN32_DLL_SUPPORT
2159     if ( (unsigned long)(*srt) & 0x1 ) {
2160        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2161     } else {
2162        evacuate(*srt);
2163     }
2164 #else
2165        evacuate(*srt);
2166 #endif
2167   }
2168 }
2169
2170 /* -----------------------------------------------------------------------------
2171    Scavenge a TSO.
2172    -------------------------------------------------------------------------- */
2173
2174 static void
2175 scavengeTSO (StgTSO *tso)
2176 {
2177   // chase the link field for any TSOs on the same queue
2178   (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2179   if (   tso->why_blocked == BlockedOnMVar
2180          || tso->why_blocked == BlockedOnBlackHole
2181          || tso->why_blocked == BlockedOnException
2182 #if defined(PAR)
2183          || tso->why_blocked == BlockedOnGA
2184          || tso->why_blocked == BlockedOnGA_NoSend
2185 #endif
2186          ) {
2187     tso->block_info.closure = evacuate(tso->block_info.closure);
2188   }
2189   if ( tso->blocked_exceptions != NULL ) {
2190     tso->blocked_exceptions =
2191       (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2192   }
2193   // scavenge this thread's stack
2194   scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2195 }
2196
2197 /* -----------------------------------------------------------------------------
2198    Scavenge a given step until there are no more objects in this step
2199    to scavenge.
2200
2201    evac_gen is set by the caller to be either zero (for a step in a
2202    generation < N) or G where G is the generation of the step being
2203    scavenged.
2204
2205    We sometimes temporarily change evac_gen back to zero if we're
2206    scavenging a mutable object where early promotion isn't such a good
2207    idea.
2208    -------------------------------------------------------------------------- */
2209
2210 static void
2211 scavenge(step *stp)
2212 {
2213   StgPtr p, q;
2214   StgInfoTable *info;
2215   bdescr *bd;
2216   nat saved_evac_gen = evac_gen;
2217
2218   p = stp->scan;
2219   bd = stp->scan_bd;
2220
2221   failed_to_evac = rtsFalse;
2222
2223   /* scavenge phase - standard breadth-first scavenging of the
2224    * evacuated objects
2225    */
2226
2227   while (bd != stp->hp_bd || p < stp->hp) {
2228
2229     // If we're at the end of this block, move on to the next block
2230     if (bd != stp->hp_bd && p == bd->free) {
2231       bd = bd->link;
2232       p = bd->start;
2233       continue;
2234     }
2235
2236     info = get_itbl((StgClosure *)p);
2237     ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2238
2239     ASSERT(thunk_selector_depth == 0);
2240
2241     q = p;
2242     switch (info->type) {
2243
2244     case MVAR:
2245         /* treat MVars specially, because we don't want to evacuate the
2246          * mut_link field in the middle of the closure.
2247          */
2248     {
2249         StgMVar *mvar = ((StgMVar *)p);
2250         evac_gen = 0;
2251         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2252         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2253         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2254         evac_gen = saved_evac_gen;
2255         recordMutable((StgMutClosure *)mvar);
2256         failed_to_evac = rtsFalse; // mutable.
2257         p += sizeofW(StgMVar);
2258         break;
2259     }
2260
2261     case THUNK_2_0:
2262     case FUN_2_0:
2263         scavenge_srt(info);
2264     case CONSTR_2_0:
2265         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2266         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2267         p += sizeofW(StgHeader) + 2;
2268         break;
2269
2270     case THUNK_1_0:
2271         scavenge_srt(info);
2272         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2273         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2274         break;
2275
2276     case FUN_1_0:
2277         scavenge_srt(info);
2278     case CONSTR_1_0:
2279         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2280         p += sizeofW(StgHeader) + 1;
2281         break;
2282
2283     case THUNK_0_1:
2284         scavenge_srt(info);
2285         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2286         break;
2287
2288     case FUN_0_1:
2289         scavenge_srt(info);
2290     case CONSTR_0_1:
2291         p += sizeofW(StgHeader) + 1;
2292         break;
2293
2294     case THUNK_0_2:
2295     case FUN_0_2:
2296         scavenge_srt(info);
2297     case CONSTR_0_2:
2298         p += sizeofW(StgHeader) + 2;
2299         break;
2300
2301     case THUNK_1_1:
2302     case FUN_1_1:
2303         scavenge_srt(info);
2304     case CONSTR_1_1:
2305         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2306         p += sizeofW(StgHeader) + 2;
2307         break;
2308
2309     case FUN:
2310     case THUNK:
2311         scavenge_srt(info);
2312         // fall through
2313
2314     case CONSTR:
2315     case WEAK:
2316     case FOREIGN:
2317     case STABLE_NAME:
2318     case BCO:
2319     {
2320         StgPtr end;
2321
2322         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2323         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2324             (StgClosure *)*p = evacuate((StgClosure *)*p);
2325         }
2326         p += info->layout.payload.nptrs;
2327         break;
2328     }
2329
2330     case IND_PERM:
2331       if (stp->gen->no != 0) {
2332 #ifdef PROFILING
2333         // @LDV profiling
2334         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2335         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2336         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2337 #endif
2338         //
2339         // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
2340         //
2341         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2342 #ifdef PROFILING
2343         // @LDV profiling
2344         // We pretend that p has just been created.
2345         LDV_recordCreate((StgClosure *)p);
2346 #endif
2347       }
2348         // fall through
2349     case IND_OLDGEN_PERM:
2350         ((StgIndOldGen *)p)->indirectee =
2351             evacuate(((StgIndOldGen *)p)->indirectee);
2352         if (failed_to_evac) {
2353             failed_to_evac = rtsFalse;
2354             recordOldToNewPtrs((StgMutClosure *)p);
2355         }
2356         p += sizeofW(StgIndOldGen);
2357         break;
2358
2359     case MUT_VAR:
2360         evac_gen = 0;
2361         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2362         evac_gen = saved_evac_gen;
2363         recordMutable((StgMutClosure *)p);
2364         failed_to_evac = rtsFalse; // mutable anyhow
2365         p += sizeofW(StgMutVar);
2366         break;
2367
2368     case MUT_CONS:
2369         // ignore these
2370         failed_to_evac = rtsFalse; // mutable anyhow
2371         p += sizeofW(StgMutVar);
2372         break;
2373
2374     case CAF_BLACKHOLE:
2375     case SE_CAF_BLACKHOLE:
2376     case SE_BLACKHOLE:
2377     case BLACKHOLE:
2378         p += BLACKHOLE_sizeW();
2379         break;
2380
2381     case BLACKHOLE_BQ:
2382     {
2383         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2384         (StgClosure *)bh->blocking_queue =
2385             evacuate((StgClosure *)bh->blocking_queue);
2386         recordMutable((StgMutClosure *)bh);
2387         failed_to_evac = rtsFalse;
2388         p += BLACKHOLE_sizeW();
2389         break;
2390     }
2391
2392     case THUNK_SELECTOR:
2393     {
2394         StgSelector *s = (StgSelector *)p;
2395         s->selectee = evacuate(s->selectee);
2396         p += THUNK_SELECTOR_sizeW();
2397         break;
2398     }
2399
2400     case AP_UPD: // same as PAPs
2401     case PAP:
2402         /* Treat a PAP just like a section of stack, not forgetting to
2403          * evacuate the function pointer too...
2404          */
2405     {
2406         StgPAP* pap = (StgPAP *)p;
2407
2408         pap->fun = evacuate(pap->fun);
2409         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2410         p += pap_sizeW(pap);
2411         break;
2412     }
2413
2414     case ARR_WORDS:
2415         // nothing to follow
2416         p += arr_words_sizeW((StgArrWords *)p);
2417         break;
2418
2419     case MUT_ARR_PTRS:
2420         // follow everything
2421     {
2422         StgPtr next;
2423
2424         evac_gen = 0;           // repeatedly mutable
2425         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2426         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2427             (StgClosure *)*p = evacuate((StgClosure *)*p);
2428         }
2429         evac_gen = saved_evac_gen;
2430         recordMutable((StgMutClosure *)q);
2431         failed_to_evac = rtsFalse; // mutable anyhow.
2432         break;
2433     }
2434
2435     case MUT_ARR_PTRS_FROZEN:
2436         // follow everything
2437     {
2438         StgPtr next;
2439
2440         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2441         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2442             (StgClosure *)*p = evacuate((StgClosure *)*p);
2443         }
2444         // it's tempting to recordMutable() if failed_to_evac is
2445         // false, but that breaks some assumptions (eg. every
2446         // closure on the mutable list is supposed to have the MUT
2447         // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2448         break;
2449     }
2450
2451     case TSO:
2452     {
2453         StgTSO *tso = (StgTSO *)p;
2454         evac_gen = 0;
2455         scavengeTSO(tso);
2456         evac_gen = saved_evac_gen;
2457         recordMutable((StgMutClosure *)tso);
2458         failed_to_evac = rtsFalse; // mutable anyhow.
2459         p += tso_sizeW(tso);
2460         break;
2461     }
2462
2463 #if defined(PAR)
2464     case RBH: // cf. BLACKHOLE_BQ
2465     {
2466 #if 0
2467         nat size, ptrs, nonptrs, vhs;
2468         char str[80];
2469         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2470 #endif
2471         StgRBH *rbh = (StgRBH *)p;
2472         (StgClosure *)rbh->blocking_queue =
2473             evacuate((StgClosure *)rbh->blocking_queue);
2474         recordMutable((StgMutClosure *)to);
2475         failed_to_evac = rtsFalse;  // mutable anyhow.
2476         IF_DEBUG(gc,
2477                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2478                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2479         // ToDo: use size of reverted closure here!
2480         p += BLACKHOLE_sizeW();
2481         break;
2482     }
2483
2484     case BLOCKED_FETCH:
2485     {
2486         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2487         // follow the pointer to the node which is being demanded
2488         (StgClosure *)bf->node =
2489             evacuate((StgClosure *)bf->node);
2490         // follow the link to the rest of the blocking queue
2491         (StgClosure *)bf->link =
2492             evacuate((StgClosure *)bf->link);
2493         if (failed_to_evac) {
2494             failed_to_evac = rtsFalse;
2495             recordMutable((StgMutClosure *)bf);
2496         }
2497         IF_DEBUG(gc,
2498                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2499                        bf, info_type((StgClosure *)bf),
2500                        bf->node, info_type(bf->node)));
2501         p += sizeofW(StgBlockedFetch);
2502         break;
2503     }
2504
2505 #ifdef DIST
2506     case REMOTE_REF:
2507 #endif
2508     case FETCH_ME:
2509         p += sizeofW(StgFetchMe);
2510         break; // nothing to do in this case
2511
2512     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2513     {
2514         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2515         (StgClosure *)fmbq->blocking_queue =
2516             evacuate((StgClosure *)fmbq->blocking_queue);
2517         if (failed_to_evac) {
2518             failed_to_evac = rtsFalse;
2519             recordMutable((StgMutClosure *)fmbq);
2520         }
2521         IF_DEBUG(gc,
2522                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2523                        p, info_type((StgClosure *)p)));
2524         p += sizeofW(StgFetchMeBlockingQueue);
2525         break;
2526     }
2527 #endif
2528
2529     default:
2530         barf("scavenge: unimplemented/strange closure type %d @ %p",
2531              info->type, p);
2532     }
2533
2534     /* If we didn't manage to promote all the objects pointed to by
2535      * the current object, then we have to designate this object as
2536      * mutable (because it contains old-to-new generation pointers).
2537      */
2538     if (failed_to_evac) {
2539         failed_to_evac = rtsFalse;
2540         mkMutCons((StgClosure *)q, &generations[evac_gen]);
2541     }
2542   }
2543
2544   stp->scan_bd = bd;
2545   stp->scan = p;
2546 }
2547
2548 /* -----------------------------------------------------------------------------
2549    Scavenge everything on the mark stack.
2550
2551    This is slightly different from scavenge():
2552       - we don't walk linearly through the objects, so the scavenger
2553         doesn't need to advance the pointer on to the next object.
2554    -------------------------------------------------------------------------- */
2555
2556 static void
2557 scavenge_mark_stack(void)
2558 {
2559     StgPtr p, q;
2560     StgInfoTable *info;
2561     nat saved_evac_gen;
2562
2563     evac_gen = oldest_gen->no;
2564     saved_evac_gen = evac_gen;
2565
2566 linear_scan:
2567     while (!mark_stack_empty()) {
2568         p = pop_mark_stack();
2569
2570         info = get_itbl((StgClosure *)p);
2571         ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2572
2573         q = p;
2574         switch (info->type) {
2575
2576         case MVAR:
2577             /* treat MVars specially, because we don't want to evacuate the
2578              * mut_link field in the middle of the closure.
2579              */
2580         {
2581             StgMVar *mvar = ((StgMVar *)p);
2582             evac_gen = 0;
2583             (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2584             (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2585             (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2586             evac_gen = saved_evac_gen;
2587             failed_to_evac = rtsFalse; // mutable.
2588             break;
2589         }
2590
2591         case FUN_2_0:
2592         case THUNK_2_0:
2593             scavenge_srt(info);
2594         case CONSTR_2_0:
2595             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2596             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2597             break;
2598
2599         case FUN_1_0:
2600         case FUN_1_1:
2601         case THUNK_1_0:
2602         case THUNK_1_1:
2603             scavenge_srt(info);
2604         case CONSTR_1_0:
2605         case CONSTR_1_1:
2606             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2607             break;
2608
2609         case FUN_0_1:
2610         case FUN_0_2:
2611         case THUNK_0_1:
2612         case THUNK_0_2:
2613             scavenge_srt(info);
2614         case CONSTR_0_1:
2615         case CONSTR_0_2:
2616             break;
2617
2618         case FUN:
2619         case THUNK:
2620             scavenge_srt(info);
2621             // fall through
2622
2623         case CONSTR:
2624         case WEAK:
2625         case FOREIGN:
2626         case STABLE_NAME:
2627         case BCO:
2628         {
2629             StgPtr end;
2630
2631             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2632             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2633                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2634             }
2635             break;
2636         }
2637
2638         case IND_PERM:
2639             // don't need to do anything here: the only possible case
2640             // is that we're in a 1-space compacting collector, with
2641             // no "old" generation.
2642             break;
2643
2644         case IND_OLDGEN:
2645         case IND_OLDGEN_PERM:
2646             ((StgIndOldGen *)p)->indirectee =
2647                 evacuate(((StgIndOldGen *)p)->indirectee);
2648             if (failed_to_evac) {
2649                 recordOldToNewPtrs((StgMutClosure *)p);
2650             }
2651             failed_to_evac = rtsFalse;
2652             break;
2653
2654         case MUT_VAR:
2655             evac_gen = 0;
2656             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2657             evac_gen = saved_evac_gen;
2658             failed_to_evac = rtsFalse;
2659             break;
2660
2661         case MUT_CONS:
2662             // ignore these
2663             failed_to_evac = rtsFalse;
2664             break;
2665
2666         case CAF_BLACKHOLE:
2667         case SE_CAF_BLACKHOLE:
2668         case SE_BLACKHOLE:
2669         case BLACKHOLE:
2670         case ARR_WORDS:
2671             break;
2672
2673         case BLACKHOLE_BQ:
2674         {
2675             StgBlockingQueue *bh = (StgBlockingQueue *)p;
2676             (StgClosure *)bh->blocking_queue =
2677                 evacuate((StgClosure *)bh->blocking_queue);
2678             failed_to_evac = rtsFalse;
2679             break;
2680         }
2681
2682         case THUNK_SELECTOR:
2683         {
2684             StgSelector *s = (StgSelector *)p;
2685             s->selectee = evacuate(s->selectee);
2686             break;
2687         }
2688
2689         case AP_UPD: // same as PAPs
2690         case PAP:
2691             /* Treat a PAP just like a section of stack, not forgetting to
2692              * evacuate the function pointer too...
2693              */
2694         {
2695             StgPAP* pap = (StgPAP *)p;
2696
2697             pap->fun = evacuate(pap->fun);
2698             scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2699             break;
2700         }
2701
2702         case MUT_ARR_PTRS:
2703             // follow everything
2704         {
2705             StgPtr next;
2706
2707             evac_gen = 0;               // repeatedly mutable
2708             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2709             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2710                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2711             }
2712             evac_gen = saved_evac_gen;
2713             failed_to_evac = rtsFalse; // mutable anyhow.
2714             break;
2715         }
2716
2717         case MUT_ARR_PTRS_FROZEN:
2718             // follow everything
2719         {
2720             StgPtr next;
2721
2722             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2723             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2724                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2725             }
2726             break;
2727         }
2728
2729         case TSO:
2730         {
2731             StgTSO *tso = (StgTSO *)p;
2732             evac_gen = 0;
2733             scavengeTSO(tso);
2734             evac_gen = saved_evac_gen;
2735             failed_to_evac = rtsFalse;
2736             break;
2737         }
2738
2739 #if defined(PAR)
2740         case RBH: // cf. BLACKHOLE_BQ
2741         {
2742 #if 0
2743             nat size, ptrs, nonptrs, vhs;
2744             char str[80];
2745             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2746 #endif
2747             StgRBH *rbh = (StgRBH *)p;
2748             (StgClosure *)rbh->blocking_queue =
2749                 evacuate((StgClosure *)rbh->blocking_queue);
2750             recordMutable((StgMutClosure *)rbh);
2751             failed_to_evac = rtsFalse;  // mutable anyhow.
2752             IF_DEBUG(gc,
2753                      belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2754                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
2755             break;
2756         }
2757
2758         case BLOCKED_FETCH:
2759         {
2760             StgBlockedFetch *bf = (StgBlockedFetch *)p;
2761             // follow the pointer to the node which is being demanded
2762             (StgClosure *)bf->node =
2763                 evacuate((StgClosure *)bf->node);
2764             // follow the link to the rest of the blocking queue
2765             (StgClosure *)bf->link =
2766                 evacuate((StgClosure *)bf->link);
2767             if (failed_to_evac) {
2768                 failed_to_evac = rtsFalse;
2769                 recordMutable((StgMutClosure *)bf);
2770             }
2771             IF_DEBUG(gc,
2772                      belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2773                            bf, info_type((StgClosure *)bf),
2774                            bf->node, info_type(bf->node)));
2775             break;
2776         }
2777
2778 #ifdef DIST
2779         case REMOTE_REF:
2780 #endif
2781         case FETCH_ME:
2782             break; // nothing to do in this case
2783
2784         case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2785         {
2786             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2787             (StgClosure *)fmbq->blocking_queue =
2788                 evacuate((StgClosure *)fmbq->blocking_queue);
2789             if (failed_to_evac) {
2790                 failed_to_evac = rtsFalse;
2791                 recordMutable((StgMutClosure *)fmbq);
2792             }
2793             IF_DEBUG(gc,
2794                      belch("@@ scavenge: %p (%s) exciting, isn't it",
2795                            p, info_type((StgClosure *)p)));
2796             break;
2797         }
2798 #endif // PAR
2799
2800         default:
2801             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
2802                  info->type, p);
2803         }
2804
2805         if (failed_to_evac) {
2806             failed_to_evac = rtsFalse;
2807             mkMutCons((StgClosure *)q, &generations[evac_gen]);
2808         }
2809
2810         // mark the next bit to indicate "scavenged"
2811         mark(q+1, Bdescr(q));
2812
2813     } // while (!mark_stack_empty())
2814
2815     // start a new linear scan if the mark stack overflowed at some point
2816     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
2817         IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
2818         mark_stack_overflowed = rtsFalse;
2819         oldgen_scan_bd = oldest_gen->steps[0].blocks;
2820         oldgen_scan = oldgen_scan_bd->start;
2821     }
2822
2823     if (oldgen_scan_bd) {
2824         // push a new thing on the mark stack
2825     loop:
2826         // find a closure that is marked but not scavenged, and start
2827         // from there.
2828         while (oldgen_scan < oldgen_scan_bd->free
2829                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
2830             oldgen_scan++;
2831         }
2832
2833         if (oldgen_scan < oldgen_scan_bd->free) {
2834
2835             // already scavenged?
2836             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
2837                 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2838                 goto loop;
2839             }
2840             push_mark_stack(oldgen_scan);
2841             // ToDo: bump the linear scan by the actual size of the object
2842             oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2843             goto linear_scan;
2844         }
2845
2846         oldgen_scan_bd = oldgen_scan_bd->link;
2847         if (oldgen_scan_bd != NULL) {
2848             oldgen_scan = oldgen_scan_bd->start;
2849             goto loop;
2850         }
2851     }
2852 }
2853
2854 /* -----------------------------------------------------------------------------
2855    Scavenge one object.
2856
2857    This is used for objects that are temporarily marked as mutable
2858    because they contain old-to-new generation pointers.  Only certain
2859    objects can have this property.
2860    -------------------------------------------------------------------------- */
2861
2862 static rtsBool
2863 scavenge_one(StgPtr p)
2864 {
2865     const StgInfoTable *info;
2866     nat saved_evac_gen = evac_gen;
2867     rtsBool no_luck;
2868
2869     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
2870                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
2871
2872     info = get_itbl((StgClosure *)p);
2873
2874     switch (info->type) {
2875
2876     case FUN:
2877     case FUN_1_0:                       // hardly worth specialising these guys
2878     case FUN_0_1:
2879     case FUN_1_1:
2880     case FUN_0_2:
2881     case FUN_2_0:
2882     case THUNK:
2883     case THUNK_1_0:
2884     case THUNK_0_1:
2885     case THUNK_1_1:
2886     case THUNK_0_2:
2887     case THUNK_2_0:
2888     case CONSTR:
2889     case CONSTR_1_0:
2890     case CONSTR_0_1:
2891     case CONSTR_1_1:
2892     case CONSTR_0_2:
2893     case CONSTR_2_0:
2894     case WEAK:
2895     case FOREIGN:
2896     case IND_PERM:
2897     case IND_OLDGEN_PERM:
2898     {
2899         StgPtr q, end;
2900
2901         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2902         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
2903             (StgClosure *)*q = evacuate((StgClosure *)*q);
2904         }
2905         break;
2906     }
2907
2908     case CAF_BLACKHOLE:
2909     case SE_CAF_BLACKHOLE:
2910     case SE_BLACKHOLE:
2911     case BLACKHOLE:
2912         break;
2913
2914     case THUNK_SELECTOR:
2915     {
2916         StgSelector *s = (StgSelector *)p;
2917         s->selectee = evacuate(s->selectee);
2918         break;
2919     }
2920
2921     case ARR_WORDS:
2922         // nothing to follow
2923         break;
2924
2925     case MUT_ARR_PTRS:
2926     {
2927         // follow everything
2928         StgPtr next;
2929
2930         evac_gen = 0;           // repeatedly mutable
2931         recordMutable((StgMutClosure *)p);
2932         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2933         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2934             (StgClosure *)*p = evacuate((StgClosure *)*p);
2935         }
2936         evac_gen = saved_evac_gen;
2937         failed_to_evac = rtsFalse;
2938         break;
2939     }
2940
2941     case MUT_ARR_PTRS_FROZEN:
2942     {
2943         // follow everything
2944         StgPtr next;
2945
2946         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2947         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2948             (StgClosure *)*p = evacuate((StgClosure *)*p);
2949         }
2950         break;
2951     }
2952
2953     case TSO:
2954     {
2955         StgTSO *tso = (StgTSO *)p;
2956
2957         evac_gen = 0;           // repeatedly mutable
2958         scavengeTSO(tso);
2959         recordMutable((StgMutClosure *)tso);
2960         evac_gen = saved_evac_gen;
2961         failed_to_evac = rtsFalse;
2962         break;
2963     }
2964
2965     case AP_UPD:
2966     case PAP:
2967     {
2968         StgPAP* pap = (StgPAP *)p;
2969         pap->fun = evacuate(pap->fun);
2970         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2971         break;
2972     }
2973
2974     case IND_OLDGEN:
2975         // This might happen if for instance a MUT_CONS was pointing to a
2976         // THUNK which has since been updated.  The IND_OLDGEN will
2977         // be on the mutable list anyway, so we don't need to do anything
2978         // here.
2979         break;
2980
2981     default:
2982         barf("scavenge_one: strange object %d", (int)(info->type));
2983     }
2984
2985     no_luck = failed_to_evac;
2986     failed_to_evac = rtsFalse;
2987     return (no_luck);
2988 }
2989
2990 /* -----------------------------------------------------------------------------
2991    Scavenging mutable lists.
2992
2993    We treat the mutable list of each generation > N (i.e. all the
2994    generations older than the one being collected) as roots.  We also
2995    remove non-mutable objects from the mutable list at this point.
2996    -------------------------------------------------------------------------- */
2997
2998 static void
2999 scavenge_mut_once_list(generation *gen)
3000 {
3001   const StgInfoTable *info;
3002   StgMutClosure *p, *next, *new_list;
3003
3004   p = gen->mut_once_list;
3005   new_list = END_MUT_LIST;
3006   next = p->mut_link;
3007
3008   evac_gen = gen->no;
3009   failed_to_evac = rtsFalse;
3010
3011   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3012
3013     // make sure the info pointer is into text space
3014     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3015                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3016
3017     info = get_itbl(p);
3018     /*
3019     if (info->type==RBH)
3020       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3021     */
3022     switch(info->type) {
3023
3024     case IND_OLDGEN:
3025     case IND_OLDGEN_PERM:
3026     case IND_STATIC:
3027       /* Try to pull the indirectee into this generation, so we can
3028        * remove the indirection from the mutable list.
3029        */
3030       ((StgIndOldGen *)p)->indirectee =
3031         evacuate(((StgIndOldGen *)p)->indirectee);
3032
3033 #if 0 && defined(DEBUG)
3034       if (RtsFlags.DebugFlags.gc)
3035       /* Debugging code to print out the size of the thing we just
3036        * promoted
3037        */
3038       {
3039         StgPtr start = gen->steps[0].scan;
3040         bdescr *start_bd = gen->steps[0].scan_bd;
3041         nat size = 0;
3042         scavenge(&gen->steps[0]);
3043         if (start_bd != gen->steps[0].scan_bd) {
3044           size += (P_)BLOCK_ROUND_UP(start) - start;
3045           start_bd = start_bd->link;
3046           while (start_bd != gen->steps[0].scan_bd) {
3047             size += BLOCK_SIZE_W;
3048             start_bd = start_bd->link;
3049           }
3050           size += gen->steps[0].scan -
3051             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3052         } else {
3053           size = gen->steps[0].scan - start;
3054         }
3055         belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3056       }
3057 #endif
3058
3059       /* failed_to_evac might happen if we've got more than two
3060        * generations, we're collecting only generation 0, the
3061        * indirection resides in generation 2 and the indirectee is
3062        * in generation 1.
3063        */
3064       if (failed_to_evac) {
3065         failed_to_evac = rtsFalse;
3066         p->mut_link = new_list;
3067         new_list = p;
3068       } else {
3069         /* the mut_link field of an IND_STATIC is overloaded as the
3070          * static link field too (it just so happens that we don't need
3071          * both at the same time), so we need to NULL it out when
3072          * removing this object from the mutable list because the static
3073          * link fields are all assumed to be NULL before doing a major
3074          * collection.
3075          */
3076         p->mut_link = NULL;
3077       }
3078       continue;
3079
3080     case MUT_CONS:
3081         /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3082          * it from the mutable list if possible by promoting whatever it
3083          * points to.
3084          */
3085         if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3086             /* didn't manage to promote everything, so put the
3087              * MUT_CONS back on the list.
3088              */
3089             p->mut_link = new_list;
3090             new_list = p;
3091         }
3092         continue;
3093
3094     default:
3095       // shouldn't have anything else on the mutables list
3096       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3097     }
3098   }
3099
3100   gen->mut_once_list = new_list;
3101 }
3102
3103
3104 static void
3105 scavenge_mutable_list(generation *gen)
3106 {
3107   const StgInfoTable *info;
3108   StgMutClosure *p, *next;
3109
3110   p = gen->saved_mut_list;
3111   next = p->mut_link;
3112
3113   evac_gen = 0;
3114   failed_to_evac = rtsFalse;
3115
3116   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3117
3118     // make sure the info pointer is into text space
3119     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3120                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3121
3122     info = get_itbl(p);
3123     /*
3124     if (info->type==RBH)
3125       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3126     */
3127     switch(info->type) {
3128
3129     case MUT_ARR_PTRS:
3130       // follow everything
3131       p->mut_link = gen->mut_list;
3132       gen->mut_list = p;
3133       {
3134         StgPtr end, q;
3135
3136         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3137         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3138           (StgClosure *)*q = evacuate((StgClosure *)*q);
3139         }
3140         continue;
3141       }
3142
3143       // Happens if a MUT_ARR_PTRS in the old generation is frozen
3144     case MUT_ARR_PTRS_FROZEN:
3145       {
3146         StgPtr end, q;
3147
3148         evac_gen = gen->no;
3149         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3150         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3151           (StgClosure *)*q = evacuate((StgClosure *)*q);
3152         }
3153         evac_gen = 0;
3154         p->mut_link = NULL;
3155         if (failed_to_evac) {
3156             failed_to_evac = rtsFalse;
3157             mkMutCons((StgClosure *)p, gen);
3158         }
3159         continue;
3160       }
3161
3162     case MUT_VAR:
3163         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3164         p->mut_link = gen->mut_list;
3165         gen->mut_list = p;
3166         continue;
3167
3168     case MVAR:
3169       {
3170         StgMVar *mvar = (StgMVar *)p;
3171         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3172         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3173         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3174         p->mut_link = gen->mut_list;
3175         gen->mut_list = p;
3176         continue;
3177       }
3178
3179     case TSO:
3180       {
3181         StgTSO *tso = (StgTSO *)p;
3182
3183         scavengeTSO(tso);
3184
3185         /* Don't take this TSO off the mutable list - it might still
3186          * point to some younger objects (because we set evac_gen to 0
3187          * above).
3188          */
3189         tso->mut_link = gen->mut_list;
3190         gen->mut_list = (StgMutClosure *)tso;
3191         continue;
3192       }
3193
3194     case BLACKHOLE_BQ:
3195       {
3196         StgBlockingQueue *bh = (StgBlockingQueue *)p;
3197         (StgClosure *)bh->blocking_queue =
3198           evacuate((StgClosure *)bh->blocking_queue);
3199         p->mut_link = gen->mut_list;
3200         gen->mut_list = p;
3201         continue;
3202       }
3203
3204       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3205        */
3206     case IND_OLDGEN:
3207     case IND_OLDGEN_PERM:
3208       /* Try to pull the indirectee into this generation, so we can
3209        * remove the indirection from the mutable list.
3210        */
3211       evac_gen = gen->no;
3212       ((StgIndOldGen *)p)->indirectee =
3213         evacuate(((StgIndOldGen *)p)->indirectee);
3214       evac_gen = 0;
3215
3216       if (failed_to_evac) {
3217         failed_to_evac = rtsFalse;
3218         p->mut_link = gen->mut_once_list;
3219         gen->mut_once_list = p;
3220       } else {
3221         p->mut_link = NULL;
3222       }
3223       continue;
3224
3225 #if defined(PAR)
3226     // HWL: check whether all of these are necessary
3227
3228     case RBH: // cf. BLACKHOLE_BQ
3229       {
3230         // nat size, ptrs, nonptrs, vhs;
3231         // char str[80];
3232         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3233         StgRBH *rbh = (StgRBH *)p;
3234         (StgClosure *)rbh->blocking_queue =
3235           evacuate((StgClosure *)rbh->blocking_queue);
3236         if (failed_to_evac) {
3237           failed_to_evac = rtsFalse;
3238           recordMutable((StgMutClosure *)rbh);
3239         }
3240         // ToDo: use size of reverted closure here!
3241         p += BLACKHOLE_sizeW();
3242         break;
3243       }
3244
3245     case BLOCKED_FETCH:
3246       {
3247         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3248         // follow the pointer to the node which is being demanded
3249         (StgClosure *)bf->node =
3250           evacuate((StgClosure *)bf->node);
3251         // follow the link to the rest of the blocking queue
3252         (StgClosure *)bf->link =
3253           evacuate((StgClosure *)bf->link);
3254         if (failed_to_evac) {
3255           failed_to_evac = rtsFalse;
3256           recordMutable((StgMutClosure *)bf);
3257         }
3258         p += sizeofW(StgBlockedFetch);
3259         break;
3260       }
3261
3262 #ifdef DIST
3263     case REMOTE_REF:
3264       barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3265 #endif
3266     case FETCH_ME:
3267       p += sizeofW(StgFetchMe);
3268       break; // nothing to do in this case
3269
3270     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3271       {
3272         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3273         (StgClosure *)fmbq->blocking_queue =
3274           evacuate((StgClosure *)fmbq->blocking_queue);
3275         if (failed_to_evac) {
3276           failed_to_evac = rtsFalse;
3277           recordMutable((StgMutClosure *)fmbq);
3278         }
3279         p += sizeofW(StgFetchMeBlockingQueue);
3280         break;
3281       }
3282 #endif
3283
3284     default:
3285       // shouldn't have anything else on the mutables list
3286       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3287     }
3288   }
3289 }
3290
3291
3292 static void
3293 scavenge_static(void)
3294 {
3295   StgClosure* p = static_objects;
3296   const StgInfoTable *info;
3297
3298   /* Always evacuate straight to the oldest generation for static
3299    * objects */
3300   evac_gen = oldest_gen->no;
3301
3302   /* keep going until we've scavenged all the objects on the linked
3303      list... */
3304   while (p != END_OF_STATIC_LIST) {
3305
3306     info = get_itbl(p);
3307     /*
3308     if (info->type==RBH)
3309       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3310     */
3311     // make sure the info pointer is into text space
3312     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3313                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3314
3315     /* Take this object *off* the static_objects list,
3316      * and put it on the scavenged_static_objects list.
3317      */
3318     static_objects = STATIC_LINK(info,p);
3319     STATIC_LINK(info,p) = scavenged_static_objects;
3320     scavenged_static_objects = p;
3321
3322     switch (info -> type) {
3323
3324     case IND_STATIC:
3325       {
3326         StgInd *ind = (StgInd *)p;
3327         ind->indirectee = evacuate(ind->indirectee);
3328
3329         /* might fail to evacuate it, in which case we have to pop it
3330          * back on the mutable list (and take it off the
3331          * scavenged_static list because the static link and mut link
3332          * pointers are one and the same).
3333          */
3334         if (failed_to_evac) {
3335           failed_to_evac = rtsFalse;
3336           scavenged_static_objects = IND_STATIC_LINK(p);
3337           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3338           oldest_gen->mut_once_list = (StgMutClosure *)ind;
3339         }
3340         break;
3341       }
3342
3343     case THUNK_STATIC:
3344     case FUN_STATIC:
3345       scavenge_srt(info);
3346       break;
3347
3348     case CONSTR_STATIC:
3349       {
3350         StgPtr q, next;
3351
3352         next = (P_)p->payload + info->layout.payload.ptrs;
3353         // evacuate the pointers
3354         for (q = (P_)p->payload; q < next; q++) {
3355           (StgClosure *)*q = evacuate((StgClosure *)*q);
3356         }
3357         break;
3358       }
3359
3360     default:
3361       barf("scavenge_static: strange closure %d", (int)(info->type));
3362     }
3363
3364     ASSERT(failed_to_evac == rtsFalse);
3365
3366     /* get the next static object from the list.  Remember, there might
3367      * be more stuff on this list now that we've done some evacuating!
3368      * (static_objects is a global)
3369      */
3370     p = static_objects;
3371   }
3372 }
3373
3374 /* -----------------------------------------------------------------------------
3375    scavenge_stack walks over a section of stack and evacuates all the
3376    objects pointed to by it.  We can use the same code for walking
3377    PAPs, since these are just sections of copied stack.
3378    -------------------------------------------------------------------------- */
3379
3380 static void
3381 scavenge_stack(StgPtr p, StgPtr stack_end)
3382 {
3383   StgPtr q;
3384   const StgInfoTable* info;
3385   StgWord bitmap;
3386
3387   //IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
3388
3389   /*
3390    * Each time around this loop, we are looking at a chunk of stack
3391    * that starts with either a pending argument section or an
3392    * activation record.
3393    */
3394
3395   while (p < stack_end) {
3396     q = *(P_ *)p;
3397
3398     // If we've got a tag, skip over that many words on the stack
3399     if (IS_ARG_TAG((W_)q)) {
3400       p += ARG_SIZE(q);
3401       p++; continue;
3402     }
3403
3404     /* Is q a pointer to a closure?
3405      */
3406     if (! LOOKS_LIKE_GHC_INFO(q) ) {
3407 #ifdef DEBUG
3408       if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  // Is it a static closure?
3409         ASSERT(closure_STATIC((StgClosure *)q));
3410       }
3411       // otherwise, must be a pointer into the allocation space.
3412 #endif
3413
3414       (StgClosure *)*p = evacuate((StgClosure *)q);
3415       p++;
3416       continue;
3417     }
3418
3419     /*
3420      * Otherwise, q must be the info pointer of an activation
3421      * record.  All activation records have 'bitmap' style layout
3422      * info.
3423      */
3424     info  = get_itbl((StgClosure *)p);
3425
3426     switch (info->type) {
3427
3428       // Dynamic bitmap: the mask is stored on the stack
3429     case RET_DYN:
3430       bitmap = ((StgRetDyn *)p)->liveness;
3431       p      = (P_)&((StgRetDyn *)p)->payload[0];
3432       goto small_bitmap;
3433
3434       // probably a slow-entry point return address:
3435     case FUN:
3436     case FUN_STATIC:
3437       {
3438 #if 0
3439         StgPtr old_p = p;
3440         p++; p++;
3441         IF_DEBUG(sanity,
3442                  belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
3443                        old_p, p, old_p+1));
3444 #else
3445       p++; // what if FHS!=1 !? -- HWL
3446 #endif
3447       goto follow_srt;
3448       }
3449
3450       /* Specialised code for update frames, since they're so common.
3451        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
3452        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
3453        */
3454     case UPDATE_FRAME:
3455       {
3456         StgUpdateFrame *frame = (StgUpdateFrame *)p;
3457
3458         p += sizeofW(StgUpdateFrame);
3459
3460 #ifndef not_yet
3461         frame->updatee = evacuate(frame->updatee);
3462         continue;
3463 #else // specialised code for update frames, not sure if it's worth it.
3464         StgClosure *to;
3465         nat type = get_itbl(frame->updatee)->type;
3466
3467         if (type == EVACUATED) {
3468           frame->updatee = evacuate(frame->updatee);
3469           continue;
3470         } else {
3471           bdescr *bd = Bdescr((P_)frame->updatee);
3472           step *stp;
3473           if (bd->gen_no > N) {
3474             if (bd->gen_no < evac_gen) {
3475               failed_to_evac = rtsTrue;
3476             }
3477             continue;
3478           }
3479
3480           // Don't promote blackholes
3481           stp = bd->step;
3482           if (!(stp->gen_no == 0 &&
3483                 stp->no != 0 &&
3484                 stp->no == stp->gen->n_steps-1)) {
3485             stp = stp->to;
3486           }
3487
3488           switch (type) {
3489           case BLACKHOLE:
3490           case CAF_BLACKHOLE:
3491             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
3492                           sizeofW(StgHeader), stp);
3493             frame->updatee = to;
3494             continue;
3495           case BLACKHOLE_BQ:
3496             to = copy(frame->updatee, BLACKHOLE_sizeW(), stp);
3497             frame->updatee = to;
3498             recordMutable((StgMutClosure *)to);
3499             continue;
3500           default:
3501             /* will never be SE_{,CAF_}BLACKHOLE, since we
3502                don't push an update frame for single-entry thunks.  KSW 1999-01. */
3503             barf("scavenge_stack: UPDATE_FRAME updatee");
3504           }
3505         }
3506 #endif
3507       }
3508
3509       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3510     case STOP_FRAME:
3511     case CATCH_FRAME:
3512     case SEQ_FRAME:
3513     case RET_BCO:
3514     case RET_SMALL:
3515     case RET_VEC_SMALL:
3516       bitmap = info->layout.bitmap;
3517       p++;
3518       // this assumes that the payload starts immediately after the info-ptr
3519     small_bitmap:
3520       while (bitmap != 0) {
3521         if ((bitmap & 1) == 0) {
3522           (StgClosure *)*p = evacuate((StgClosure *)*p);
3523         }
3524         p++;
3525         bitmap = bitmap >> 1;
3526       }
3527
3528     follow_srt:
3529       scavenge_srt(info);
3530       continue;
3531
3532       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3533     case RET_BIG:
3534     case RET_VEC_BIG:
3535       {
3536         StgPtr q;
3537         StgLargeBitmap *large_bitmap;
3538         nat i;
3539
3540         large_bitmap = info->layout.large_bitmap;
3541         p++;
3542
3543         for (i=0; i<large_bitmap->size; i++) {
3544           bitmap = large_bitmap->bitmap[i];
3545           q = p + BITS_IN(W_);
3546           while (bitmap != 0) {
3547             if ((bitmap & 1) == 0) {
3548               (StgClosure *)*p = evacuate((StgClosure *)*p);
3549             }
3550             p++;
3551             bitmap = bitmap >> 1;
3552           }
3553           if (i+1 < large_bitmap->size) {
3554             while (p < q) {
3555               (StgClosure *)*p = evacuate((StgClosure *)*p);
3556               p++;
3557             }
3558           }
3559         }
3560
3561         // and don't forget to follow the SRT
3562         goto follow_srt;
3563       }
3564
3565     default:
3566       barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->type));
3567     }
3568   }
3569 }
3570
3571 /*-----------------------------------------------------------------------------
3572   scavenge the large object list.
3573
3574   evac_gen set by caller; similar games played with evac_gen as with
3575   scavenge() - see comment at the top of scavenge().  Most large
3576   objects are (repeatedly) mutable, so most of the time evac_gen will
3577   be zero.
3578   --------------------------------------------------------------------------- */
3579
3580 static void
3581 scavenge_large(step *stp)
3582 {
3583   bdescr *bd;
3584   StgPtr p;
3585
3586   bd = stp->new_large_objects;
3587
3588   for (; bd != NULL; bd = stp->new_large_objects) {
3589
3590     /* take this object *off* the large objects list and put it on
3591      * the scavenged large objects list.  This is so that we can
3592      * treat new_large_objects as a stack and push new objects on
3593      * the front when evacuating.
3594      */
3595     stp->new_large_objects = bd->link;
3596     dbl_link_onto(bd, &stp->scavenged_large_objects);
3597
3598     // update the block count in this step.
3599     stp->n_scavenged_large_blocks += bd->blocks;
3600
3601     p = bd->start;
3602     if (scavenge_one(p)) {
3603         mkMutCons((StgClosure *)p, stp->gen);
3604     }
3605   }
3606 }
3607
3608 /* -----------------------------------------------------------------------------
3609    Initialising the static object & mutable lists
3610    -------------------------------------------------------------------------- */
3611
3612 static void
3613 zero_static_object_list(StgClosure* first_static)
3614 {
3615   StgClosure* p;
3616   StgClosure* link;
3617   const StgInfoTable *info;
3618
3619   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3620     info = get_itbl(p);
3621     link = STATIC_LINK(info, p);
3622     STATIC_LINK(info,p) = NULL;
3623   }
3624 }
3625
3626 /* This function is only needed because we share the mutable link
3627  * field with the static link field in an IND_STATIC, so we have to
3628  * zero the mut_link field before doing a major GC, which needs the
3629  * static link field.
3630  *
3631  * It doesn't do any harm to zero all the mutable link fields on the
3632  * mutable list.
3633  */
3634
3635 static void
3636 zero_mutable_list( StgMutClosure *first )
3637 {
3638   StgMutClosure *next, *c;
3639
3640   for (c = first; c != END_MUT_LIST; c = next) {
3641     next = c->mut_link;
3642     c->mut_link = NULL;
3643   }
3644 }
3645
3646 /* -----------------------------------------------------------------------------
3647    Reverting CAFs
3648    -------------------------------------------------------------------------- */
3649
3650 void
3651 revertCAFs( void )
3652 {
3653     StgIndStatic *c;
3654
3655     for (c = (StgIndStatic *)caf_list; c != NULL;
3656          c = (StgIndStatic *)c->static_link)
3657     {
3658         c->header.info = c->saved_info;
3659         c->saved_info = NULL;
3660         // could, but not necessary: c->static_link = NULL;
3661     }
3662     caf_list = NULL;
3663 }
3664
3665 void
3666 markCAFs( evac_fn evac )
3667 {
3668     StgIndStatic *c;
3669
3670     for (c = (StgIndStatic *)caf_list; c != NULL;
3671          c = (StgIndStatic *)c->static_link)
3672     {
3673         evac(&c->indirectee);
3674     }
3675 }
3676
3677 /* -----------------------------------------------------------------------------
3678    Sanity code for CAF garbage collection.
3679
3680    With DEBUG turned on, we manage a CAF list in addition to the SRT
3681    mechanism.  After GC, we run down the CAF list and blackhole any
3682    CAFs which have been garbage collected.  This means we get an error
3683    whenever the program tries to enter a garbage collected CAF.
3684
3685    Any garbage collected CAFs are taken off the CAF list at the same
3686    time.
3687    -------------------------------------------------------------------------- */
3688
3689 #if 0 && defined(DEBUG)
3690
3691 static void
3692 gcCAFs(void)
3693 {
3694   StgClosure*  p;
3695   StgClosure** pp;
3696   const StgInfoTable *info;
3697   nat i;
3698
3699   i = 0;
3700   p = caf_list;
3701   pp = &caf_list;
3702
3703   while (p != NULL) {
3704
3705     info = get_itbl(p);
3706
3707     ASSERT(info->type == IND_STATIC);
3708
3709     if (STATIC_LINK(info,p) == NULL) {
3710       IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3711       // black hole it
3712       SET_INFO(p,&stg_BLACKHOLE_info);
3713       p = STATIC_LINK2(info,p);
3714       *pp = p;
3715     }
3716     else {
3717       pp = &STATIC_LINK2(info,p);
3718       p = *pp;
3719       i++;
3720     }
3721
3722   }
3723
3724   //  belch("%d CAFs live", i);
3725 }
3726 #endif
3727
3728
3729 /* -----------------------------------------------------------------------------
3730    Lazy black holing.
3731
3732    Whenever a thread returns to the scheduler after possibly doing
3733    some work, we have to run down the stack and black-hole all the
3734    closures referred to by update frames.
3735    -------------------------------------------------------------------------- */
3736
3737 static void
3738 threadLazyBlackHole(StgTSO *tso)
3739 {
3740   StgUpdateFrame *update_frame;
3741   StgBlockingQueue *bh;
3742   StgPtr stack_end;
3743
3744   stack_end = &tso->stack[tso->stack_size];
3745   update_frame = tso->su;
3746
3747   while (1) {
3748     switch (get_itbl(update_frame)->type) {
3749
3750     case CATCH_FRAME:
3751       update_frame = ((StgCatchFrame *)update_frame)->link;
3752       break;
3753
3754     case UPDATE_FRAME:
3755       bh = (StgBlockingQueue *)update_frame->updatee;
3756
3757       /* if the thunk is already blackholed, it means we've also
3758        * already blackholed the rest of the thunks on this stack,
3759        * so we can stop early.
3760        *
3761        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3762        * don't interfere with this optimisation.
3763        */
3764       if (bh->header.info == &stg_BLACKHOLE_info) {
3765         return;
3766       }
3767
3768       if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
3769           bh->header.info != &stg_CAF_BLACKHOLE_info) {
3770 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3771         belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3772 #endif
3773 #ifdef PROFILING
3774         // @LDV profiling
3775         // We pretend that bh is now dead.
3776         LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
3777 #endif
3778         SET_INFO(bh,&stg_BLACKHOLE_info);
3779 #ifdef PROFILING
3780         // @LDV profiling
3781         // We pretend that bh has just been created.
3782         LDV_recordCreate(bh);
3783 #endif
3784       }
3785
3786       update_frame = update_frame->link;
3787       break;
3788
3789     case SEQ_FRAME:
3790       update_frame = ((StgSeqFrame *)update_frame)->link;
3791       break;
3792
3793     case STOP_FRAME:
3794       return;
3795     default:
3796       barf("threadPaused");
3797     }
3798   }
3799 }
3800
3801
3802 /* -----------------------------------------------------------------------------
3803  * Stack squeezing
3804  *
3805  * Code largely pinched from old RTS, then hacked to bits.  We also do
3806  * lazy black holing here.
3807  *
3808  * -------------------------------------------------------------------------- */
3809
3810 static void
3811 threadSqueezeStack(StgTSO *tso)
3812 {
3813   lnat displacement = 0;
3814   StgUpdateFrame *frame;
3815   StgUpdateFrame *next_frame;                   // Temporally next
3816   StgUpdateFrame *prev_frame;                   // Temporally previous
3817   StgPtr bottom;
3818   rtsBool prev_was_update_frame;
3819 #if DEBUG
3820   StgUpdateFrame *top_frame;
3821   nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
3822       bhs=0, squeezes=0;
3823   void printObj( StgClosure *obj ); // from Printer.c
3824
3825   top_frame  = tso->su;
3826 #endif
3827
3828   bottom = &(tso->stack[tso->stack_size]);
3829   frame  = tso->su;
3830
3831   /* There must be at least one frame, namely the STOP_FRAME.
3832    */
3833   ASSERT((P_)frame < bottom);
3834
3835   /* Walk down the stack, reversing the links between frames so that
3836    * we can walk back up as we squeeze from the bottom.  Note that
3837    * next_frame and prev_frame refer to next and previous as they were
3838    * added to the stack, rather than the way we see them in this
3839    * walk. (It makes the next loop less confusing.)
3840    *
3841    * Stop if we find an update frame pointing to a black hole
3842    * (see comment in threadLazyBlackHole()).
3843    */
3844
3845   next_frame = NULL;
3846   // bottom - sizeof(StgStopFrame) is the STOP_FRAME
3847   while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
3848     prev_frame = frame->link;
3849     frame->link = next_frame;
3850     next_frame = frame;
3851     frame = prev_frame;
3852 #if DEBUG
3853     IF_DEBUG(sanity,
3854              if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
3855                printObj((StgClosure *)prev_frame);
3856                barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
3857                     frame, prev_frame);
3858              })
3859     switch (get_itbl(frame)->type) {
3860     case UPDATE_FRAME:
3861         upd_frames++;
3862         if (frame->updatee->header.info == &stg_BLACKHOLE_info)
3863             bhs++;
3864         break;
3865     case STOP_FRAME:
3866         stop_frames++;
3867         break;
3868     case CATCH_FRAME:
3869         catch_frames++;
3870         break;
3871     case SEQ_FRAME:
3872         seq_frames++;
3873         break;
3874     default:
3875       barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
3876            frame, prev_frame);
3877       printObj((StgClosure *)prev_frame);
3878     }
3879 #endif
3880     if (get_itbl(frame)->type == UPDATE_FRAME
3881         && frame->updatee->header.info == &stg_BLACKHOLE_info) {
3882         break;
3883     }
3884   }
3885
3886   /* Now, we're at the bottom.  Frame points to the lowest update
3887    * frame on the stack, and its link actually points to the frame
3888    * above. We have to walk back up the stack, squeezing out empty
3889    * update frames and turning the pointers back around on the way
3890    * back up.
3891    *
3892    * The bottom-most frame (the STOP_FRAME) has not been altered, and
3893    * we never want to eliminate it anyway.  Just walk one step up
3894    * before starting to squeeze. When you get to the topmost frame,
3895    * remember that there are still some words above it that might have
3896    * to be moved.
3897    */
3898
3899   prev_frame = frame;
3900   frame = next_frame;
3901
3902   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
3903
3904   /*
3905    * Loop through all of the frames (everything except the very
3906    * bottom).  Things are complicated by the fact that we have
3907    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
3908    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
3909    */
3910   while (frame != NULL) {
3911     StgPtr sp;
3912     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
3913     rtsBool is_update_frame;
3914
3915     next_frame = frame->link;
3916     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
3917
3918     /* Check to see if
3919      *   1. both the previous and current frame are update frames
3920      *   2. the current frame is empty
3921      */
3922     if (prev_was_update_frame && is_update_frame &&
3923         (P_)prev_frame == frame_bottom + displacement) {
3924
3925       // Now squeeze out the current frame
3926       StgClosure *updatee_keep   = prev_frame->updatee;
3927       StgClosure *updatee_bypass = frame->updatee;
3928
3929 #if DEBUG
3930       IF_DEBUG(gc, belch("@@ squeezing frame at %p", frame));
3931       squeezes++;
3932 #endif
3933
3934       /* Deal with blocking queues.  If both updatees have blocked
3935        * threads, then we should merge the queues into the update
3936        * frame that we're keeping.
3937        *
3938        * Alternatively, we could just wake them up: they'll just go
3939        * straight to sleep on the proper blackhole!  This is less code
3940        * and probably less bug prone, although it's probably much
3941        * slower --SDM
3942        */
3943 #if 0 // do it properly...
3944 #  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3945 #    error Unimplemented lazy BH warning.  (KSW 1999-01)
3946 #  endif
3947       if (GET_INFO(updatee_bypass) == stg_BLACKHOLE_BQ_info
3948           || GET_INFO(updatee_bypass) == stg_CAF_BLACKHOLE_info
3949           ) {
3950         // Sigh.  It has one.  Don't lose those threads!
3951           if (GET_INFO(updatee_keep) == stg_BLACKHOLE_BQ_info) {
3952           // Urgh.  Two queues.  Merge them.
3953           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
3954
3955           while (keep_tso->link != END_TSO_QUEUE) {
3956             keep_tso = keep_tso->link;
3957           }
3958           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
3959
3960         } else {
3961           // For simplicity, just swap the BQ for the BH
3962           P_ temp = updatee_keep;
3963
3964           updatee_keep = updatee_bypass;
3965           updatee_bypass = temp;
3966
3967           // Record the swap in the kept frame (below)
3968           prev_frame->updatee = updatee_keep;
3969         }
3970       }
3971 #endif
3972
3973       TICK_UPD_SQUEEZED();
3974       /* wasn't there something about update squeezing and ticky to be
3975        * sorted out?  oh yes: we aren't counting each enter properly
3976        * in this case.  See the log somewhere.  KSW 1999-04-21
3977        *
3978        * Check two things: that the two update frames don't point to
3979        * the same object, and that the updatee_bypass isn't already an
3980        * indirection.  Both of these cases only happen when we're in a
3981        * block hole-style loop (and there are multiple update frames
3982        * on the stack pointing to the same closure), but they can both
3983        * screw us up if we don't check.
3984        */
3985       if (updatee_bypass != updatee_keep && !closure_IND(updatee_bypass)) {
3986           // this wakes the threads up
3987           UPD_IND_NOLOCK(updatee_bypass, updatee_keep);
3988       }
3989
3990       sp = (P_)frame - 1;       // sp = stuff to slide
3991       displacement += sizeofW(StgUpdateFrame);
3992
3993     } else {
3994       // No squeeze for this frame
3995       sp = frame_bottom - 1;    // Keep the current frame
3996
3997       /* Do lazy black-holing.
3998        */
3999       if (is_update_frame) {
4000         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
4001         if (bh->header.info != &stg_BLACKHOLE_info &&
4002             bh->header.info != &stg_BLACKHOLE_BQ_info &&
4003             bh->header.info != &stg_CAF_BLACKHOLE_info) {
4004 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4005           belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4006 #endif
4007 #ifdef DEBUG
4008           /* zero out the slop so that the sanity checker can tell
4009            * where the next closure is.
4010            */
4011           {
4012               StgInfoTable *info = get_itbl(bh);
4013               nat np = info->layout.payload.ptrs, nw = info->layout.payload.nptrs, i;
4014               /* don't zero out slop for a THUNK_SELECTOR, because its layout
4015                * info is used for a different purpose, and it's exactly the
4016                * same size as a BLACKHOLE in any case.
4017                */
4018               if (info->type != THUNK_SELECTOR) {
4019                 for (i = np; i < np + nw; i++) {
4020                   ((StgClosure *)bh)->payload[i] = 0;
4021                 }
4022               }
4023           }
4024 #endif
4025 #ifdef PROFILING
4026           // @LDV profiling
4027           // We pretend that bh is now dead.
4028           LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4029 #endif
4030           //
4031           // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
4032           //
4033           SET_INFO(bh,&stg_BLACKHOLE_info);
4034 #ifdef PROFILING
4035           // @LDV profiling
4036           // We pretend that bh has just been created.
4037           LDV_recordCreate(bh);
4038 #endif
4039         }
4040       }
4041
4042       // Fix the link in the current frame (should point to the frame below)
4043       frame->link = prev_frame;
4044       prev_was_update_frame = is_update_frame;
4045     }
4046
4047     // Now slide all words from sp up to the next frame
4048
4049     if (displacement > 0) {
4050       P_ next_frame_bottom;
4051
4052       if (next_frame != NULL)
4053         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
4054       else
4055         next_frame_bottom = tso->sp - 1;
4056
4057 #if 0
4058       IF_DEBUG(gc,
4059                belch("sliding [%p, %p] by %ld", sp, next_frame_bottom,
4060                      displacement))
4061 #endif
4062
4063       while (sp >= next_frame_bottom) {
4064         sp[displacement] = *sp;
4065         sp -= 1;
4066       }
4067     }
4068     (P_)prev_frame = (P_)frame + displacement;
4069     frame = next_frame;
4070   }
4071
4072   tso->sp += displacement;
4073   tso->su = prev_frame;
4074 #if 0
4075   IF_DEBUG(gc,
4076            belch("@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames",
4077                    squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
4078 #endif
4079 }
4080
4081
4082 /* -----------------------------------------------------------------------------
4083  * Pausing a thread
4084  *
4085  * We have to prepare for GC - this means doing lazy black holing
4086  * here.  We also take the opportunity to do stack squeezing if it's
4087  * turned on.
4088  * -------------------------------------------------------------------------- */
4089 void
4090 threadPaused(StgTSO *tso)
4091 {
4092   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4093     threadSqueezeStack(tso);    // does black holing too
4094   else
4095     threadLazyBlackHole(tso);
4096 }
4097
4098 /* -----------------------------------------------------------------------------
4099  * Debugging
4100  * -------------------------------------------------------------------------- */
4101
4102 #if DEBUG
4103 void
4104 printMutOnceList(generation *gen)
4105 {
4106   StgMutClosure *p, *next;
4107
4108   p = gen->mut_once_list;
4109   next = p->mut_link;
4110
4111   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4112   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4113     fprintf(stderr, "%p (%s), ",
4114             p, info_type((StgClosure *)p));
4115   }
4116   fputc('\n', stderr);
4117 }
4118
4119 void
4120 printMutableList(generation *gen)
4121 {
4122   StgMutClosure *p, *next;
4123
4124   p = gen->mut_list;
4125   next = p->mut_link;
4126
4127   fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4128   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4129     fprintf(stderr, "%p (%s), ",
4130             p, info_type((StgClosure *)p));
4131   }
4132   fputc('\n', stderr);
4133 }
4134
4135 static inline rtsBool
4136 maybeLarge(StgClosure *closure)
4137 {
4138   StgInfoTable *info = get_itbl(closure);
4139
4140   /* closure types that may be found on the new_large_objects list;
4141      see scavenge_large */
4142   return (info->type == MUT_ARR_PTRS ||
4143           info->type == MUT_ARR_PTRS_FROZEN ||
4144           info->type == TSO ||
4145           info->type == ARR_WORDS);
4146 }
4147
4148
4149 #endif // DEBUG