ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.146 2002/12/11 15:36:42 simonmar Exp $
   3  *
   4  * (c) The GHC Team 1998-2002
   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               ((StgInd *)selectee)->indirectee = val;
2063               SET_INFO(selectee,&stg_IND_info);
2064               selectee = val;
2065               goto selector_loop;
2066           }
2067       }
2068
2069       case AP:
2070       case THUNK:
2071       case THUNK_1_0:
2072       case THUNK_0_1:
2073       case THUNK_2_0:
2074       case THUNK_1_1:
2075       case THUNK_0_2:
2076       case THUNK_STATIC:
2077       case CAF_BLACKHOLE:
2078       case SE_CAF_BLACKHOLE:
2079       case SE_BLACKHOLE:
2080       case BLACKHOLE:
2081       case BLACKHOLE_BQ:
2082 #if defined(PAR)
2083       case RBH:
2084       case BLOCKED_FETCH:
2085 # ifdef DIST
2086       case REMOTE_REF:
2087 # endif
2088       case FETCH_ME:
2089       case FETCH_ME_BQ:
2090 #endif
2091           // not evaluated yet
2092           break;
2093
2094       default:
2095         barf("eval_thunk_selector: strange selectee %d",
2096              (int)(info->type));
2097     }
2098
2099     // We didn't manage to evaluate this thunk; restore the old info pointer
2100     SET_INFO(p, info_ptr);
2101     return NULL;
2102 }
2103
2104 /* -----------------------------------------------------------------------------
2105    move_TSO is called to update the TSO structure after it has been
2106    moved from one place to another.
2107    -------------------------------------------------------------------------- */
2108
2109 void
2110 move_TSO (StgTSO *src, StgTSO *dest)
2111 {
2112     ptrdiff_t diff;
2113
2114     // relocate the stack pointers...
2115     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2116     dest->sp = (StgPtr)dest->sp + diff;
2117 }
2118
2119 /* evacuate the SRT.  If srt_len is zero, then there isn't an
2120  * srt field in the info table.  That's ok, because we'll
2121  * never dereference it.
2122  */
2123 static inline void
2124 scavenge_srt (StgClosure **srt, nat srt_len)
2125 {
2126   StgClosure **srt_end;
2127
2128   srt_end = srt + srt_len;
2129
2130   for (; srt < srt_end; srt++) {
2131     /* Special-case to handle references to closures hiding out in DLLs, since
2132        double indirections required to get at those. The code generator knows
2133        which is which when generating the SRT, so it stores the (indirect)
2134        reference to the DLL closure in the table by first adding one to it.
2135        We check for this here, and undo the addition before evacuating it.
2136
2137        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2138        closure that's fixed at link-time, and no extra magic is required.
2139     */
2140 #ifdef ENABLE_WIN32_DLL_SUPPORT
2141     if ( (unsigned long)(*srt) & 0x1 ) {
2142        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2143     } else {
2144        evacuate(*srt);
2145     }
2146 #else
2147        evacuate(*srt);
2148 #endif
2149   }
2150 }
2151
2152
2153 static inline void
2154 scavenge_thunk_srt(const StgInfoTable *info)
2155 {
2156     StgThunkInfoTable *thunk_info;
2157
2158     thunk_info = itbl_to_thunk_itbl(info);
2159     scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_len);
2160 }
2161
2162 static inline void
2163 scavenge_fun_srt(const StgInfoTable *info)
2164 {
2165     StgFunInfoTable *fun_info;
2166
2167     fun_info = itbl_to_fun_itbl(info);
2168     scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_len);
2169 }
2170
2171 static inline void
2172 scavenge_ret_srt(const StgInfoTable *info)
2173 {
2174     StgRetInfoTable *ret_info;
2175
2176     ret_info = itbl_to_ret_itbl(info);
2177     scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_len);
2178 }
2179
2180 /* -----------------------------------------------------------------------------
2181    Scavenge a TSO.
2182    -------------------------------------------------------------------------- */
2183
2184 static void
2185 scavengeTSO (StgTSO *tso)
2186 {
2187     // chase the link field for any TSOs on the same queue
2188     (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2189     if (   tso->why_blocked == BlockedOnMVar
2190         || tso->why_blocked == BlockedOnBlackHole
2191         || tso->why_blocked == BlockedOnException
2192 #if defined(PAR)
2193         || tso->why_blocked == BlockedOnGA
2194         || tso->why_blocked == BlockedOnGA_NoSend
2195 #endif
2196         ) {
2197         tso->block_info.closure = evacuate(tso->block_info.closure);
2198     }
2199     if ( tso->blocked_exceptions != NULL ) {
2200         tso->blocked_exceptions =
2201             (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2202     }
2203
2204     // scavenge this thread's stack
2205     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2206 }
2207
2208 /* -----------------------------------------------------------------------------
2209    Blocks of function args occur on the stack (at the top) and
2210    in PAPs.
2211    -------------------------------------------------------------------------- */
2212
2213 static inline StgPtr
2214 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2215 {
2216     StgPtr p;
2217     StgWord bitmap;
2218     nat size;
2219
2220     p = (StgPtr)args;
2221     switch (fun_info->fun_type) {
2222     case ARG_GEN:
2223         bitmap = BITMAP_BITS(fun_info->bitmap);
2224         size = BITMAP_SIZE(fun_info->bitmap);
2225         goto small_bitmap;
2226     case ARG_GEN_BIG:
2227         size = ((StgLargeBitmap *)fun_info->bitmap)->size;
2228         scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
2229         p += size;
2230         break;
2231     default:
2232         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
2233         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
2234     small_bitmap:
2235         while (size > 0) {
2236             if ((bitmap & 1) == 0) {
2237                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2238             }
2239             p++;
2240             bitmap = bitmap >> 1;
2241             size--;
2242         }
2243         break;
2244     }
2245     return p;
2246 }
2247
2248 static inline StgPtr
2249 scavenge_PAP (StgPAP *pap)
2250 {
2251     StgPtr p;
2252     StgWord bitmap, size;
2253     StgFunInfoTable *fun_info;
2254
2255     pap->fun = evacuate(pap->fun);
2256     fun_info = get_fun_itbl(pap->fun);
2257     ASSERT(fun_info->i.type != PAP);
2258
2259     p = (StgPtr)pap->payload;
2260     size = pap->n_args;
2261
2262     switch (fun_info->fun_type) {
2263     case ARG_GEN:
2264         bitmap = BITMAP_BITS(fun_info->bitmap);
2265         goto small_bitmap;
2266     case ARG_GEN_BIG:
2267         scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
2268         p += size;
2269         break;
2270     case ARG_BCO:
2271         scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
2272         p += size;
2273         break;
2274     default:
2275         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
2276     small_bitmap:
2277         size = pap->n_args;
2278         while (size > 0) {
2279             if ((bitmap & 1) == 0) {
2280                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2281             }
2282             p++;
2283             bitmap = bitmap >> 1;
2284             size--;
2285         }
2286         break;
2287     }
2288     return p;
2289 }
2290
2291 /* -----------------------------------------------------------------------------
2292    Scavenge a given step until there are no more objects in this step
2293    to scavenge.
2294
2295    evac_gen is set by the caller to be either zero (for a step in a
2296    generation < N) or G where G is the generation of the step being
2297    scavenged.
2298
2299    We sometimes temporarily change evac_gen back to zero if we're
2300    scavenging a mutable object where early promotion isn't such a good
2301    idea.
2302    -------------------------------------------------------------------------- */
2303
2304 static void
2305 scavenge(step *stp)
2306 {
2307   StgPtr p, q;
2308   StgInfoTable *info;
2309   bdescr *bd;
2310   nat saved_evac_gen = evac_gen;
2311
2312   p = stp->scan;
2313   bd = stp->scan_bd;
2314
2315   failed_to_evac = rtsFalse;
2316
2317   /* scavenge phase - standard breadth-first scavenging of the
2318    * evacuated objects
2319    */
2320
2321   while (bd != stp->hp_bd || p < stp->hp) {
2322
2323     // If we're at the end of this block, move on to the next block
2324     if (bd != stp->hp_bd && p == bd->free) {
2325       bd = bd->link;
2326       p = bd->start;
2327       continue;
2328     }
2329
2330     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2331     info = get_itbl((StgClosure *)p);
2332
2333     ASSERT(thunk_selector_depth == 0);
2334
2335     q = p;
2336     switch (info->type) {
2337
2338     case MVAR:
2339         /* treat MVars specially, because we don't want to evacuate the
2340          * mut_link field in the middle of the closure.
2341          */
2342     {
2343         StgMVar *mvar = ((StgMVar *)p);
2344         evac_gen = 0;
2345         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2346         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2347         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2348         evac_gen = saved_evac_gen;
2349         recordMutable((StgMutClosure *)mvar);
2350         failed_to_evac = rtsFalse; // mutable.
2351         p += sizeofW(StgMVar);
2352         break;
2353     }
2354
2355     case FUN_2_0:
2356         scavenge_fun_srt(info);
2357         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2358         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2359         p += sizeofW(StgHeader) + 2;
2360         break;
2361
2362     case THUNK_2_0:
2363         scavenge_thunk_srt(info);
2364     case CONSTR_2_0:
2365         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2366         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2367         p += sizeofW(StgHeader) + 2;
2368         break;
2369
2370     case THUNK_1_0:
2371         scavenge_thunk_srt(info);
2372         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2373         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2374         break;
2375
2376     case FUN_1_0:
2377         scavenge_fun_srt(info);
2378     case CONSTR_1_0:
2379         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2380         p += sizeofW(StgHeader) + 1;
2381         break;
2382
2383     case THUNK_0_1:
2384         scavenge_thunk_srt(info);
2385         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2386         break;
2387
2388     case FUN_0_1:
2389         scavenge_fun_srt(info);
2390     case CONSTR_0_1:
2391         p += sizeofW(StgHeader) + 1;
2392         break;
2393
2394     case THUNK_0_2:
2395         scavenge_thunk_srt(info);
2396         p += sizeofW(StgHeader) + 2;
2397         break;
2398
2399     case FUN_0_2:
2400         scavenge_fun_srt(info);
2401     case CONSTR_0_2:
2402         p += sizeofW(StgHeader) + 2;
2403         break;
2404
2405     case THUNK_1_1:
2406         scavenge_thunk_srt(info);
2407         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2408         p += sizeofW(StgHeader) + 2;
2409         break;
2410
2411     case FUN_1_1:
2412         scavenge_fun_srt(info);
2413     case CONSTR_1_1:
2414         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2415         p += sizeofW(StgHeader) + 2;
2416         break;
2417
2418     case FUN:
2419         scavenge_fun_srt(info);
2420         goto gen_obj;
2421
2422     case THUNK:
2423         scavenge_thunk_srt(info);
2424         // fall through
2425
2426     gen_obj:
2427     case CONSTR:
2428     case WEAK:
2429     case FOREIGN:
2430     case STABLE_NAME:
2431     case BCO:
2432     {
2433         StgPtr end;
2434
2435         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2436         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2437             (StgClosure *)*p = evacuate((StgClosure *)*p);
2438         }
2439         p += info->layout.payload.nptrs;
2440         break;
2441     }
2442
2443     case IND_PERM:
2444       if (stp->gen->no != 0) {
2445 #ifdef PROFILING
2446         // @LDV profiling
2447         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2448         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2449         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2450 #endif
2451         //
2452         // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
2453         //
2454         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2455 #ifdef PROFILING
2456         // @LDV profiling
2457         // We pretend that p has just been created.
2458         LDV_recordCreate((StgClosure *)p);
2459 #endif
2460       }
2461         // fall through
2462     case IND_OLDGEN_PERM:
2463         ((StgIndOldGen *)p)->indirectee =
2464             evacuate(((StgIndOldGen *)p)->indirectee);
2465         if (failed_to_evac) {
2466             failed_to_evac = rtsFalse;
2467             recordOldToNewPtrs((StgMutClosure *)p);
2468         }
2469         p += sizeofW(StgIndOldGen);
2470         break;
2471
2472     case MUT_VAR:
2473         evac_gen = 0;
2474         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2475         evac_gen = saved_evac_gen;
2476         recordMutable((StgMutClosure *)p);
2477         failed_to_evac = rtsFalse; // mutable anyhow
2478         p += sizeofW(StgMutVar);
2479         break;
2480
2481     case MUT_CONS:
2482         // ignore these
2483         failed_to_evac = rtsFalse; // mutable anyhow
2484         p += sizeofW(StgMutVar);
2485         break;
2486
2487     case CAF_BLACKHOLE:
2488     case SE_CAF_BLACKHOLE:
2489     case SE_BLACKHOLE:
2490     case BLACKHOLE:
2491         p += BLACKHOLE_sizeW();
2492         break;
2493
2494     case BLACKHOLE_BQ:
2495     {
2496         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2497         (StgClosure *)bh->blocking_queue =
2498             evacuate((StgClosure *)bh->blocking_queue);
2499         recordMutable((StgMutClosure *)bh);
2500         failed_to_evac = rtsFalse;
2501         p += BLACKHOLE_sizeW();
2502         break;
2503     }
2504
2505     case THUNK_SELECTOR:
2506     {
2507         StgSelector *s = (StgSelector *)p;
2508         s->selectee = evacuate(s->selectee);
2509         p += THUNK_SELECTOR_sizeW();
2510         break;
2511     }
2512
2513     // A chunk of stack saved in a heap object
2514     case AP_STACK:
2515     {
2516         StgAP_STACK *ap = (StgAP_STACK *)p;
2517
2518         ap->fun = evacuate(ap->fun);
2519         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2520         p = (StgPtr)ap->payload + ap->size;
2521         break;
2522     }
2523
2524     case PAP:
2525     case AP:
2526         p = scavenge_PAP((StgPAP *)p);
2527         break;
2528
2529     case ARR_WORDS:
2530         // nothing to follow
2531         p += arr_words_sizeW((StgArrWords *)p);
2532         break;
2533
2534     case MUT_ARR_PTRS:
2535         // follow everything
2536     {
2537         StgPtr next;
2538
2539         evac_gen = 0;           // repeatedly mutable
2540         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2541         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2542             (StgClosure *)*p = evacuate((StgClosure *)*p);
2543         }
2544         evac_gen = saved_evac_gen;
2545         recordMutable((StgMutClosure *)q);
2546         failed_to_evac = rtsFalse; // mutable anyhow.
2547         break;
2548     }
2549
2550     case MUT_ARR_PTRS_FROZEN:
2551         // follow everything
2552     {
2553         StgPtr next;
2554
2555         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2556         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2557             (StgClosure *)*p = evacuate((StgClosure *)*p);
2558         }
2559         // it's tempting to recordMutable() if failed_to_evac is
2560         // false, but that breaks some assumptions (eg. every
2561         // closure on the mutable list is supposed to have the MUT
2562         // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2563         break;
2564     }
2565
2566     case TSO:
2567     {
2568         StgTSO *tso = (StgTSO *)p;
2569         evac_gen = 0;
2570         scavengeTSO(tso);
2571         evac_gen = saved_evac_gen;
2572         recordMutable((StgMutClosure *)tso);
2573         failed_to_evac = rtsFalse; // mutable anyhow.
2574         p += tso_sizeW(tso);
2575         break;
2576     }
2577
2578 #if defined(PAR)
2579     case RBH: // cf. BLACKHOLE_BQ
2580     {
2581 #if 0
2582         nat size, ptrs, nonptrs, vhs;
2583         char str[80];
2584         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2585 #endif
2586         StgRBH *rbh = (StgRBH *)p;
2587         (StgClosure *)rbh->blocking_queue =
2588             evacuate((StgClosure *)rbh->blocking_queue);
2589         recordMutable((StgMutClosure *)to);
2590         failed_to_evac = rtsFalse;  // mutable anyhow.
2591         IF_DEBUG(gc,
2592                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2593                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2594         // ToDo: use size of reverted closure here!
2595         p += BLACKHOLE_sizeW();
2596         break;
2597     }
2598
2599     case BLOCKED_FETCH:
2600     {
2601         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2602         // follow the pointer to the node which is being demanded
2603         (StgClosure *)bf->node =
2604             evacuate((StgClosure *)bf->node);
2605         // follow the link to the rest of the blocking queue
2606         (StgClosure *)bf->link =
2607             evacuate((StgClosure *)bf->link);
2608         if (failed_to_evac) {
2609             failed_to_evac = rtsFalse;
2610             recordMutable((StgMutClosure *)bf);
2611         }
2612         IF_DEBUG(gc,
2613                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2614                        bf, info_type((StgClosure *)bf),
2615                        bf->node, info_type(bf->node)));
2616         p += sizeofW(StgBlockedFetch);
2617         break;
2618     }
2619
2620 #ifdef DIST
2621     case REMOTE_REF:
2622 #endif
2623     case FETCH_ME:
2624         p += sizeofW(StgFetchMe);
2625         break; // nothing to do in this case
2626
2627     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2628     {
2629         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2630         (StgClosure *)fmbq->blocking_queue =
2631             evacuate((StgClosure *)fmbq->blocking_queue);
2632         if (failed_to_evac) {
2633             failed_to_evac = rtsFalse;
2634             recordMutable((StgMutClosure *)fmbq);
2635         }
2636         IF_DEBUG(gc,
2637                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2638                        p, info_type((StgClosure *)p)));
2639         p += sizeofW(StgFetchMeBlockingQueue);
2640         break;
2641     }
2642 #endif
2643
2644     default:
2645         barf("scavenge: unimplemented/strange closure type %d @ %p",
2646              info->type, p);
2647     }
2648
2649     /* If we didn't manage to promote all the objects pointed to by
2650      * the current object, then we have to designate this object as
2651      * mutable (because it contains old-to-new generation pointers).
2652      */
2653     if (failed_to_evac) {
2654         failed_to_evac = rtsFalse;
2655         mkMutCons((StgClosure *)q, &generations[evac_gen]);
2656     }
2657   }
2658
2659   stp->scan_bd = bd;
2660   stp->scan = p;
2661 }
2662
2663 /* -----------------------------------------------------------------------------
2664    Scavenge everything on the mark stack.
2665
2666    This is slightly different from scavenge():
2667       - we don't walk linearly through the objects, so the scavenger
2668         doesn't need to advance the pointer on to the next object.
2669    -------------------------------------------------------------------------- */
2670
2671 static void
2672 scavenge_mark_stack(void)
2673 {
2674     StgPtr p, q;
2675     StgInfoTable *info;
2676     nat saved_evac_gen;
2677
2678     evac_gen = oldest_gen->no;
2679     saved_evac_gen = evac_gen;
2680
2681 linear_scan:
2682     while (!mark_stack_empty()) {
2683         p = pop_mark_stack();
2684
2685         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2686         info = get_itbl((StgClosure *)p);
2687
2688         q = p;
2689         switch (info->type) {
2690
2691         case MVAR:
2692             /* treat MVars specially, because we don't want to evacuate the
2693              * mut_link field in the middle of the closure.
2694              */
2695         {
2696             StgMVar *mvar = ((StgMVar *)p);
2697             evac_gen = 0;
2698             (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2699             (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2700             (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2701             evac_gen = saved_evac_gen;
2702             failed_to_evac = rtsFalse; // mutable.
2703             break;
2704         }
2705
2706         case FUN_2_0:
2707             scavenge_fun_srt(info);
2708             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2709             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2710             break;
2711
2712         case THUNK_2_0:
2713             scavenge_thunk_srt(info);
2714         case CONSTR_2_0:
2715             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2716             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2717             break;
2718
2719         case FUN_1_0:
2720         case FUN_1_1:
2721             scavenge_fun_srt(info);
2722             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2723             break;
2724
2725         case THUNK_1_0:
2726         case THUNK_1_1:
2727             scavenge_thunk_srt(info);
2728         case CONSTR_1_0:
2729         case CONSTR_1_1:
2730             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2731             break;
2732
2733         case FUN_0_1:
2734         case FUN_0_2:
2735             scavenge_fun_srt(info);
2736             break;
2737
2738         case THUNK_0_1:
2739         case THUNK_0_2:
2740             scavenge_thunk_srt(info);
2741             break;
2742
2743         case CONSTR_0_1:
2744         case CONSTR_0_2:
2745             break;
2746
2747         case FUN:
2748             scavenge_fun_srt(info);
2749             goto gen_obj;
2750
2751         case THUNK:
2752             scavenge_thunk_srt(info);
2753             // fall through
2754
2755         gen_obj:
2756         case CONSTR:
2757         case WEAK:
2758         case FOREIGN:
2759         case STABLE_NAME:
2760         case BCO:
2761         {
2762             StgPtr end;
2763
2764             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2765             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2766                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2767             }
2768             break;
2769         }
2770
2771         case IND_PERM:
2772             // don't need to do anything here: the only possible case
2773             // is that we're in a 1-space compacting collector, with
2774             // no "old" generation.
2775             break;
2776
2777         case IND_OLDGEN:
2778         case IND_OLDGEN_PERM:
2779             ((StgIndOldGen *)p)->indirectee =
2780                 evacuate(((StgIndOldGen *)p)->indirectee);
2781             if (failed_to_evac) {
2782                 recordOldToNewPtrs((StgMutClosure *)p);
2783             }
2784             failed_to_evac = rtsFalse;
2785             break;
2786
2787         case MUT_VAR:
2788             evac_gen = 0;
2789             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2790             evac_gen = saved_evac_gen;
2791             failed_to_evac = rtsFalse;
2792             break;
2793
2794         case MUT_CONS:
2795             // ignore these
2796             failed_to_evac = rtsFalse;
2797             break;
2798
2799         case CAF_BLACKHOLE:
2800         case SE_CAF_BLACKHOLE:
2801         case SE_BLACKHOLE:
2802         case BLACKHOLE:
2803         case ARR_WORDS:
2804             break;
2805
2806         case BLACKHOLE_BQ:
2807         {
2808             StgBlockingQueue *bh = (StgBlockingQueue *)p;
2809             (StgClosure *)bh->blocking_queue =
2810                 evacuate((StgClosure *)bh->blocking_queue);
2811             failed_to_evac = rtsFalse;
2812             break;
2813         }
2814
2815         case THUNK_SELECTOR:
2816         {
2817             StgSelector *s = (StgSelector *)p;
2818             s->selectee = evacuate(s->selectee);
2819             break;
2820         }
2821
2822         // A chunk of stack saved in a heap object
2823         case AP_STACK:
2824         {
2825             StgAP_STACK *ap = (StgAP_STACK *)p;
2826
2827             ap->fun = evacuate(ap->fun);
2828             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2829             break;
2830         }
2831
2832         case PAP:
2833         case AP:
2834             scavenge_PAP((StgPAP *)p);
2835             break;
2836
2837         case MUT_ARR_PTRS:
2838             // follow everything
2839         {
2840             StgPtr next;
2841
2842             evac_gen = 0;               // repeatedly mutable
2843             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2844             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2845                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2846             }
2847             evac_gen = saved_evac_gen;
2848             failed_to_evac = rtsFalse; // mutable anyhow.
2849             break;
2850         }
2851
2852         case MUT_ARR_PTRS_FROZEN:
2853             // follow everything
2854         {
2855             StgPtr next;
2856
2857             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2858             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2859                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2860             }
2861             break;
2862         }
2863
2864         case TSO:
2865         {
2866             StgTSO *tso = (StgTSO *)p;
2867             evac_gen = 0;
2868             scavengeTSO(tso);
2869             evac_gen = saved_evac_gen;
2870             failed_to_evac = rtsFalse;
2871             break;
2872         }
2873
2874 #if defined(PAR)
2875         case RBH: // cf. BLACKHOLE_BQ
2876         {
2877 #if 0
2878             nat size, ptrs, nonptrs, vhs;
2879             char str[80];
2880             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2881 #endif
2882             StgRBH *rbh = (StgRBH *)p;
2883             (StgClosure *)rbh->blocking_queue =
2884                 evacuate((StgClosure *)rbh->blocking_queue);
2885             recordMutable((StgMutClosure *)rbh);
2886             failed_to_evac = rtsFalse;  // mutable anyhow.
2887             IF_DEBUG(gc,
2888                      belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2889                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
2890             break;
2891         }
2892
2893         case BLOCKED_FETCH:
2894         {
2895             StgBlockedFetch *bf = (StgBlockedFetch *)p;
2896             // follow the pointer to the node which is being demanded
2897             (StgClosure *)bf->node =
2898                 evacuate((StgClosure *)bf->node);
2899             // follow the link to the rest of the blocking queue
2900             (StgClosure *)bf->link =
2901                 evacuate((StgClosure *)bf->link);
2902             if (failed_to_evac) {
2903                 failed_to_evac = rtsFalse;
2904                 recordMutable((StgMutClosure *)bf);
2905             }
2906             IF_DEBUG(gc,
2907                      belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2908                            bf, info_type((StgClosure *)bf),
2909                            bf->node, info_type(bf->node)));
2910             break;
2911         }
2912
2913 #ifdef DIST
2914         case REMOTE_REF:
2915 #endif
2916         case FETCH_ME:
2917             break; // nothing to do in this case
2918
2919         case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2920         {
2921             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2922             (StgClosure *)fmbq->blocking_queue =
2923                 evacuate((StgClosure *)fmbq->blocking_queue);
2924             if (failed_to_evac) {
2925                 failed_to_evac = rtsFalse;
2926                 recordMutable((StgMutClosure *)fmbq);
2927             }
2928             IF_DEBUG(gc,
2929                      belch("@@ scavenge: %p (%s) exciting, isn't it",
2930                            p, info_type((StgClosure *)p)));
2931             break;
2932         }
2933 #endif // PAR
2934
2935         default:
2936             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
2937                  info->type, p);
2938         }
2939
2940         if (failed_to_evac) {
2941             failed_to_evac = rtsFalse;
2942             mkMutCons((StgClosure *)q, &generations[evac_gen]);
2943         }
2944
2945         // mark the next bit to indicate "scavenged"
2946         mark(q+1, Bdescr(q));
2947
2948     } // while (!mark_stack_empty())
2949
2950     // start a new linear scan if the mark stack overflowed at some point
2951     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
2952         IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
2953         mark_stack_overflowed = rtsFalse;
2954         oldgen_scan_bd = oldest_gen->steps[0].blocks;
2955         oldgen_scan = oldgen_scan_bd->start;
2956     }
2957
2958     if (oldgen_scan_bd) {
2959         // push a new thing on the mark stack
2960     loop:
2961         // find a closure that is marked but not scavenged, and start
2962         // from there.
2963         while (oldgen_scan < oldgen_scan_bd->free
2964                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
2965             oldgen_scan++;
2966         }
2967
2968         if (oldgen_scan < oldgen_scan_bd->free) {
2969
2970             // already scavenged?
2971             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
2972                 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2973                 goto loop;
2974             }
2975             push_mark_stack(oldgen_scan);
2976             // ToDo: bump the linear scan by the actual size of the object
2977             oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2978             goto linear_scan;
2979         }
2980
2981         oldgen_scan_bd = oldgen_scan_bd->link;
2982         if (oldgen_scan_bd != NULL) {
2983             oldgen_scan = oldgen_scan_bd->start;
2984             goto loop;
2985         }
2986     }
2987 }
2988
2989 /* -----------------------------------------------------------------------------
2990    Scavenge one object.
2991
2992    This is used for objects that are temporarily marked as mutable
2993    because they contain old-to-new generation pointers.  Only certain
2994    objects can have this property.
2995    -------------------------------------------------------------------------- */
2996
2997 static rtsBool
2998 scavenge_one(StgPtr p)
2999 {
3000     const StgInfoTable *info;
3001     nat saved_evac_gen = evac_gen;
3002     rtsBool no_luck;
3003
3004     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3005     info = get_itbl((StgClosure *)p);
3006
3007     switch (info->type) {
3008
3009     case FUN:
3010     case FUN_1_0:                       // hardly worth specialising these guys
3011     case FUN_0_1:
3012     case FUN_1_1:
3013     case FUN_0_2:
3014     case FUN_2_0:
3015     case THUNK:
3016     case THUNK_1_0:
3017     case THUNK_0_1:
3018     case THUNK_1_1:
3019     case THUNK_0_2:
3020     case THUNK_2_0:
3021     case CONSTR:
3022     case CONSTR_1_0:
3023     case CONSTR_0_1:
3024     case CONSTR_1_1:
3025     case CONSTR_0_2:
3026     case CONSTR_2_0:
3027     case WEAK:
3028     case FOREIGN:
3029     case IND_PERM:
3030     case IND_OLDGEN_PERM:
3031     {
3032         StgPtr q, end;
3033
3034         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3035         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3036             (StgClosure *)*q = evacuate((StgClosure *)*q);
3037         }
3038         break;
3039     }
3040
3041     case CAF_BLACKHOLE:
3042     case SE_CAF_BLACKHOLE:
3043     case SE_BLACKHOLE:
3044     case BLACKHOLE:
3045         break;
3046
3047     case THUNK_SELECTOR:
3048     {
3049         StgSelector *s = (StgSelector *)p;
3050         s->selectee = evacuate(s->selectee);
3051         break;
3052     }
3053
3054     case ARR_WORDS:
3055         // nothing to follow
3056         break;
3057
3058     case MUT_ARR_PTRS:
3059     {
3060         // follow everything
3061         StgPtr next;
3062
3063         evac_gen = 0;           // repeatedly mutable
3064         recordMutable((StgMutClosure *)p);
3065         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3066         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3067             (StgClosure *)*p = evacuate((StgClosure *)*p);
3068         }
3069         evac_gen = saved_evac_gen;
3070         failed_to_evac = rtsFalse;
3071         break;
3072     }
3073
3074     case MUT_ARR_PTRS_FROZEN:
3075     {
3076         // follow everything
3077         StgPtr next;
3078
3079         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3080         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3081             (StgClosure *)*p = evacuate((StgClosure *)*p);
3082         }
3083         break;
3084     }
3085
3086     case TSO:
3087     {
3088         StgTSO *tso = (StgTSO *)p;
3089
3090         evac_gen = 0;           // repeatedly mutable
3091         scavengeTSO(tso);
3092         recordMutable((StgMutClosure *)tso);
3093         evac_gen = saved_evac_gen;
3094         failed_to_evac = rtsFalse;
3095         break;
3096     }
3097
3098     case AP_STACK:
3099     {
3100         StgAP_STACK *ap = (StgAP_STACK *)p;
3101
3102         ap->fun = evacuate(ap->fun);
3103         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3104         p = (StgPtr)ap->payload + ap->size;
3105         break;
3106     }
3107
3108     case PAP:
3109     case AP:
3110         p = scavenge_PAP((StgPAP *)p);
3111         break;
3112
3113     case IND_OLDGEN:
3114         // This might happen if for instance a MUT_CONS was pointing to a
3115         // THUNK which has since been updated.  The IND_OLDGEN will
3116         // be on the mutable list anyway, so we don't need to do anything
3117         // here.
3118         break;
3119
3120     default:
3121         barf("scavenge_one: strange object %d", (int)(info->type));
3122     }
3123
3124     no_luck = failed_to_evac;
3125     failed_to_evac = rtsFalse;
3126     return (no_luck);
3127 }
3128
3129 /* -----------------------------------------------------------------------------
3130    Scavenging mutable lists.
3131
3132    We treat the mutable list of each generation > N (i.e. all the
3133    generations older than the one being collected) as roots.  We also
3134    remove non-mutable objects from the mutable list at this point.
3135    -------------------------------------------------------------------------- */
3136
3137 static void
3138 scavenge_mut_once_list(generation *gen)
3139 {
3140   const StgInfoTable *info;
3141   StgMutClosure *p, *next, *new_list;
3142
3143   p = gen->mut_once_list;
3144   new_list = END_MUT_LIST;
3145   next = p->mut_link;
3146
3147   evac_gen = gen->no;
3148   failed_to_evac = rtsFalse;
3149
3150   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3151
3152     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3153     info = get_itbl(p);
3154     /*
3155     if (info->type==RBH)
3156       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3157     */
3158     switch(info->type) {
3159
3160     case IND_OLDGEN:
3161     case IND_OLDGEN_PERM:
3162     case IND_STATIC:
3163       /* Try to pull the indirectee into this generation, so we can
3164        * remove the indirection from the mutable list.
3165        */
3166       ((StgIndOldGen *)p)->indirectee =
3167         evacuate(((StgIndOldGen *)p)->indirectee);
3168
3169 #if 0 && defined(DEBUG)
3170       if (RtsFlags.DebugFlags.gc)
3171       /* Debugging code to print out the size of the thing we just
3172        * promoted
3173        */
3174       {
3175         StgPtr start = gen->steps[0].scan;
3176         bdescr *start_bd = gen->steps[0].scan_bd;
3177         nat size = 0;
3178         scavenge(&gen->steps[0]);
3179         if (start_bd != gen->steps[0].scan_bd) {
3180           size += (P_)BLOCK_ROUND_UP(start) - start;
3181           start_bd = start_bd->link;
3182           while (start_bd != gen->steps[0].scan_bd) {
3183             size += BLOCK_SIZE_W;
3184             start_bd = start_bd->link;
3185           }
3186           size += gen->steps[0].scan -
3187             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3188         } else {
3189           size = gen->steps[0].scan - start;
3190         }
3191         belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3192       }
3193 #endif
3194
3195       /* failed_to_evac might happen if we've got more than two
3196        * generations, we're collecting only generation 0, the
3197        * indirection resides in generation 2 and the indirectee is
3198        * in generation 1.
3199        */
3200       if (failed_to_evac) {
3201         failed_to_evac = rtsFalse;
3202         p->mut_link = new_list;
3203         new_list = p;
3204       } else {
3205         /* the mut_link field of an IND_STATIC is overloaded as the
3206          * static link field too (it just so happens that we don't need
3207          * both at the same time), so we need to NULL it out when
3208          * removing this object from the mutable list because the static
3209          * link fields are all assumed to be NULL before doing a major
3210          * collection.
3211          */
3212         p->mut_link = NULL;
3213       }
3214       continue;
3215
3216     case MUT_CONS:
3217         /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3218          * it from the mutable list if possible by promoting whatever it
3219          * points to.
3220          */
3221         if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3222             /* didn't manage to promote everything, so put the
3223              * MUT_CONS back on the list.
3224              */
3225             p->mut_link = new_list;
3226             new_list = p;
3227         }
3228         continue;
3229
3230     default:
3231       // shouldn't have anything else on the mutables list
3232       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3233     }
3234   }
3235
3236   gen->mut_once_list = new_list;
3237 }
3238
3239
3240 static void
3241 scavenge_mutable_list(generation *gen)
3242 {
3243   const StgInfoTable *info;
3244   StgMutClosure *p, *next;
3245
3246   p = gen->saved_mut_list;
3247   next = p->mut_link;
3248
3249   evac_gen = 0;
3250   failed_to_evac = rtsFalse;
3251
3252   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3253
3254     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3255     info = get_itbl(p);
3256     /*
3257     if (info->type==RBH)
3258       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3259     */
3260     switch(info->type) {
3261
3262     case MUT_ARR_PTRS:
3263       // follow everything
3264       p->mut_link = gen->mut_list;
3265       gen->mut_list = p;
3266       {
3267         StgPtr end, q;
3268
3269         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3270         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3271           (StgClosure *)*q = evacuate((StgClosure *)*q);
3272         }
3273         continue;
3274       }
3275
3276       // Happens if a MUT_ARR_PTRS in the old generation is frozen
3277     case MUT_ARR_PTRS_FROZEN:
3278       {
3279         StgPtr end, q;
3280
3281         evac_gen = gen->no;
3282         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3283         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3284           (StgClosure *)*q = evacuate((StgClosure *)*q);
3285         }
3286         evac_gen = 0;
3287         p->mut_link = NULL;
3288         if (failed_to_evac) {
3289             failed_to_evac = rtsFalse;
3290             mkMutCons((StgClosure *)p, gen);
3291         }
3292         continue;
3293       }
3294
3295     case MUT_VAR:
3296         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3297         p->mut_link = gen->mut_list;
3298         gen->mut_list = p;
3299         continue;
3300
3301     case MVAR:
3302       {
3303         StgMVar *mvar = (StgMVar *)p;
3304         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3305         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3306         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3307         p->mut_link = gen->mut_list;
3308         gen->mut_list = p;
3309         continue;
3310       }
3311
3312     case TSO:
3313       {
3314         StgTSO *tso = (StgTSO *)p;
3315
3316         scavengeTSO(tso);
3317
3318         /* Don't take this TSO off the mutable list - it might still
3319          * point to some younger objects (because we set evac_gen to 0
3320          * above).
3321          */
3322         tso->mut_link = gen->mut_list;
3323         gen->mut_list = (StgMutClosure *)tso;
3324         continue;
3325       }
3326
3327     case BLACKHOLE_BQ:
3328       {
3329         StgBlockingQueue *bh = (StgBlockingQueue *)p;
3330         (StgClosure *)bh->blocking_queue =
3331           evacuate((StgClosure *)bh->blocking_queue);
3332         p->mut_link = gen->mut_list;
3333         gen->mut_list = p;
3334         continue;
3335       }
3336
3337       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3338        */
3339     case IND_OLDGEN:
3340     case IND_OLDGEN_PERM:
3341       /* Try to pull the indirectee into this generation, so we can
3342        * remove the indirection from the mutable list.
3343        */
3344       evac_gen = gen->no;
3345       ((StgIndOldGen *)p)->indirectee =
3346         evacuate(((StgIndOldGen *)p)->indirectee);
3347       evac_gen = 0;
3348
3349       if (failed_to_evac) {
3350         failed_to_evac = rtsFalse;
3351         p->mut_link = gen->mut_once_list;
3352         gen->mut_once_list = p;
3353       } else {
3354         p->mut_link = NULL;
3355       }
3356       continue;
3357
3358 #if defined(PAR)
3359     // HWL: check whether all of these are necessary
3360
3361     case RBH: // cf. BLACKHOLE_BQ
3362       {
3363         // nat size, ptrs, nonptrs, vhs;
3364         // char str[80];
3365         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3366         StgRBH *rbh = (StgRBH *)p;
3367         (StgClosure *)rbh->blocking_queue =
3368           evacuate((StgClosure *)rbh->blocking_queue);
3369         if (failed_to_evac) {
3370           failed_to_evac = rtsFalse;
3371           recordMutable((StgMutClosure *)rbh);
3372         }
3373         // ToDo: use size of reverted closure here!
3374         p += BLACKHOLE_sizeW();
3375         break;
3376       }
3377
3378     case BLOCKED_FETCH:
3379       {
3380         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3381         // follow the pointer to the node which is being demanded
3382         (StgClosure *)bf->node =
3383           evacuate((StgClosure *)bf->node);
3384         // follow the link to the rest of the blocking queue
3385         (StgClosure *)bf->link =
3386           evacuate((StgClosure *)bf->link);
3387         if (failed_to_evac) {
3388           failed_to_evac = rtsFalse;
3389           recordMutable((StgMutClosure *)bf);
3390         }
3391         p += sizeofW(StgBlockedFetch);
3392         break;
3393       }
3394
3395 #ifdef DIST
3396     case REMOTE_REF:
3397       barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3398 #endif
3399     case FETCH_ME:
3400       p += sizeofW(StgFetchMe);
3401       break; // nothing to do in this case
3402
3403     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3404       {
3405         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3406         (StgClosure *)fmbq->blocking_queue =
3407           evacuate((StgClosure *)fmbq->blocking_queue);
3408         if (failed_to_evac) {
3409           failed_to_evac = rtsFalse;
3410           recordMutable((StgMutClosure *)fmbq);
3411         }
3412         p += sizeofW(StgFetchMeBlockingQueue);
3413         break;
3414       }
3415 #endif
3416
3417     default:
3418       // shouldn't have anything else on the mutables list
3419       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3420     }
3421   }
3422 }
3423
3424
3425 static void
3426 scavenge_static(void)
3427 {
3428   StgClosure* p = static_objects;
3429   const StgInfoTable *info;
3430
3431   /* Always evacuate straight to the oldest generation for static
3432    * objects */
3433   evac_gen = oldest_gen->no;
3434
3435   /* keep going until we've scavenged all the objects on the linked
3436      list... */
3437   while (p != END_OF_STATIC_LIST) {
3438
3439     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3440     info = get_itbl(p);
3441     /*
3442     if (info->type==RBH)
3443       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3444     */
3445     // make sure the info pointer is into text space
3446
3447     /* Take this object *off* the static_objects list,
3448      * and put it on the scavenged_static_objects list.
3449      */
3450     static_objects = STATIC_LINK(info,p);
3451     STATIC_LINK(info,p) = scavenged_static_objects;
3452     scavenged_static_objects = p;
3453
3454     switch (info -> type) {
3455
3456     case IND_STATIC:
3457       {
3458         StgInd *ind = (StgInd *)p;
3459         ind->indirectee = evacuate(ind->indirectee);
3460
3461         /* might fail to evacuate it, in which case we have to pop it
3462          * back on the mutable list (and take it off the
3463          * scavenged_static list because the static link and mut link
3464          * pointers are one and the same).
3465          */
3466         if (failed_to_evac) {
3467           failed_to_evac = rtsFalse;
3468           scavenged_static_objects = IND_STATIC_LINK(p);
3469           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3470           oldest_gen->mut_once_list = (StgMutClosure *)ind;
3471         }
3472         break;
3473       }
3474
3475     case THUNK_STATIC:
3476       scavenge_thunk_srt(info);
3477       break;
3478
3479     case FUN_STATIC:
3480       scavenge_fun_srt(info);
3481       break;
3482
3483     case CONSTR_STATIC:
3484       {
3485         StgPtr q, next;
3486
3487         next = (P_)p->payload + info->layout.payload.ptrs;
3488         // evacuate the pointers
3489         for (q = (P_)p->payload; q < next; q++) {
3490           (StgClosure *)*q = evacuate((StgClosure *)*q);
3491         }
3492         break;
3493       }
3494
3495     default:
3496       barf("scavenge_static: strange closure %d", (int)(info->type));
3497     }
3498
3499     ASSERT(failed_to_evac == rtsFalse);
3500
3501     /* get the next static object from the list.  Remember, there might
3502      * be more stuff on this list now that we've done some evacuating!
3503      * (static_objects is a global)
3504      */
3505     p = static_objects;
3506   }
3507 }
3508
3509 /* -----------------------------------------------------------------------------
3510    scavenge a chunk of memory described by a bitmap
3511    -------------------------------------------------------------------------- */
3512
3513 static void
3514 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
3515 {
3516     nat i, b;
3517     StgWord bitmap;
3518
3519     b = 0;
3520     bitmap = large_bitmap->bitmap[b];
3521     for (i = 0; i < size; ) {
3522         if ((bitmap & 1) == 0) {
3523             (StgClosure *)*p = evacuate((StgClosure *)*p);
3524         }
3525         i++;
3526         p++;
3527         if (i % BITS_IN(W_) == 0) {
3528             b++;
3529             bitmap = large_bitmap->bitmap[b];
3530         } else {
3531             bitmap = bitmap >> 1;
3532         }
3533     }
3534 }
3535
3536 static inline StgPtr
3537 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
3538 {
3539     while (size > 0) {
3540         if ((bitmap & 1) == 0) {
3541             (StgClosure *)*p = evacuate((StgClosure *)*p);
3542         }
3543         p++;
3544         bitmap = bitmap >> 1;
3545         size--;
3546     }
3547     return p;
3548 }
3549
3550 /* -----------------------------------------------------------------------------
3551    scavenge_stack walks over a section of stack and evacuates all the
3552    objects pointed to by it.  We can use the same code for walking
3553    AP_STACK_UPDs, since these are just sections of copied stack.
3554    -------------------------------------------------------------------------- */
3555
3556
3557 static void
3558 scavenge_stack(StgPtr p, StgPtr stack_end)
3559 {
3560   const StgRetInfoTable* info;
3561   StgWord bitmap;
3562   nat size;
3563
3564   //IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
3565
3566   /*
3567    * Each time around this loop, we are looking at a chunk of stack
3568    * that starts with an activation record.
3569    */
3570
3571   while (p < stack_end) {
3572     info  = get_ret_itbl((StgClosure *)p);
3573
3574     switch (info->i.type) {
3575
3576     case UPDATE_FRAME:
3577         ((StgUpdateFrame *)p)->updatee
3578             = evacuate(((StgUpdateFrame *)p)->updatee);
3579         p += sizeofW(StgUpdateFrame);
3580         continue;
3581
3582       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3583     case STOP_FRAME:
3584     case CATCH_FRAME:
3585     case RET_SMALL:
3586     case RET_VEC_SMALL:
3587         bitmap = BITMAP_BITS(info->i.layout.bitmap);
3588         size   = BITMAP_SIZE(info->i.layout.bitmap);
3589         // NOTE: the payload starts immediately after the info-ptr, we
3590         // don't have an StgHeader in the same sense as a heap closure.
3591         p++;
3592         p = scavenge_small_bitmap(p, size, bitmap);
3593
3594     follow_srt:
3595         scavenge_srt((StgClosure **)info->srt, info->i.srt_len);
3596         continue;
3597
3598     case RET_BCO: {
3599         StgBCO *bco;
3600         nat size;
3601
3602         p++;
3603         (StgClosure *)*p = evacuate((StgClosure *)*p);
3604         bco = (StgBCO *)*p;
3605         p++;
3606         size = BCO_BITMAP_SIZE(bco);
3607         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
3608         p += size;
3609         continue;
3610     }
3611
3612       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3613     case RET_BIG:
3614     case RET_VEC_BIG:
3615     {
3616         nat size;
3617
3618         size = info->i.layout.large_bitmap->size;
3619         p++;
3620         scavenge_large_bitmap(p, info->i.layout.large_bitmap, size);
3621         p += size;
3622         // and don't forget to follow the SRT
3623         goto follow_srt;
3624     }
3625
3626       // Dynamic bitmap: the mask is stored on the stack, and
3627       // there are a number of non-pointers followed by a number
3628       // of pointers above the bitmapped area.  (see StgMacros.h,
3629       // HEAP_CHK_GEN).
3630     case RET_DYN:
3631     {
3632         StgWord dyn;
3633         dyn = ((StgRetDyn *)p)->liveness;
3634
3635         // traverse the bitmap first
3636         bitmap = GET_LIVENESS(dyn);
3637         p      = (P_)&((StgRetDyn *)p)->payload[0];
3638         size   = RET_DYN_SIZE;
3639         p = scavenge_small_bitmap(p, size, bitmap);
3640
3641         // skip over the non-ptr words
3642         p += GET_NONPTRS(dyn);
3643
3644         // follow the ptr words
3645         for (size = GET_PTRS(dyn); size > 0; size--) {
3646             (StgClosure *)*p = evacuate((StgClosure *)*p);
3647             p++;
3648         }
3649         continue;
3650     }
3651
3652     case RET_FUN:
3653     {
3654         StgRetFun *ret_fun = (StgRetFun *)p;
3655         StgFunInfoTable *fun_info;
3656
3657         ret_fun->fun = evacuate(ret_fun->fun);
3658         fun_info = get_fun_itbl(ret_fun->fun);
3659         p = scavenge_arg_block(fun_info, ret_fun->payload);
3660         goto follow_srt;
3661     }
3662
3663     default:
3664         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
3665     }
3666   }
3667 }
3668
3669 /*-----------------------------------------------------------------------------
3670   scavenge the large object list.
3671
3672   evac_gen set by caller; similar games played with evac_gen as with
3673   scavenge() - see comment at the top of scavenge().  Most large
3674   objects are (repeatedly) mutable, so most of the time evac_gen will
3675   be zero.
3676   --------------------------------------------------------------------------- */
3677
3678 static void
3679 scavenge_large(step *stp)
3680 {
3681   bdescr *bd;
3682   StgPtr p;
3683
3684   bd = stp->new_large_objects;
3685
3686   for (; bd != NULL; bd = stp->new_large_objects) {
3687
3688     /* take this object *off* the large objects list and put it on
3689      * the scavenged large objects list.  This is so that we can
3690      * treat new_large_objects as a stack and push new objects on
3691      * the front when evacuating.
3692      */
3693     stp->new_large_objects = bd->link;
3694     dbl_link_onto(bd, &stp->scavenged_large_objects);
3695
3696     // update the block count in this step.
3697     stp->n_scavenged_large_blocks += bd->blocks;
3698
3699     p = bd->start;
3700     if (scavenge_one(p)) {
3701         mkMutCons((StgClosure *)p, stp->gen);
3702     }
3703   }
3704 }
3705
3706 /* -----------------------------------------------------------------------------
3707    Initialising the static object & mutable lists
3708    -------------------------------------------------------------------------- */
3709
3710 static void
3711 zero_static_object_list(StgClosure* first_static)
3712 {
3713   StgClosure* p;
3714   StgClosure* link;
3715   const StgInfoTable *info;
3716
3717   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3718     info = get_itbl(p);
3719     link = STATIC_LINK(info, p);
3720     STATIC_LINK(info,p) = NULL;
3721   }
3722 }
3723
3724 /* This function is only needed because we share the mutable link
3725  * field with the static link field in an IND_STATIC, so we have to
3726  * zero the mut_link field before doing a major GC, which needs the
3727  * static link field.
3728  *
3729  * It doesn't do any harm to zero all the mutable link fields on the
3730  * mutable list.
3731  */
3732
3733 static void
3734 zero_mutable_list( StgMutClosure *first )
3735 {
3736   StgMutClosure *next, *c;
3737
3738   for (c = first; c != END_MUT_LIST; c = next) {
3739     next = c->mut_link;
3740     c->mut_link = NULL;
3741   }
3742 }
3743
3744 /* -----------------------------------------------------------------------------
3745    Reverting CAFs
3746    -------------------------------------------------------------------------- */
3747
3748 void
3749 revertCAFs( void )
3750 {
3751     StgIndStatic *c;
3752
3753     for (c = (StgIndStatic *)caf_list; c != NULL;
3754          c = (StgIndStatic *)c->static_link)
3755     {
3756         c->header.info = c->saved_info;
3757         c->saved_info = NULL;
3758         // could, but not necessary: c->static_link = NULL;
3759     }
3760     caf_list = NULL;
3761 }
3762
3763 void
3764 markCAFs( evac_fn evac )
3765 {
3766     StgIndStatic *c;
3767
3768     for (c = (StgIndStatic *)caf_list; c != NULL;
3769          c = (StgIndStatic *)c->static_link)
3770     {
3771         evac(&c->indirectee);
3772     }
3773 }
3774
3775 /* -----------------------------------------------------------------------------
3776    Sanity code for CAF garbage collection.
3777
3778    With DEBUG turned on, we manage a CAF list in addition to the SRT
3779    mechanism.  After GC, we run down the CAF list and blackhole any
3780    CAFs which have been garbage collected.  This means we get an error
3781    whenever the program tries to enter a garbage collected CAF.
3782
3783    Any garbage collected CAFs are taken off the CAF list at the same
3784    time.
3785    -------------------------------------------------------------------------- */
3786
3787 #if 0 && defined(DEBUG)
3788
3789 static void
3790 gcCAFs(void)
3791 {
3792   StgClosure*  p;
3793   StgClosure** pp;
3794   const StgInfoTable *info;
3795   nat i;
3796
3797   i = 0;
3798   p = caf_list;
3799   pp = &caf_list;
3800
3801   while (p != NULL) {
3802
3803     info = get_itbl(p);
3804
3805     ASSERT(info->type == IND_STATIC);
3806
3807     if (STATIC_LINK(info,p) == NULL) {
3808       IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3809       // black hole it
3810       SET_INFO(p,&stg_BLACKHOLE_info);
3811       p = STATIC_LINK2(info,p);
3812       *pp = p;
3813     }
3814     else {
3815       pp = &STATIC_LINK2(info,p);
3816       p = *pp;
3817       i++;
3818     }
3819
3820   }
3821
3822   //  belch("%d CAFs live", i);
3823 }
3824 #endif
3825
3826
3827 /* -----------------------------------------------------------------------------
3828    Lazy black holing.
3829
3830    Whenever a thread returns to the scheduler after possibly doing
3831    some work, we have to run down the stack and black-hole all the
3832    closures referred to by update frames.
3833    -------------------------------------------------------------------------- */
3834
3835 static void
3836 threadLazyBlackHole(StgTSO *tso)
3837 {
3838     StgClosure *frame;
3839     StgRetInfoTable *info;
3840     StgBlockingQueue *bh;
3841     StgPtr stack_end;
3842
3843     stack_end = &tso->stack[tso->stack_size];
3844
3845     frame = (StgClosure *)tso->sp;
3846
3847     while (1) {
3848         info = get_ret_itbl(frame);
3849
3850         switch (info->i.type) {
3851
3852         case UPDATE_FRAME:
3853             bh = (StgBlockingQueue *)((StgUpdateFrame *)frame)->updatee;
3854
3855             /* if the thunk is already blackholed, it means we've also
3856              * already blackholed the rest of the thunks on this stack,
3857              * so we can stop early.
3858              *
3859              * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3860              * don't interfere with this optimisation.
3861              */
3862             if (bh->header.info == &stg_BLACKHOLE_info) {
3863                 return;
3864             }
3865
3866             if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
3867                 bh->header.info != &stg_CAF_BLACKHOLE_info) {
3868 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3869                 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3870 #endif
3871 #ifdef PROFILING
3872                 // @LDV profiling
3873                 // We pretend that bh is now dead.
3874                 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
3875 #endif
3876                 SET_INFO(bh,&stg_BLACKHOLE_info);
3877 #ifdef PROFILING
3878                 // @LDV profiling
3879                 // We pretend that bh has just been created.
3880                 LDV_recordCreate(bh);
3881 #endif
3882             }
3883
3884             frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
3885             break;
3886
3887         case STOP_FRAME:
3888             return;
3889
3890             // normal stack frames; do nothing except advance the pointer
3891         default:
3892             (StgPtr)frame += stack_frame_sizeW(frame);
3893         }
3894     }
3895 }
3896
3897
3898 /* -----------------------------------------------------------------------------
3899  * Stack squeezing
3900  *
3901  * Code largely pinched from old RTS, then hacked to bits.  We also do
3902  * lazy black holing here.
3903  *
3904  * -------------------------------------------------------------------------- */
3905
3906 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
3907
3908 static void
3909 threadSqueezeStack(StgTSO *tso)
3910 {
3911     StgPtr frame;
3912     rtsBool prev_was_update_frame;
3913     StgClosure *updatee = NULL;
3914     StgPtr bottom;
3915     StgRetInfoTable *info;
3916     StgWord current_gap_size;
3917     struct stack_gap *gap;
3918
3919     // Stage 1:
3920     //    Traverse the stack upwards, replacing adjacent update frames
3921     //    with a single update frame and a "stack gap".  A stack gap
3922     //    contains two values: the size of the gap, and the distance
3923     //    to the next gap (or the stack top).
3924
3925     bottom = &(tso->stack[tso->stack_size]);
3926
3927     frame = tso->sp;
3928
3929     ASSERT(frame < bottom);
3930
3931     prev_was_update_frame = rtsFalse;
3932     current_gap_size = 0;
3933     gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
3934
3935     while (frame < bottom) {
3936
3937         info = get_ret_itbl((StgClosure *)frame);
3938         switch (info->i.type) {
3939
3940         case UPDATE_FRAME:
3941         {
3942             StgUpdateFrame *upd = (StgUpdateFrame *)frame;
3943
3944             if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
3945
3946                 // found a BLACKHOLE'd update frame; we've been here
3947                 // before, in a previous GC, so just break out.
3948
3949                 // Mark the end of the gap, if we're in one.
3950                 if (current_gap_size != 0) {
3951                     gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
3952                 }
3953
3954                 frame += sizeofW(StgUpdateFrame);
3955                 goto done_traversing;
3956             }
3957
3958             if (prev_was_update_frame) {
3959
3960                 TICK_UPD_SQUEEZED();
3961                 /* wasn't there something about update squeezing and ticky to be
3962                  * sorted out?  oh yes: we aren't counting each enter properly
3963                  * in this case.  See the log somewhere.  KSW 1999-04-21
3964                  *
3965                  * Check two things: that the two update frames don't point to
3966                  * the same object, and that the updatee_bypass isn't already an
3967                  * indirection.  Both of these cases only happen when we're in a
3968                  * block hole-style loop (and there are multiple update frames
3969                  * on the stack pointing to the same closure), but they can both
3970                  * screw us up if we don't check.
3971                  */
3972                 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
3973                     // this wakes the threads up
3974                     UPD_IND_NOLOCK(upd->updatee, updatee);
3975                 }
3976
3977                 // now mark this update frame as a stack gap.  The gap
3978                 // marker resides in the bottom-most update frame of
3979                 // the series of adjacent frames, and covers all the
3980                 // frames in this series.
3981                 current_gap_size += sizeofW(StgUpdateFrame);
3982                 ((struct stack_gap *)frame)->gap_size = current_gap_size;
3983                 ((struct stack_gap *)frame)->next_gap = gap;
3984
3985                 frame += sizeofW(StgUpdateFrame);
3986                 continue;
3987             }
3988
3989             // single update frame, or the topmost update frame in a series
3990             else {
3991                 StgBlockingQueue *bh = (StgBlockingQueue *)upd->updatee;
3992
3993                 // Do lazy black-holing
3994                 if (bh->header.info != &stg_BLACKHOLE_info &&
3995                     bh->header.info != &stg_BLACKHOLE_BQ_info &&
3996                     bh->header.info != &stg_CAF_BLACKHOLE_info) {
3997 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3998                     belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3999 #endif
4000 #ifdef DEBUG
4001                     /* zero out the slop so that the sanity checker can tell
4002                      * where the next closure is.
4003                      */
4004                     {
4005                         StgInfoTable *bh_info = get_itbl(bh);
4006                         nat np = bh_info->layout.payload.ptrs,
4007                             nw = bh_info->layout.payload.nptrs, i;
4008                         /* don't zero out slop for a THUNK_SELECTOR,
4009                          * because its layout info is used for a
4010                          * different purpose, and it's exactly the
4011                          * same size as a BLACKHOLE in any case.
4012                          */
4013                         if (bh_info->type != THUNK_SELECTOR) {
4014                             for (i = np; i < np + nw; i++) {
4015                                 ((StgClosure *)bh)->payload[i] = 0;
4016                             }
4017                         }
4018                     }
4019 #endif
4020 #ifdef PROFILING
4021                     // We pretend that bh is now dead.
4022                     LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4023 #endif
4024                     // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
4025                     SET_INFO(bh,&stg_BLACKHOLE_info);
4026 #ifdef PROFILING
4027                     // We pretend that bh has just been created.
4028                     LDV_recordCreate(bh);
4029 #endif
4030                 }
4031
4032                 prev_was_update_frame = rtsTrue;
4033                 updatee = upd->updatee;
4034                 frame += sizeofW(StgUpdateFrame);
4035                 continue;
4036             }
4037         }
4038
4039         default:
4040             prev_was_update_frame = rtsFalse;
4041
4042             // we're not in a gap... check whether this is the end of a gap
4043             // (an update frame can't be the end of a gap).
4044             if (current_gap_size != 0) {
4045                 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4046             }
4047             current_gap_size = 0;
4048
4049             frame += stack_frame_sizeW((StgClosure *)frame);
4050             continue;
4051         }
4052     }
4053
4054 done_traversing:
4055
4056     // Now we have a stack with gaps in it, and we have to walk down
4057     // shoving the stack up to fill in the gaps.  A diagram might
4058     // help:
4059     //
4060     //    +| ********* |
4061     //     | ********* | <- sp
4062     //     |           |
4063     //     |           | <- gap_start
4064     //     | ......... |                |
4065     //     | stack_gap | <- gap         | chunk_size
4066     //     | ......... |                |
4067     //     | ......... | <- gap_end     v
4068     //     | ********* |
4069     //     | ********* |
4070     //     | ********* |
4071     //    -| ********* |
4072     //
4073     // 'sp'  points the the current top-of-stack
4074     // 'gap' points to the stack_gap structure inside the gap
4075     // *****   indicates real stack data
4076     // .....   indicates gap
4077     // <empty> indicates unused
4078     //
4079     {
4080         void *sp;
4081         void *gap_start, *next_gap_start, *gap_end;
4082         nat chunk_size;
4083
4084         next_gap_start = (void *)gap + sizeof(StgUpdateFrame);
4085         sp = next_gap_start;
4086
4087         while ((StgPtr)gap > tso->sp) {
4088
4089             // we're working in *bytes* now...
4090             gap_start = next_gap_start;
4091             gap_end = gap_start - gap->gap_size * sizeof(W_);
4092
4093             gap = gap->next_gap;
4094             next_gap_start = (void *)gap + sizeof(StgUpdateFrame);
4095
4096             chunk_size = gap_end - next_gap_start;
4097             sp -= chunk_size;
4098             memmove(sp, next_gap_start, chunk_size);
4099         }
4100
4101         tso->sp = (StgPtr)sp;
4102     }
4103 }
4104
4105 /* -----------------------------------------------------------------------------
4106  * Pausing a thread
4107  *
4108  * We have to prepare for GC - this means doing lazy black holing
4109  * here.  We also take the opportunity to do stack squeezing if it's
4110  * turned on.
4111  * -------------------------------------------------------------------------- */
4112 void
4113 threadPaused(StgTSO *tso)
4114 {
4115   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4116     threadSqueezeStack(tso);    // does black holing too
4117   else
4118     threadLazyBlackHole(tso);
4119 }
4120
4121 /* -----------------------------------------------------------------------------
4122  * Debugging
4123  * -------------------------------------------------------------------------- */
4124
4125 #if DEBUG
4126 void
4127 printMutOnceList(generation *gen)
4128 {
4129   StgMutClosure *p, *next;
4130
4131   p = gen->mut_once_list;
4132   next = p->mut_link;
4133
4134   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4135   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4136     fprintf(stderr, "%p (%s), ",
4137             p, info_type((StgClosure *)p));
4138   }
4139   fputc('\n', stderr);
4140 }
4141
4142 void
4143 printMutableList(generation *gen)
4144 {
4145   StgMutClosure *p, *next;
4146
4147   p = gen->mut_list;
4148   next = p->mut_link;
4149
4150   fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4151   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4152     fprintf(stderr, "%p (%s), ",
4153             p, info_type((StgClosure *)p));
4154   }
4155   fputc('\n', stderr);
4156 }
4157
4158 static inline rtsBool
4159 maybeLarge(StgClosure *closure)
4160 {
4161   StgInfoTable *info = get_itbl(closure);
4162
4163   /* closure types that may be found on the new_large_objects list;
4164      see scavenge_large */
4165   return (info->type == MUT_ARR_PTRS ||
4166           info->type == MUT_ARR_PTRS_FROZEN ||
4167           info->type == TSO ||
4168           info->type == ARR_WORDS);
4169 }
4170
4171
4172 #endif // DEBUG