ghc/rts/GC.c

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