ghc/rts/GC.c

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