ghc/rts/GC.c

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