ghc/rts/GC.c

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