ghc/rts/GC.c

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