ghc/rts/GC.c

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