ghc/rts/GC.c

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