ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.69 2000/01/13 14:34:02 hwloidl Exp $
   3  *
   4  * (c) The GHC Team 1998-1999
   5  *
   6  * Generational garbage collector
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 //@menu
  11 //* Includes::
  12 //* STATIC OBJECT LIST::
  13 //* Static function declarations::
  14 //* Garbage Collect::
  15 //* Weak Pointers::
  16 //* Evacuation::
  17 //* Scavenging::
  18 //* Reverting CAFs::
  19 //* Sanity code for CAF garbage collection::
  20 //* Lazy black holing::
  21 //* Stack squeezing::
  22 //* Pausing a thread::
  23 //* Index::
  24 //@end menu
  25
  26 //@node Includes, STATIC OBJECT LIST
  27 //@subsection Includes
  28
  29 #include "Rts.h"
  30 #include "RtsFlags.h"
  31 #include "RtsUtils.h"
  32 #include "Storage.h"
  33 #include "StoragePriv.h"
  34 #include "Stats.h"
  35 #include "Schedule.h"
  36 #include "SchedAPI.h" /* for ReverCAFs prototype */
  37 #include "Sanity.h"
  38 #include "GC.h"
  39 #include "BlockAlloc.h"
  40 #include "Main.h"
  41 #include "ProfHeap.h"
  42 #include "SchedAPI.h"
  43 #include "Weak.h"
  44 #include "StablePriv.h"
  45 #if defined(GRAN) || defined(PAR)
  46 # include "GranSimRts.h"
  47 # include "ParallelRts.h"
  48 # include "FetchMe.h"
  49 # if defined(DEBUG)
  50 #  include "Printer.h"
  51 #  include "ParallelDebug.h"
  52 # endif
  53 #endif
  54
  55 StgCAF* enteredCAFs;
  56
  57 //@node STATIC OBJECT LIST, Static function declarations, Includes
  58 //@subsection STATIC OBJECT LIST
  59
  60 /* STATIC OBJECT LIST.
  61  *
  62  * During GC:
  63  * We maintain a linked list of static objects that are still live.
  64  * The requirements for this list are:
  65  *
  66  *  - we need to scan the list while adding to it, in order to
  67  *    scavenge all the static objects (in the same way that
  68  *    breadth-first scavenging works for dynamic objects).
  69  *
  70  *  - we need to be able to tell whether an object is already on
  71  *    the list, to break loops.
  72  *
  73  * Each static object has a "static link field", which we use for
  74  * linking objects on to the list.  We use a stack-type list, consing
  75  * objects on the front as they are added (this means that the
  76  * scavenge phase is depth-first, not breadth-first, but that
  77  * shouldn't matter).
  78  *
  79  * A separate list is kept for objects that have been scavenged
  80  * already - this is so that we can zero all the marks afterwards.
  81  *
  82  * An object is on the list if its static link field is non-zero; this
  83  * means that we have to mark the end of the list with '1', not NULL.
  84  *
  85  * Extra notes for generational GC:
  86  *
  87  * Each generation has a static object list associated with it.  When
  88  * collecting generations up to N, we treat the static object lists
  89  * from generations > N as roots.
  90  *
  91  * We build up a static object list while collecting generations 0..N,
  92  * which is then appended to the static object list of generation N+1.
  93  */
  94 StgClosure* static_objects;           /* live static objects */
  95 StgClosure* scavenged_static_objects; /* static objects scavenged so far */
  96
  97 /* N is the oldest generation being collected, where the generations
  98  * are numbered starting at 0.  A major GC (indicated by the major_gc
  99  * flag) is when we're collecting all generations.  We only attempt to
 100  * deal with static objects and GC CAFs when doing a major GC.
 101  */
 102 static nat N;
 103 static rtsBool major_gc;
 104
 105 /* Youngest generation that objects should be evacuated to in
 106  * evacuate().  (Logically an argument to evacuate, but it's static
 107  * a lot of the time so we optimise it into a global variable).
 108  */
 109 static nat evac_gen;
 110
 111 /* WEAK POINTERS
 112  */
 113 static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
 114 static rtsBool weak_done;       /* all done for this pass */
 115
 116 /* Flag indicating failure to evacuate an object to the desired
 117  * generation.
 118  */
 119 static rtsBool failed_to_evac;
 120
 121 /* Old to-space (used for two-space collector only)
 122  */
 123 bdescr *old_to_space;
 124
 125 /* Data used for allocation area sizing.
 126  */
 127 lnat new_blocks;                /* blocks allocated during this GC */
 128 lnat g0s0_pcnt_kept = 30;       /* percentage of g0s0 live at last minor GC */
 129
 130 //@node Static function declarations, Garbage Collect, STATIC OBJECT LIST
 131 //@subsection Static function declarations
 132
 133 /* -----------------------------------------------------------------------------
 134    Static function declarations
 135    -------------------------------------------------------------------------- */
 136
 137 static StgClosure * evacuate                ( StgClosure *q );
 138 static void         zero_static_object_list ( StgClosure* first_static );
 139 static void         zero_mutable_list       ( StgMutClosure *first );
 140 static void         revert_dead_CAFs        ( void );
 141
 142 static rtsBool      traverse_weak_ptr_list  ( void );
 143 static void         cleanup_weak_ptr_list   ( StgWeak **list );
 144
 145 static void         scavenge_stack          ( StgPtr p, StgPtr stack_end );
 146 static void         scavenge_large          ( step *step );
 147 static void         scavenge                ( step *step );
 148 static void         scavenge_static         ( void );
 149 static void         scavenge_mutable_list   ( generation *g );
 150 static void         scavenge_mut_once_list  ( generation *g );
 151
 152 #ifdef DEBUG
 153 static void         gcCAFs                  ( void );
 154 #endif
 155
 156 //@node Garbage Collect, Weak Pointers, Static function declarations
 157 //@subsection Garbage Collect
 158
 159 /* -----------------------------------------------------------------------------
 160    GarbageCollect
 161
 162    For garbage collecting generation N (and all younger generations):
 163
 164      - follow all pointers in the root set.  the root set includes all
 165        mutable objects in all steps in all generations.
 166
 167      - for each pointer, evacuate the object it points to into either
 168        + to-space in the next higher step in that generation, if one exists,
 169        + if the object's generation == N, then evacuate it to the next
 170          generation if one exists, or else to-space in the current
 171          generation.
 172        + if the object's generation < N, then evacuate it to to-space
 173          in the next generation.
 174
 175      - repeatedly scavenge to-space from each step in each generation
 176        being collected until no more objects can be evacuated.
 177
 178      - free from-space in each step, and set from-space = to-space.
 179
 180    -------------------------------------------------------------------------- */
 181 //@cindex GarbageCollect
 182
 183 void GarbageCollect(void (*get_roots)(void))
 184 {
 185   bdescr *bd;
 186   step *step;
 187   lnat live, allocated, collected = 0, copied = 0;
 188   nat g, s;
 189
 190 #ifdef PROFILING
 191   CostCentreStack *prev_CCS;
 192 #endif
 193
 194 #if defined(DEBUG) && defined(GRAN)
 195   IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n",
 196                      Now, Now))
 197 #endif
 198
 199   /* tell the stats department that we've started a GC */
 200   stat_startGC();
 201
 202   /* attribute any costs to CCS_GC */
 203 #ifdef PROFILING
 204   prev_CCS = CCCS;
 205   CCCS = CCS_GC;
 206 #endif
 207
 208   /* Approximate how much we allocated */
 209   allocated = calcAllocated();
 210
 211   /* Figure out which generation to collect
 212    */
 213   N = 0;
 214   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 215     if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
 216       N = g;
 217     }
 218   }
 219   major_gc = (N == RtsFlags.GcFlags.generations-1);
 220
 221   /* check stack sanity *before* GC (ToDo: check all threads) */
 222 #if defined(GRAN)
 223   // ToDo!: check sanity  IF_DEBUG(sanity, checkTSOsSanity());
 224 #endif
 225     IF_DEBUG(sanity, checkFreeListSanity());
 226
 227   /* Initialise the static object lists
 228    */
 229   static_objects = END_OF_STATIC_LIST;
 230   scavenged_static_objects = END_OF_STATIC_LIST;
 231
 232   /* zero the mutable list for the oldest generation (see comment by
 233    * zero_mutable_list below).
 234    */
 235   if (major_gc) {
 236     zero_mutable_list(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
 237   }
 238
 239   /* Save the old to-space if we're doing a two-space collection
 240    */
 241   if (RtsFlags.GcFlags.generations == 1) {
 242     old_to_space = g0s0->to_space;
 243     g0s0->to_space = NULL;
 244   }
 245
 246   /* Keep a count of how many new blocks we allocated during this GC
 247    * (used for resizing the allocation area, later).
 248    */
 249   new_blocks = 0;
 250
 251   /* Initialise to-space in all the generations/steps that we're
 252    * collecting.
 253    */
 254   for (g = 0; g <= N; g++) {
 255     generations[g].mut_once_list = END_MUT_LIST;
 256     generations[g].mut_list = END_MUT_LIST;
 257
 258     for (s = 0; s < generations[g].n_steps; s++) {
 259
 260       /* generation 0, step 0 doesn't need to-space */
 261       if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
 262         continue;
 263       }
 264
 265       /* Get a free block for to-space.  Extra blocks will be chained on
 266        * as necessary.
 267        */
 268       bd = allocBlock();
 269       step = &generations[g].steps[s];
 270       ASSERT(step->gen->no == g);
 271       ASSERT(step->hp ? Bdescr(step->hp)->step == step : rtsTrue);
 272       bd->gen  = &generations[g];
 273       bd->step = step;
 274       bd->link = NULL;
 275       bd->evacuated = 1;        /* it's a to-space block */
 276       step->hp        = bd->start;
 277       step->hpLim     = step->hp + BLOCK_SIZE_W;
 278       step->hp_bd     = bd;
 279       step->to_space  = bd;
 280       step->to_blocks = 1;
 281       step->scan      = bd->start;
 282       step->scan_bd   = bd;
 283       step->new_large_objects = NULL;
 284       step->scavenged_large_objects = NULL;
 285       new_blocks++;
 286       /* mark the large objects as not evacuated yet */
 287       for (bd = step->large_objects; bd; bd = bd->link) {
 288         bd->evacuated = 0;
 289       }
 290     }
 291   }
 292
 293   /* make sure the older generations have at least one block to
 294    * allocate into (this makes things easier for copy(), see below.
 295    */
 296   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 297     for (s = 0; s < generations[g].n_steps; s++) {
 298       step = &generations[g].steps[s];
 299       if (step->hp_bd == NULL) {
 300         bd = allocBlock();
 301         bd->gen = &generations[g];
 302         bd->step = step;
 303         bd->link = NULL;
 304         bd->evacuated = 0;      /* *not* a to-space block */
 305         step->hp = bd->start;
 306         step->hpLim = step->hp + BLOCK_SIZE_W;
 307         step->hp_bd = bd;
 308         step->blocks = bd;
 309         step->n_blocks = 1;
 310         new_blocks++;
 311       }
 312       /* Set the scan pointer for older generations: remember we
 313        * still have to scavenge objects that have been promoted. */
 314       step->scan = step->hp;
 315       step->scan_bd = step->hp_bd;
 316       step->to_space = NULL;
 317       step->to_blocks = 0;
 318       step->new_large_objects = NULL;
 319       step->scavenged_large_objects = NULL;
 320     }
 321   }
 322
 323   /* -----------------------------------------------------------------------
 324    * follow all the roots that we know about:
 325    *   - mutable lists from each generation > N
 326    * we want to *scavenge* these roots, not evacuate them: they're not
 327    * going to move in this GC.
 328    * Also: do them in reverse generation order.  This is because we
 329    * often want to promote objects that are pointed to by older
 330    * generations early, so we don't have to repeatedly copy them.
 331    * Doing the generations in reverse order ensures that we don't end
 332    * up in the situation where we want to evac an object to gen 3 and
 333    * it has already been evaced to gen 2.
 334    */
 335   {
 336     int st;
 337     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 338       generations[g].saved_mut_list = generations[g].mut_list;
 339       generations[g].mut_list = END_MUT_LIST;
 340     }
 341
 342     /* Do the mut-once lists first */
 343     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 344       IF_PAR_DEBUG(verbose,
 345                    printMutOnceList(&generations[g]));
 346       scavenge_mut_once_list(&generations[g]);
 347       evac_gen = g;
 348       for (st = generations[g].n_steps-1; st >= 0; st--) {
 349         scavenge(&generations[g].steps[st]);
 350       }
 351     }
 352
 353     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 354       IF_PAR_DEBUG(verbose,
 355                    printMutableList(&generations[g]));
 356       scavenge_mutable_list(&generations[g]);
 357       evac_gen = g;
 358       for (st = generations[g].n_steps-1; st >= 0; st--) {
 359         scavenge(&generations[g].steps[st]);
 360       }
 361     }
 362   }
 363
 364   /* follow all the roots that the application knows about.
 365    */
 366   evac_gen = 0;
 367   get_roots();
 368
 369 #if defined(PAR)
 370   /* And don't forget to mark the TSO if we got here direct from
 371    * Haskell! */
 372   /* Not needed in a seq version?
 373   if (CurrentTSO) {
 374     CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
 375   }
 376   */
 377
 378   /* Mark the entries in the GALA table of the parallel system */
 379   markLocalGAs(major_gc);
 380 #endif
 381
 382   /* Mark the weak pointer list, and prepare to detect dead weak
 383    * pointers.
 384    */
 385   old_weak_ptr_list = weak_ptr_list;
 386   weak_ptr_list = NULL;
 387   weak_done = rtsFalse;
 388
 389   /* Mark the stable pointer table.
 390    */
 391   markStablePtrTable(major_gc);
 392
 393 #ifdef INTERPRETER
 394   {
 395       /* ToDo: To fix the caf leak, we need to make the commented out
 396        * parts of this code do something sensible - as described in
 397        * the CAF document.
 398        */
 399       extern void markHugsObjects(void);
 400       markHugsObjects();
 401   }
 402 #endif
 403
 404   /* -------------------------------------------------------------------------
 405    * Repeatedly scavenge all the areas we know about until there's no
 406    * more scavenging to be done.
 407    */
 408   {
 409     rtsBool flag;
 410   loop:
 411     flag = rtsFalse;
 412
 413     /* scavenge static objects */
 414     if (major_gc && static_objects != END_OF_STATIC_LIST) {
 415       scavenge_static();
 416     }
 417
 418     /* When scavenging the older generations:  Objects may have been
 419      * evacuated from generations <= N into older generations, and we
 420      * need to scavenge these objects.  We're going to try to ensure that
 421      * any evacuations that occur move the objects into at least the
 422      * same generation as the object being scavenged, otherwise we
 423      * have to create new entries on the mutable list for the older
 424      * generation.
 425      */
 426
 427     /* scavenge each step in generations 0..maxgen */
 428     {
 429       int gen, st;
 430     loop2:
 431       for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
 432         for (st = generations[gen].n_steps-1; st >= 0 ; st--) {
 433           if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
 434             continue;
 435           }
 436           step = &generations[gen].steps[st];
 437           evac_gen = gen;
 438           if (step->hp_bd != step->scan_bd || step->scan < step->hp) {
 439             scavenge(step);
 440             flag = rtsTrue;
 441             goto loop2;
 442           }
 443           if (step->new_large_objects != NULL) {
 444             scavenge_large(step);
 445             flag = rtsTrue;
 446             goto loop2;
 447           }
 448         }
 449       }
 450     }
 451     if (flag) { goto loop; }
 452
 453     /* must be last... */
 454     if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
 455       goto loop;
 456     }
 457   }
 458
 459   /* Final traversal of the weak pointer list (see comment by
 460    * cleanUpWeakPtrList below).
 461    */
 462   cleanup_weak_ptr_list(&weak_ptr_list);
 463
 464   /* Now see which stable names are still alive.
 465    */
 466   gcStablePtrTable(major_gc);
 467
 468   /* revert dead CAFs and update enteredCAFs list */
 469   revert_dead_CAFs();
 470
 471   /* Set the maximum blocks for the oldest generation, based on twice
 472    * the amount of live data now, adjusted to fit the maximum heap
 473    * size if necessary.
 474    *
 475    * This is an approximation, since in the worst case we'll need
 476    * twice the amount of live data plus whatever space the other
 477    * generations need.
 478    */
 479   if (RtsFlags.GcFlags.generations > 1) {
 480     if (major_gc) {
 481       oldest_gen->max_blocks =
 482         stg_max(oldest_gen->steps[0].to_blocks * RtsFlags.GcFlags.oldGenFactor,
 483                 RtsFlags.GcFlags.minOldGenSize);
 484       if (oldest_gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
 485         oldest_gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
 486         if (((int)oldest_gen->max_blocks -
 487              (int)oldest_gen->steps[0].to_blocks) <
 488             (RtsFlags.GcFlags.pcFreeHeap *
 489              RtsFlags.GcFlags.maxHeapSize / 200)) {
 490           heapOverflow();
 491         }
 492       }
 493     }
 494   }
 495
 496   /* run through all the generations/steps and tidy up
 497    */
 498   copied = new_blocks * BLOCK_SIZE_W;
 499   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 500
 501     if (g <= N) {
 502       generations[g].collections++; /* for stats */
 503     }
 504
 505     for (s = 0; s < generations[g].n_steps; s++) {
 506       bdescr *next;
 507       step = &generations[g].steps[s];
 508
 509       if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 510         /* Tidy the end of the to-space chains */
 511         step->hp_bd->free = step->hp;
 512         step->hp_bd->link = NULL;
 513         /* stats information: how much we copied */
 514         if (g <= N) {
 515           copied -= step->hp_bd->start + BLOCK_SIZE_W -
 516             step->hp_bd->free;
 517         }
 518       }
 519
 520       /* for generations we collected... */
 521       if (g <= N) {
 522
 523         collected += step->n_blocks * BLOCK_SIZE_W; /* for stats */
 524
 525         /* free old memory and shift to-space into from-space for all
 526          * the collected steps (except the allocation area).  These
 527          * freed blocks will probaby be quickly recycled.
 528          */
 529         if (!(g == 0 && s == 0)) {
 530           freeChain(step->blocks);
 531           step->blocks = step->to_space;
 532           step->n_blocks = step->to_blocks;
 533           step->to_space = NULL;
 534           step->to_blocks = 0;
 535           for (bd = step->blocks; bd != NULL; bd = bd->link) {
 536             bd->evacuated = 0;  /* now from-space */
 537           }
 538         }
 539
 540         /* LARGE OBJECTS.  The current live large objects are chained on
 541          * scavenged_large, having been moved during garbage
 542          * collection from large_objects.  Any objects left on
 543          * large_objects list are therefore dead, so we free them here.
 544          */
 545         for (bd = step->large_objects; bd != NULL; bd = next) {
 546           next = bd->link;
 547           freeGroup(bd);
 548           bd = next;
 549         }
 550         for (bd = step->scavenged_large_objects; bd != NULL; bd = bd->link) {
 551           bd->evacuated = 0;
 552         }
 553         step->large_objects = step->scavenged_large_objects;
 554
 555         /* Set the maximum blocks for this generation, interpolating
 556          * between the maximum size of the oldest and youngest
 557          * generations.
 558          *
 559          * max_blocks =    oldgen_max_blocks * G
 560          *                 ----------------------
 561          *                      oldest_gen
 562          */
 563         if (g != 0) {
 564 #if 0
 565           generations[g].max_blocks = (oldest_gen->max_blocks * g)
 566                / (RtsFlags.GcFlags.generations-1);
 567 #endif
 568           generations[g].max_blocks = oldest_gen->max_blocks;
 569         }
 570
 571       /* for older generations... */
 572       } else {
 573
 574         /* For older generations, we need to append the
 575          * scavenged_large_object list (i.e. large objects that have been
 576          * promoted during this GC) to the large_object list for that step.
 577          */
 578         for (bd = step->scavenged_large_objects; bd; bd = next) {
 579           next = bd->link;
 580           bd->evacuated = 0;
 581           dbl_link_onto(bd, &step->large_objects);
 582         }
 583
 584         /* add the new blocks we promoted during this GC */
 585         step->n_blocks += step->to_blocks;
 586       }
 587     }
 588   }
 589
 590   /* Guess the amount of live data for stats. */
 591   live = calcLive();
 592
 593   /* Free the small objects allocated via allocate(), since this will
 594    * all have been copied into G0S1 now.
 595    */
 596   if (small_alloc_list != NULL) {
 597     freeChain(small_alloc_list);
 598   }
 599   small_alloc_list = NULL;
 600   alloc_blocks = 0;
 601   alloc_Hp = NULL;
 602   alloc_HpLim = NULL;
 603   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 604
 605   /* Two-space collector:
 606    * Free the old to-space, and estimate the amount of live data.
 607    */
 608   if (RtsFlags.GcFlags.generations == 1) {
 609     nat blocks;
 610
 611     if (old_to_space != NULL) {
 612       freeChain(old_to_space);
 613     }
 614     for (bd = g0s0->to_space; bd != NULL; bd = bd->link) {
 615       bd->evacuated = 0;        /* now from-space */
 616     }
 617
 618     /* For a two-space collector, we need to resize the nursery. */
 619
 620     /* set up a new nursery.  Allocate a nursery size based on a
 621      * function of the amount of live data (currently a factor of 2,
 622      * should be configurable (ToDo)).  Use the blocks from the old
 623      * nursery if possible, freeing up any left over blocks.
 624      *
 625      * If we get near the maximum heap size, then adjust our nursery
 626      * size accordingly.  If the nursery is the same size as the live
 627      * data (L), then we need 3L bytes.  We can reduce the size of the
 628      * nursery to bring the required memory down near 2L bytes.
 629      *
 630      * A normal 2-space collector would need 4L bytes to give the same
 631      * performance we get from 3L bytes, reducing to the same
 632      * performance at 2L bytes.
 633      */
 634     blocks = g0s0->to_blocks;
 635
 636     if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
 637          RtsFlags.GcFlags.maxHeapSize ) {
 638       int adjusted_blocks;  /* signed on purpose */
 639       int pc_free;
 640
 641       adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
 642       IF_DEBUG(gc, fprintf(stderr, "@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %d\n", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
 643       pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
 644       if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
 645         heapOverflow();
 646       }
 647       blocks = adjusted_blocks;
 648
 649     } else {
 650       blocks *= RtsFlags.GcFlags.oldGenFactor;
 651       if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
 652         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 653       }
 654     }
 655     resizeNursery(blocks);
 656
 657   } else {
 658     /* Generational collector:
 659      * If the user has given us a suggested heap size, adjust our
 660      * allocation area to make best use of the memory available.
 661      */
 662
 663     if (RtsFlags.GcFlags.heapSizeSuggestion) {
 664       int blocks;
 665       nat needed = calcNeeded();        /* approx blocks needed at next GC */
 666
 667       /* Guess how much will be live in generation 0 step 0 next time.
 668        * A good approximation is the obtained by finding the
 669        * percentage of g0s0 that was live at the last minor GC.
 670        */
 671       if (N == 0) {
 672         g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
 673       }
 674
 675       /* Estimate a size for the allocation area based on the
 676        * information available.  We might end up going slightly under
 677        * or over the suggested heap size, but we should be pretty
 678        * close on average.
 679        *
 680        * Formula:            suggested - needed
 681        *                ----------------------------
 682        *                    1 + g0s0_pcnt_kept/100
 683        *
 684        * where 'needed' is the amount of memory needed at the next
 685        * collection for collecting all steps except g0s0.
 686        */
 687       blocks =
 688         (((int)RtsFlags.GcFlags.heapSizeSuggestion - (int)needed) * 100) /
 689         (100 + (int)g0s0_pcnt_kept);
 690
 691       if (blocks < (int)RtsFlags.GcFlags.minAllocAreaSize) {
 692         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 693       }
 694
 695       resizeNursery((nat)blocks);
 696     }
 697   }
 698
 699  /* mark the garbage collected CAFs as dead */
 700 #ifdef DEBUG
 701   if (major_gc) { gcCAFs(); }
 702 #endif
 703
 704   /* zero the scavenged static object list */
 705   if (major_gc) {
 706     zero_static_object_list(scavenged_static_objects);
 707   }
 708
 709   /* Reset the nursery
 710    */
 711   resetNurseries();
 712
 713 #if defined(PAR)
 714   /* Reconstruct the Global Address tables used in GUM */
 715   RebuildGAtables(major_gc);
 716 #endif
 717
 718   /* start any pending finalizers */
 719   scheduleFinalizers(old_weak_ptr_list);
 720
 721   /* check sanity after GC */
 722   IF_DEBUG(sanity, checkSanity(N));
 723
 724   /* extra GC trace info */
 725   IF_DEBUG(gc, stat_describe_gens());
 726
 727 #ifdef DEBUG
 728   /* symbol-table based profiling */
 729   /*  heapCensus(to_space); */ /* ToDo */
 730 #endif
 731
 732   /* restore enclosing cost centre */
 733 #ifdef PROFILING
 734   heapCensus();
 735   CCCS = prev_CCS;
 736 #endif
 737
 738   /* check for memory leaks if sanity checking is on */
 739   IF_DEBUG(sanity, memInventory());
 740
 741   /* ok, GC over: tell the stats department what happened. */
 742   stat_endGC(allocated, collected, live, copied, N);
 743 }
 744
 745 //@node Weak Pointers, Evacuation, Garbage Collect
 746 //@subsection Weak Pointers
 747
 748 /* -----------------------------------------------------------------------------
 749    Weak Pointers
 750
 751    traverse_weak_ptr_list is called possibly many times during garbage
 752    collection.  It returns a flag indicating whether it did any work
 753    (i.e. called evacuate on any live pointers).
 754
 755    Invariant: traverse_weak_ptr_list is called when the heap is in an
 756    idempotent state.  That means that there are no pending
 757    evacuate/scavenge operations.  This invariant helps the weak
 758    pointer code decide which weak pointers are dead - if there are no
 759    new live weak pointers, then all the currently unreachable ones are
 760    dead.
 761
 762    For generational GC: we just don't try to finalize weak pointers in
 763    older generations than the one we're collecting.  This could
 764    probably be optimised by keeping per-generation lists of weak
 765    pointers, but for a few weak pointers this scheme will work.
 766    -------------------------------------------------------------------------- */
 767 //@cindex traverse_weak_ptr_list
 768
 769 static rtsBool
 770 traverse_weak_ptr_list(void)
 771 {
 772   StgWeak *w, **last_w, *next_w;
 773   StgClosure *new;
 774   rtsBool flag = rtsFalse;
 775
 776   if (weak_done) { return rtsFalse; }
 777
 778   /* doesn't matter where we evacuate values/finalizers to, since
 779    * these pointers are treated as roots (iff the keys are alive).
 780    */
 781   evac_gen = 0;
 782
 783   last_w = &old_weak_ptr_list;
 784   for (w = old_weak_ptr_list; w; w = next_w) {
 785
 786     /* First, this weak pointer might have been evacuated.  If so,
 787      * remove the forwarding pointer from the weak_ptr_list.
 788      */
 789     if (get_itbl(w)->type == EVACUATED) {
 790       w = (StgWeak *)((StgEvacuated *)w)->evacuee;
 791       *last_w = w;
 792     }
 793
 794     /* There might be a DEAD_WEAK on the list if finalizeWeak# was
 795      * called on a live weak pointer object.  Just remove it.
 796      */
 797     if (w->header.info == &DEAD_WEAK_info) {
 798       next_w = ((StgDeadWeak *)w)->link;
 799       *last_w = next_w;
 800       continue;
 801     }
 802
 803     ASSERT(get_itbl(w)->type == WEAK);
 804
 805     /* Now, check whether the key is reachable.
 806      */
 807     if ((new = isAlive(w->key))) {
 808       w->key = new;
 809       /* evacuate the value and finalizer */
 810       w->value = evacuate(w->value);
 811       w->finalizer = evacuate(w->finalizer);
 812       /* remove this weak ptr from the old_weak_ptr list */
 813       *last_w = w->link;
 814       /* and put it on the new weak ptr list */
 815       next_w  = w->link;
 816       w->link = weak_ptr_list;
 817       weak_ptr_list = w;
 818       flag = rtsTrue;
 819       IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
 820       continue;
 821     }
 822     else {
 823       last_w = &(w->link);
 824       next_w = w->link;
 825       continue;
 826     }
 827   }
 828
 829   /* If we didn't make any changes, then we can go round and kill all
 830    * the dead weak pointers.  The old_weak_ptr list is used as a list
 831    * of pending finalizers later on.
 832    */
 833   if (flag == rtsFalse) {
 834     cleanup_weak_ptr_list(&old_weak_ptr_list);
 835     for (w = old_weak_ptr_list; w; w = w->link) {
 836       w->finalizer = evacuate(w->finalizer);
 837     }
 838     weak_done = rtsTrue;
 839   }
 840
 841   return rtsTrue;
 842 }
 843
 844 /* -----------------------------------------------------------------------------
 845    After GC, the live weak pointer list may have forwarding pointers
 846    on it, because a weak pointer object was evacuated after being
 847    moved to the live weak pointer list.  We remove those forwarding
 848    pointers here.
 849
 850    Also, we don't consider weak pointer objects to be reachable, but
 851    we must nevertheless consider them to be "live" and retain them.
 852    Therefore any weak pointer objects which haven't as yet been
 853    evacuated need to be evacuated now.
 854    -------------------------------------------------------------------------- */
 855
 856 //@cindex cleanup_weak_ptr_list
 857
 858 static void
 859 cleanup_weak_ptr_list ( StgWeak **list )
 860 {
 861   StgWeak *w, **last_w;
 862
 863   last_w = list;
 864   for (w = *list; w; w = w->link) {
 865
 866     if (get_itbl(w)->type == EVACUATED) {
 867       w = (StgWeak *)((StgEvacuated *)w)->evacuee;
 868       *last_w = w;
 869     }
 870
 871     if (Bdescr((P_)w)->evacuated == 0) {
 872       (StgClosure *)w = evacuate((StgClosure *)w);
 873       *last_w = w;
 874     }
 875     last_w = &(w->link);
 876   }
 877 }
 878
 879 /* -----------------------------------------------------------------------------
 880    isAlive determines whether the given closure is still alive (after
 881    a garbage collection) or not.  It returns the new address of the
 882    closure if it is alive, or NULL otherwise.
 883    -------------------------------------------------------------------------- */
 884
 885 //@cindex isAlive
 886
 887 StgClosure *
 888 isAlive(StgClosure *p)
 889 {
 890   const StgInfoTable *info;
 891
 892   while (1) {
 893
 894     info = get_itbl(p);
 895
 896     /* ToDo: for static closures, check the static link field.
 897      * Problem here is that we sometimes don't set the link field, eg.
 898      * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
 899      */
 900
 901 #if 1 || !defined(PAR)
 902     /* ignore closures in generations that we're not collecting. */
 903     /* In GUM we use this routine when rebuilding GA tables; for some
 904        reason it has problems with the LOOKS_LIKE_STATIC macro -- HWL */
 905     if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
 906       return p;
 907     }
 908 #endif
 909
 910     switch (info->type) {
 911
 912     case IND:
 913     case IND_STATIC:
 914     case IND_PERM:
 915     case IND_OLDGEN:            /* rely on compatible layout with StgInd */
 916     case IND_OLDGEN_PERM:
 917       /* follow indirections */
 918       p = ((StgInd *)p)->indirectee;
 919       continue;
 920
 921     case EVACUATED:
 922       /* alive! */
 923       return ((StgEvacuated *)p)->evacuee;
 924
 925     default:
 926       /* dead. */
 927       return NULL;
 928     }
 929   }
 930 }
 931
 932 //@cindex MarkRoot
 933 StgClosure *
 934 MarkRoot(StgClosure *root)
 935 {
 936   //if (root != END_TSO_QUEUE)
 937   return evacuate(root);
 938 }
 939
 940 //@cindex MarkRootHWL
 941 StgClosure *
 942 MarkRootHWL(StgClosure *root)
 943 {
 944   StgClosure *new = evacuate(root);
 945   upd_evacuee(root, new);
 946   return new;
 947 }
 948
 949 //@cindex addBlock
 950 static void addBlock(step *step)
 951 {
 952   bdescr *bd = allocBlock();
 953   bd->gen = step->gen;
 954   bd->step = step;
 955
 956   if (step->gen->no <= N) {
 957     bd->evacuated = 1;
 958   } else {
 959     bd->evacuated = 0;
 960   }
 961
 962   step->hp_bd->free = step->hp;
 963   step->hp_bd->link = bd;
 964   step->hp = bd->start;
 965   step->hpLim = step->hp + BLOCK_SIZE_W;
 966   step->hp_bd = bd;
 967   step->to_blocks++;
 968   new_blocks++;
 969 }
 970
 971 //@cindex upd_evacuee
 972
 973 static __inline__ void
 974 upd_evacuee(StgClosure *p, StgClosure *dest)
 975 {
 976   p->header.info = &EVACUATED_info;
 977   ((StgEvacuated *)p)->evacuee = dest;
 978 }
 979
 980 //@cindex copy
 981
 982 static __inline__ StgClosure *
 983 copy(StgClosure *src, nat size, step *step)
 984 {
 985   P_ to, from, dest;
 986
 987   TICK_GC_WORDS_COPIED(size);
 988   /* Find out where we're going, using the handy "to" pointer in
 989    * the step of the source object.  If it turns out we need to
 990    * evacuate to an older generation, adjust it here (see comment
 991    * by evacuate()).
 992    */
 993   if (step->gen->no < evac_gen) {
 994 #ifdef NO_EAGER_PROMOTION
 995     failed_to_evac = rtsTrue;
 996 #else
 997     step = &generations[evac_gen].steps[0];
 998 #endif
 999   }
1000
1001   /* chain a new block onto the to-space for the destination step if
1002    * necessary.
1003    */
1004   if (step->hp + size >= step->hpLim) {
1005     addBlock(step);
1006   }
1007
1008   for(to = step->hp, from = (P_)src; size>0; --size) {
1009     *to++ = *from++;
1010   }
1011
1012   dest = step->hp;
1013   step->hp = to;
1014   upd_evacuee(src,(StgClosure *)dest);
1015   return (StgClosure *)dest;
1016 }
1017
1018 /* Special version of copy() for when we only want to copy the info
1019  * pointer of an object, but reserve some padding after it.  This is
1020  * used to optimise evacuation of BLACKHOLEs.
1021  */
1022
1023 //@cindex copyPart
1024
1025 static __inline__ StgClosure *
1026 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
1027 {
1028   P_ dest, to, from;
1029
1030   TICK_GC_WORDS_COPIED(size_to_copy);
1031   if (step->gen->no < evac_gen) {
1032 #ifdef NO_EAGER_PROMOTION
1033     failed_to_evac = rtsTrue;
1034 #else
1035     step = &generations[evac_gen].steps[0];
1036 #endif
1037   }
1038
1039   if (step->hp + size_to_reserve >= step->hpLim) {
1040     addBlock(step);
1041   }
1042
1043   for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1044     *to++ = *from++;
1045   }
1046
1047   dest = step->hp;
1048   step->hp += size_to_reserve;
1049   upd_evacuee(src,(StgClosure *)dest);
1050   return (StgClosure *)dest;
1051 }
1052
1053 //@node Evacuation, Scavenging, Weak Pointers
1054 //@subsection Evacuation
1055
1056 /* -----------------------------------------------------------------------------
1057    Evacuate a large object
1058
1059    This just consists of removing the object from the (doubly-linked)
1060    large_alloc_list, and linking it on to the (singly-linked)
1061    new_large_objects list, from where it will be scavenged later.
1062
1063    Convention: bd->evacuated is /= 0 for a large object that has been
1064    evacuated, or 0 otherwise.
1065    -------------------------------------------------------------------------- */
1066
1067 //@cindex evacuate_large
1068
1069 static inline void
1070 evacuate_large(StgPtr p, rtsBool mutable)
1071 {
1072   bdescr *bd = Bdescr(p);
1073   step *step;
1074
1075   /* should point to the beginning of the block */
1076   ASSERT(((W_)p & BLOCK_MASK) == 0);
1077
1078   /* already evacuated? */
1079   if (bd->evacuated) {
1080     /* Don't forget to set the failed_to_evac flag if we didn't get
1081      * the desired destination (see comments in evacuate()).
1082      */
1083     if (bd->gen->no < evac_gen) {
1084       failed_to_evac = rtsTrue;
1085       TICK_GC_FAILED_PROMOTION();
1086     }
1087     return;
1088   }
1089
1090   step = bd->step;
1091   /* remove from large_object list */
1092   if (bd->back) {
1093     bd->back->link = bd->link;
1094   } else { /* first object in the list */
1095     step->large_objects = bd->link;
1096   }
1097   if (bd->link) {
1098     bd->link->back = bd->back;
1099   }
1100
1101   /* link it on to the evacuated large object list of the destination step
1102    */
1103   step = bd->step->to;
1104   if (step->gen->no < evac_gen) {
1105 #ifdef NO_EAGER_PROMOTION
1106     failed_to_evac = rtsTrue;
1107 #else
1108     step = &generations[evac_gen].steps[0];
1109 #endif
1110   }
1111
1112   bd->step = step;
1113   bd->gen = step->gen;
1114   bd->link = step->new_large_objects;
1115   step->new_large_objects = bd;
1116   bd->evacuated = 1;
1117
1118   if (mutable) {
1119     recordMutable((StgMutClosure *)p);
1120   }
1121 }
1122
1123 /* -----------------------------------------------------------------------------
1124    Adding a MUT_CONS to an older generation.
1125
1126    This is necessary from time to time when we end up with an
1127    old-to-new generation pointer in a non-mutable object.  We defer
1128    the promotion until the next GC.
1129    -------------------------------------------------------------------------- */
1130
1131 //@cindex mkMutCons
1132
1133 static StgClosure *
1134 mkMutCons(StgClosure *ptr, generation *gen)
1135 {
1136   StgMutVar *q;
1137   step *step;
1138
1139   step = &gen->steps[0];
1140
1141   /* chain a new block onto the to-space for the destination step if
1142    * necessary.
1143    */
1144   if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
1145     addBlock(step);
1146   }
1147
1148   q = (StgMutVar *)step->hp;
1149   step->hp += sizeofW(StgMutVar);
1150
1151   SET_HDR(q,&MUT_CONS_info,CCS_GC);
1152   q->var = ptr;
1153   recordOldToNewPtrs((StgMutClosure *)q);
1154
1155   return (StgClosure *)q;
1156 }
1157
1158 /* -----------------------------------------------------------------------------
1159    Evacuate
1160
1161    This is called (eventually) for every live object in the system.
1162
1163    The caller to evacuate specifies a desired generation in the
1164    evac_gen global variable.  The following conditions apply to
1165    evacuating an object which resides in generation M when we're
1166    collecting up to generation N
1167
1168    if  M >= evac_gen
1169            if  M > N     do nothing
1170            else          evac to step->to
1171
1172    if  M < evac_gen      evac to evac_gen, step 0
1173
1174    if the object is already evacuated, then we check which generation
1175    it now resides in.
1176
1177    if  M >= evac_gen     do nothing
1178    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1179                          didn't manage to evacuate this object into evac_gen.
1180
1181    -------------------------------------------------------------------------- */
1182 //@cindex evacuate
1183
1184 static StgClosure *
1185 evacuate(StgClosure *q)
1186 {
1187   StgClosure *to;
1188   bdescr *bd = NULL;
1189   step *step;
1190   const StgInfoTable *info;
1191
1192   nat size, ptrs, nonptrs, vhs;
1193   char str[80];
1194
1195 loop:
1196   if (HEAP_ALLOCED(q)) {
1197     bd = Bdescr((P_)q);
1198     if (bd->gen->no > N) {
1199       /* Can't evacuate this object, because it's in a generation
1200        * older than the ones we're collecting.  Let's hope that it's
1201        * in evac_gen or older, or we will have to make an IND_OLDGEN object.
1202        */
1203       if (bd->gen->no < evac_gen) {
1204         /* nope */
1205         failed_to_evac = rtsTrue;
1206         TICK_GC_FAILED_PROMOTION();
1207       }
1208       return q;
1209     }
1210     step = bd->step->to;
1211   }
1212 #ifdef DEBUG
1213   else step = NULL; /* make sure copy() will crash if HEAP_ALLOCED is wrong */
1214 #endif
1215
1216   /* make sure the info pointer is into text space */
1217   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1218                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1219   info = get_itbl(q);
1220   /*
1221   if (info->type==RBH) {
1222     info = REVERT_INFOPTR(info);
1223     IF_DEBUG(gc,
1224              belch("@_ Trying to evacuate an RBH %p (%s); reverting to IP %p (%s)",
1225                      q, info_type(q), info, info_type_by_ip(info)));
1226   }
1227   */
1228
1229   switch (info -> type) {
1230
1231   case BCO:
1232     {
1233       nat size = bco_sizeW((StgBCO*)q);
1234
1235       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1236         evacuate_large((P_)q, rtsFalse);
1237         to = q;
1238       } else {
1239         /* just copy the block */
1240         to = copy(q,size,step);
1241       }
1242       return to;
1243     }
1244
1245   case MUT_VAR:
1246     ASSERT(q->header.info != &MUT_CONS_info);
1247   case MVAR:
1248     to = copy(q,sizeW_fromITBL(info),step);
1249     recordMutable((StgMutClosure *)to);
1250     return to;
1251
1252   case FUN_1_0:
1253   case FUN_0_1:
1254   case CONSTR_1_0:
1255   case CONSTR_0_1:
1256     return copy(q,sizeofW(StgHeader)+1,step);
1257
1258   case THUNK_1_0:               /* here because of MIN_UPD_SIZE */
1259   case THUNK_0_1:
1260   case THUNK_1_1:
1261   case THUNK_0_2:
1262   case THUNK_2_0:
1263 #ifdef NO_PROMOTE_THUNKS
1264     if (bd->gen->no == 0 &&
1265         bd->step->no != 0 &&
1266         bd->step->no == bd->gen->n_steps-1) {
1267       step = bd->step;
1268     }
1269 #endif
1270     return copy(q,sizeofW(StgHeader)+2,step);
1271
1272   case FUN_1_1:
1273   case FUN_0_2:
1274   case FUN_2_0:
1275   case CONSTR_1_1:
1276   case CONSTR_0_2:
1277   case CONSTR_2_0:
1278     return copy(q,sizeofW(StgHeader)+2,step);
1279
1280   case FUN:
1281   case THUNK:
1282   case CONSTR:
1283   case IND_PERM:
1284   case IND_OLDGEN_PERM:
1285   case CAF_UNENTERED:
1286   case CAF_ENTERED:
1287   case WEAK:
1288   case FOREIGN:
1289   case STABLE_NAME:
1290     return copy(q,sizeW_fromITBL(info),step);
1291
1292   case CAF_BLACKHOLE:
1293   case SE_CAF_BLACKHOLE:
1294   case SE_BLACKHOLE:
1295   case BLACKHOLE:
1296     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1297
1298   case BLACKHOLE_BQ:
1299     to = copy(q,BLACKHOLE_sizeW(),step);
1300     recordMutable((StgMutClosure *)to);
1301     return to;
1302
1303   case THUNK_SELECTOR:
1304     {
1305       const StgInfoTable* selectee_info;
1306       StgClosure* selectee = ((StgSelector*)q)->selectee;
1307
1308     selector_loop:
1309       selectee_info = get_itbl(selectee);
1310       switch (selectee_info->type) {
1311       case CONSTR:
1312       case CONSTR_1_0:
1313       case CONSTR_0_1:
1314       case CONSTR_2_0:
1315       case CONSTR_1_1:
1316       case CONSTR_0_2:
1317       case CONSTR_STATIC:
1318         {
1319           StgWord32 offset = info->layout.selector_offset;
1320
1321           /* check that the size is in range */
1322           ASSERT(offset <
1323                  (StgWord32)(selectee_info->layout.payload.ptrs +
1324                             selectee_info->layout.payload.nptrs));
1325
1326           /* perform the selection! */
1327           q = selectee->payload[offset];
1328
1329           /* if we're already in to-space, there's no need to continue
1330            * with the evacuation, just update the source address with
1331            * a pointer to the (evacuated) constructor field.
1332            */
1333           if (HEAP_ALLOCED(q)) {
1334             bdescr *bd = Bdescr((P_)q);
1335             if (bd->evacuated) {
1336               if (bd->gen->no < evac_gen) {
1337                 failed_to_evac = rtsTrue;
1338                 TICK_GC_FAILED_PROMOTION();
1339               }
1340               return q;
1341             }
1342           }
1343
1344           /* otherwise, carry on and evacuate this constructor field,
1345            * (but not the constructor itself)
1346            */
1347           goto loop;
1348         }
1349
1350       case IND:
1351       case IND_STATIC:
1352       case IND_PERM:
1353       case IND_OLDGEN:
1354       case IND_OLDGEN_PERM:
1355         selectee = stgCast(StgInd *,selectee)->indirectee;
1356         goto selector_loop;
1357
1358       case CAF_ENTERED:
1359         selectee = stgCast(StgCAF *,selectee)->value;
1360         goto selector_loop;
1361
1362       case EVACUATED:
1363         selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1364         goto selector_loop;
1365
1366       case THUNK:
1367       case THUNK_1_0:
1368       case THUNK_0_1:
1369       case THUNK_2_0:
1370       case THUNK_1_1:
1371       case THUNK_0_2:
1372       case THUNK_STATIC:
1373       case THUNK_SELECTOR:
1374         /* aargh - do recursively???? */
1375       case CAF_UNENTERED:
1376       case CAF_BLACKHOLE:
1377       case SE_CAF_BLACKHOLE:
1378       case SE_BLACKHOLE:
1379       case BLACKHOLE:
1380       case BLACKHOLE_BQ:
1381         /* not evaluated yet */
1382         break;
1383
1384       default:
1385         barf("evacuate: THUNK_SELECTOR: strange selectee %d",
1386              (int)(selectee_info->type));
1387       }
1388     }
1389     return copy(q,THUNK_SELECTOR_sizeW(),step);
1390
1391   case IND:
1392   case IND_OLDGEN:
1393     /* follow chains of indirections, don't evacuate them */
1394     q = ((StgInd*)q)->indirectee;
1395     goto loop;
1396
1397   case THUNK_STATIC:
1398     if (info->srt_len > 0 && major_gc &&
1399         THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1400       THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1401       static_objects = (StgClosure *)q;
1402     }
1403     return q;
1404
1405   case FUN_STATIC:
1406     if (info->srt_len > 0 && major_gc &&
1407         FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1408       FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1409       static_objects = (StgClosure *)q;
1410     }
1411     return q;
1412
1413   case IND_STATIC:
1414     if (major_gc && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1415       IND_STATIC_LINK((StgClosure *)q) = static_objects;
1416       static_objects = (StgClosure *)q;
1417     }
1418     return q;
1419
1420   case CONSTR_STATIC:
1421     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1422       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1423       static_objects = (StgClosure *)q;
1424     }
1425     return q;
1426
1427   case CONSTR_INTLIKE:
1428   case CONSTR_CHARLIKE:
1429   case CONSTR_NOCAF_STATIC:
1430     /* no need to put these on the static linked list, they don't need
1431      * to be scavenged.
1432      */
1433     return q;
1434
1435   case RET_BCO:
1436   case RET_SMALL:
1437   case RET_VEC_SMALL:
1438   case RET_BIG:
1439   case RET_VEC_BIG:
1440   case RET_DYN:
1441   case UPDATE_FRAME:
1442   case STOP_FRAME:
1443   case CATCH_FRAME:
1444   case SEQ_FRAME:
1445     /* shouldn't see these */
1446     barf("evacuate: stack frame at %p\n", q);
1447
1448   case AP_UPD:
1449   case PAP:
1450     /* these are special - the payload is a copy of a chunk of stack,
1451        tagging and all. */
1452     return copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1453
1454   case EVACUATED:
1455     /* Already evacuated, just return the forwarding address.
1456      * HOWEVER: if the requested destination generation (evac_gen) is
1457      * older than the actual generation (because the object was
1458      * already evacuated to a younger generation) then we have to
1459      * set the failed_to_evac flag to indicate that we couldn't
1460      * manage to promote the object to the desired generation.
1461      */
1462     if (evac_gen > 0) {         /* optimisation */
1463       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1464       if (Bdescr((P_)p)->gen->no < evac_gen) {
1465         IF_DEBUG(gc, belch("@@ evacuate: evac of EVACUATED node %p failed!", p));
1466         failed_to_evac = rtsTrue;
1467         TICK_GC_FAILED_PROMOTION();
1468       }
1469     }
1470     return ((StgEvacuated*)q)->evacuee;
1471
1472   case ARR_WORDS:
1473     {
1474       nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1475
1476       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1477         evacuate_large((P_)q, rtsFalse);
1478         return q;
1479       } else {
1480         /* just copy the block */
1481         return copy(q,size,step);
1482       }
1483     }
1484
1485   case MUT_ARR_PTRS:
1486   case MUT_ARR_PTRS_FROZEN:
1487     {
1488       nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1489
1490       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1491         evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1492         to = q;
1493       } else {
1494         /* just copy the block */
1495         to = copy(q,size,step);
1496         if (info->type == MUT_ARR_PTRS) {
1497           recordMutable((StgMutClosure *)to);
1498         }
1499       }
1500       return to;
1501     }
1502
1503   case TSO:
1504     {
1505       StgTSO *tso = stgCast(StgTSO *,q);
1506       nat size = tso_sizeW(tso);
1507       int diff;
1508
1509       /* Large TSOs don't get moved, so no relocation is required.
1510        */
1511       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1512         evacuate_large((P_)q, rtsTrue);
1513         return q;
1514
1515       /* To evacuate a small TSO, we need to relocate the update frame
1516        * list it contains.
1517        */
1518       } else {
1519         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1520
1521         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1522
1523         /* relocate the stack pointers... */
1524         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1525         new_tso->sp = (StgPtr)new_tso->sp + diff;
1526         new_tso->splim = (StgPtr)new_tso->splim + diff;
1527
1528         relocate_TSO(tso, new_tso);
1529
1530         recordMutable((StgMutClosure *)new_tso);
1531         return (StgClosure *)new_tso;
1532       }
1533     }
1534
1535 #if defined(PAR)
1536   case RBH: // cf. BLACKHOLE_BQ
1537     {
1538       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1539       to = copy(q,BLACKHOLE_sizeW(),step);
1540       //ToDo: derive size etc from reverted IP
1541       //to = copy(q,size,step);
1542       recordMutable((StgMutClosure *)to);
1543       IF_DEBUG(gc,
1544                belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1545                      q, info_type(q), to, info_type(to)));
1546       return to;
1547     }
1548
1549   case BLOCKED_FETCH:
1550     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1551     to = copy(q,sizeofW(StgBlockedFetch),step);
1552     IF_DEBUG(gc,
1553              belch("@@ evacuate: %p (%s) to %p (%s)",
1554                    q, info_type(q), to, info_type(to)));
1555     return to;
1556
1557   case FETCH_ME:
1558     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1559     to = copy(q,sizeofW(StgFetchMe),step);
1560     IF_DEBUG(gc,
1561              belch("@@ evacuate: %p (%s) to %p (%s)",
1562                    q, info_type(q), to, info_type(to)));
1563     return to;
1564
1565   case FETCH_ME_BQ:
1566     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1567     to = copy(q,sizeofW(StgFetchMeBlockingQueue),step);
1568     IF_DEBUG(gc,
1569              belch("@@ evacuate: %p (%s) to %p (%s)",
1570                    q, info_type(q), to, info_type(to)));
1571     return to;
1572 #endif
1573
1574   default:
1575     barf("evacuate: strange closure type %d", (int)(info->type));
1576   }
1577
1578   barf("evacuate");
1579 }
1580
1581 /* -----------------------------------------------------------------------------
1582    relocate_TSO is called just after a TSO has been copied from src to
1583    dest.  It adjusts the update frame list for the new location.
1584    -------------------------------------------------------------------------- */
1585 //@cindex relocate_TSO
1586
1587 StgTSO *
1588 relocate_TSO(StgTSO *src, StgTSO *dest)
1589 {
1590   StgUpdateFrame *su;
1591   StgCatchFrame  *cf;
1592   StgSeqFrame    *sf;
1593   int diff;
1594
1595   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1596
1597   su = dest->su;
1598
1599   while ((P_)su < dest->stack + dest->stack_size) {
1600     switch (get_itbl(su)->type) {
1601
1602       /* GCC actually manages to common up these three cases! */
1603
1604     case UPDATE_FRAME:
1605       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1606       su = su->link;
1607       continue;
1608
1609     case CATCH_FRAME:
1610       cf = (StgCatchFrame *)su;
1611       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1612       su = cf->link;
1613       continue;
1614
1615     case SEQ_FRAME:
1616       sf = (StgSeqFrame *)su;
1617       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1618       su = sf->link;
1619       continue;
1620
1621     case STOP_FRAME:
1622       /* all done! */
1623       break;
1624
1625     default:
1626       barf("relocate_TSO %d", (int)(get_itbl(su)->type));
1627     }
1628     break;
1629   }
1630
1631   return dest;
1632 }
1633
1634 //@node Scavenging, Reverting CAFs, Evacuation
1635 //@subsection Scavenging
1636
1637 //@cindex scavenge_srt
1638
1639 static inline void
1640 scavenge_srt(const StgInfoTable *info)
1641 {
1642   StgClosure **srt, **srt_end;
1643
1644   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1645    * srt field in the info table.  That's ok, because we'll
1646    * never dereference it.
1647    */
1648   srt = stgCast(StgClosure **,info->srt);
1649   srt_end = srt + info->srt_len;
1650   for (; srt < srt_end; srt++) {
1651     /* Special-case to handle references to closures hiding out in DLLs, since
1652        double indirections required to get at those. The code generator knows
1653        which is which when generating the SRT, so it stores the (indirect)
1654        reference to the DLL closure in the table by first adding one to it.
1655        We check for this here, and undo the addition before evacuating it.
1656
1657        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1658        closure that's fixed at link-time, and no extra magic is required.
1659     */
1660 #ifdef ENABLE_WIN32_DLL_SUPPORT
1661     if ( stgCast(unsigned long,*srt) & 0x1 ) {
1662        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
1663     } else {
1664        evacuate(*srt);
1665     }
1666 #else
1667        evacuate(*srt);
1668 #endif
1669   }
1670 }
1671
1672 /* -----------------------------------------------------------------------------
1673    Scavenge a TSO.
1674    -------------------------------------------------------------------------- */
1675
1676 static void
1677 scavengeTSO (StgTSO *tso)
1678 {
1679   /* chase the link field for any TSOs on the same queue */
1680   (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1681   if (   tso->why_blocked == BlockedOnMVar
1682          || tso->why_blocked == BlockedOnBlackHole
1683          || tso->why_blocked == BlockedOnException) {
1684     tso->block_info.closure = evacuate(tso->block_info.closure);
1685   }
1686   if ( tso->blocked_exceptions != NULL ) {
1687     tso->blocked_exceptions =
1688       (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
1689   }
1690   /* scavenge this thread's stack */
1691   scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1692 }
1693
1694 /* -----------------------------------------------------------------------------
1695    Scavenge a given step until there are no more objects in this step
1696    to scavenge.
1697
1698    evac_gen is set by the caller to be either zero (for a step in a
1699    generation < N) or G where G is the generation of the step being
1700    scavenged.
1701
1702    We sometimes temporarily change evac_gen back to zero if we're
1703    scavenging a mutable object where early promotion isn't such a good
1704    idea.
1705    -------------------------------------------------------------------------- */
1706 //@cindex scavenge
1707
1708 static void
1709 scavenge(step *step)
1710 {
1711   StgPtr p, q;
1712   const StgInfoTable *info;
1713   bdescr *bd;
1714   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1715
1716   p = step->scan;
1717   bd = step->scan_bd;
1718
1719   failed_to_evac = rtsFalse;
1720
1721   /* scavenge phase - standard breadth-first scavenging of the
1722    * evacuated objects
1723    */
1724
1725   while (bd != step->hp_bd || p < step->hp) {
1726
1727     /* If we're at the end of this block, move on to the next block */
1728     if (bd != step->hp_bd && p == bd->free) {
1729       bd = bd->link;
1730       p = bd->start;
1731       continue;
1732     }
1733
1734     q = p;                      /* save ptr to object */
1735
1736     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1737                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1738
1739     info = get_itbl((StgClosure *)p);
1740     /*
1741     if (info->type==RBH)
1742       info = REVERT_INFOPTR(info);
1743     */
1744
1745     switch (info -> type) {
1746
1747     case BCO:
1748       {
1749         StgBCO* bco = stgCast(StgBCO*,p);
1750         nat i;
1751         for (i = 0; i < bco->n_ptrs; i++) {
1752           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1753         }
1754         p += bco_sizeW(bco);
1755         break;
1756       }
1757
1758     case MVAR:
1759       /* treat MVars specially, because we don't want to evacuate the
1760        * mut_link field in the middle of the closure.
1761        */
1762       {
1763         StgMVar *mvar = ((StgMVar *)p);
1764         evac_gen = 0;
1765         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1766         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1767         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1768         p += sizeofW(StgMVar);
1769         evac_gen = saved_evac_gen;
1770         break;
1771       }
1772
1773     case THUNK_2_0:
1774     case FUN_2_0:
1775       scavenge_srt(info);
1776     case CONSTR_2_0:
1777       ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1778       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1779       p += sizeofW(StgHeader) + 2;
1780       break;
1781
1782     case THUNK_1_0:
1783       scavenge_srt(info);
1784       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1785       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1786       break;
1787
1788     case FUN_1_0:
1789       scavenge_srt(info);
1790     case CONSTR_1_0:
1791       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1792       p += sizeofW(StgHeader) + 1;
1793       break;
1794
1795     case THUNK_0_1:
1796       scavenge_srt(info);
1797       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1798       break;
1799
1800     case FUN_0_1:
1801       scavenge_srt(info);
1802     case CONSTR_0_1:
1803       p += sizeofW(StgHeader) + 1;
1804       break;
1805
1806     case THUNK_0_2:
1807     case FUN_0_2:
1808       scavenge_srt(info);
1809     case CONSTR_0_2:
1810       p += sizeofW(StgHeader) + 2;
1811       break;
1812
1813     case THUNK_1_1:
1814     case FUN_1_1:
1815       scavenge_srt(info);
1816     case CONSTR_1_1:
1817       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1818       p += sizeofW(StgHeader) + 2;
1819       break;
1820
1821     case FUN:
1822     case THUNK:
1823       scavenge_srt(info);
1824       /* fall through */
1825
1826     case CONSTR:
1827     case WEAK:
1828     case FOREIGN:
1829     case STABLE_NAME:
1830       {
1831         StgPtr end;
1832
1833         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1834         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1835           (StgClosure *)*p = evacuate((StgClosure *)*p);
1836         }
1837         p += info->layout.payload.nptrs;
1838         break;
1839       }
1840
1841     case IND_PERM:
1842       if (step->gen->no != 0) {
1843         SET_INFO(((StgClosure *)p), &IND_OLDGEN_PERM_info);
1844       }
1845       /* fall through */
1846     case IND_OLDGEN_PERM:
1847       ((StgIndOldGen *)p)->indirectee =
1848         evacuate(((StgIndOldGen *)p)->indirectee);
1849       if (failed_to_evac) {
1850         failed_to_evac = rtsFalse;
1851         recordOldToNewPtrs((StgMutClosure *)p);
1852       }
1853       p += sizeofW(StgIndOldGen);
1854       break;
1855
1856     case CAF_UNENTERED:
1857       {
1858         StgCAF *caf = (StgCAF *)p;
1859
1860         caf->body = evacuate(caf->body);
1861         if (failed_to_evac) {
1862           failed_to_evac = rtsFalse;
1863           recordOldToNewPtrs((StgMutClosure *)p);
1864         } else {
1865           caf->mut_link = NULL;
1866         }
1867         p += sizeofW(StgCAF);
1868         break;
1869       }
1870
1871     case CAF_ENTERED:
1872       {
1873         StgCAF *caf = (StgCAF *)p;
1874
1875         caf->body = evacuate(caf->body);
1876         caf->value = evacuate(caf->value);
1877         if (failed_to_evac) {
1878           failed_to_evac = rtsFalse;
1879           recordOldToNewPtrs((StgMutClosure *)p);
1880         } else {
1881           caf->mut_link = NULL;
1882         }
1883         p += sizeofW(StgCAF);
1884         break;
1885       }
1886
1887     case MUT_VAR:
1888       /* ignore MUT_CONSs */
1889       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1890         evac_gen = 0;
1891         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1892         evac_gen = saved_evac_gen;
1893       }
1894       p += sizeofW(StgMutVar);
1895       break;
1896
1897     case CAF_BLACKHOLE:
1898     case SE_CAF_BLACKHOLE:
1899     case SE_BLACKHOLE:
1900     case BLACKHOLE:
1901         p += BLACKHOLE_sizeW();
1902         break;
1903
1904     case BLACKHOLE_BQ:
1905       {
1906         StgBlockingQueue *bh = (StgBlockingQueue *)p;
1907         (StgClosure *)bh->blocking_queue =
1908           evacuate((StgClosure *)bh->blocking_queue);
1909         if (failed_to_evac) {
1910           failed_to_evac = rtsFalse;
1911           recordMutable((StgMutClosure *)bh);
1912         }
1913         p += BLACKHOLE_sizeW();
1914         break;
1915       }
1916
1917     case THUNK_SELECTOR:
1918       {
1919         StgSelector *s = (StgSelector *)p;
1920         s->selectee = evacuate(s->selectee);
1921         p += THUNK_SELECTOR_sizeW();
1922         break;
1923       }
1924
1925     case IND:
1926     case IND_OLDGEN:
1927       barf("scavenge:IND???\n");
1928
1929     case CONSTR_INTLIKE:
1930     case CONSTR_CHARLIKE:
1931     case CONSTR_STATIC:
1932     case CONSTR_NOCAF_STATIC:
1933     case THUNK_STATIC:
1934     case FUN_STATIC:
1935     case IND_STATIC:
1936       /* Shouldn't see a static object here. */
1937       barf("scavenge: STATIC object\n");
1938
1939     case RET_BCO:
1940     case RET_SMALL:
1941     case RET_VEC_SMALL:
1942     case RET_BIG:
1943     case RET_VEC_BIG:
1944     case RET_DYN:
1945     case UPDATE_FRAME:
1946     case STOP_FRAME:
1947     case CATCH_FRAME:
1948     case SEQ_FRAME:
1949       /* Shouldn't see stack frames here. */
1950       barf("scavenge: stack frame\n");
1951
1952     case AP_UPD: /* same as PAPs */
1953     case PAP:
1954       /* Treat a PAP just like a section of stack, not forgetting to
1955        * evacuate the function pointer too...
1956        */
1957       {
1958         StgPAP* pap = stgCast(StgPAP*,p);
1959
1960         pap->fun = evacuate(pap->fun);
1961         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1962         p += pap_sizeW(pap);
1963         break;
1964       }
1965
1966     case ARR_WORDS:
1967       /* nothing to follow */
1968       p += arr_words_sizeW(stgCast(StgArrWords*,p));
1969       break;
1970
1971     case MUT_ARR_PTRS:
1972       /* follow everything */
1973       {
1974         StgPtr next;
1975
1976         evac_gen = 0;           /* repeatedly mutable */
1977         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1978         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1979           (StgClosure *)*p = evacuate((StgClosure *)*p);
1980         }
1981         evac_gen = saved_evac_gen;
1982         break;
1983       }
1984
1985     case MUT_ARR_PTRS_FROZEN:
1986       /* follow everything */
1987       {
1988         StgPtr start = p, next;
1989
1990         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1991         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1992           (StgClosure *)*p = evacuate((StgClosure *)*p);
1993         }
1994         if (failed_to_evac) {
1995           /* we can do this easier... */
1996           recordMutable((StgMutClosure *)start);
1997           failed_to_evac = rtsFalse;
1998         }
1999         break;
2000       }
2001
2002     case TSO:
2003       {
2004         StgTSO *tso = (StgTSO *)p;
2005         evac_gen = 0;
2006         scavengeTSO(tso);
2007         evac_gen = saved_evac_gen;
2008         p += tso_sizeW(tso);
2009         break;
2010       }
2011
2012 #if defined(PAR)
2013     case RBH: // cf. BLACKHOLE_BQ
2014       {
2015         // nat size, ptrs, nonptrs, vhs;
2016         // char str[80];
2017         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2018         StgRBH *rbh = (StgRBH *)p;
2019         (StgClosure *)rbh->blocking_queue =
2020           evacuate((StgClosure *)rbh->blocking_queue);
2021         if (failed_to_evac) {
2022           failed_to_evac = rtsFalse;
2023           recordMutable((StgMutClosure *)rbh);
2024         }
2025         IF_DEBUG(gc,
2026                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2027                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2028         // ToDo: use size of reverted closure here!
2029         p += BLACKHOLE_sizeW();
2030         break;
2031       }
2032
2033     case BLOCKED_FETCH:
2034       {
2035         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2036         /* follow the pointer to the node which is being demanded */
2037         (StgClosure *)bf->node =
2038           evacuate((StgClosure *)bf->node);
2039         /* follow the link to the rest of the blocking queue */
2040         (StgClosure *)bf->link =
2041           evacuate((StgClosure *)bf->link);
2042         if (failed_to_evac) {
2043           failed_to_evac = rtsFalse;
2044           recordMutable((StgMutClosure *)bf);
2045         }
2046         IF_DEBUG(gc,
2047                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2048                      bf, info_type((StgClosure *)bf),
2049                      bf->node, info_type(bf->node)));
2050         p += sizeofW(StgBlockedFetch);
2051         break;
2052       }
2053
2054     case FETCH_ME:
2055       IF_DEBUG(gc,
2056                belch("@@ scavenge: HWL claims nothing to do for %p (%s)",
2057                      p, info_type((StgClosure *)p)));
2058       p += sizeofW(StgFetchMe);
2059       break; // nothing to do in this case
2060
2061     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2062       {
2063         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2064         (StgClosure *)fmbq->blocking_queue =
2065           evacuate((StgClosure *)fmbq->blocking_queue);
2066         if (failed_to_evac) {
2067           failed_to_evac = rtsFalse;
2068           recordMutable((StgMutClosure *)fmbq);
2069         }
2070         IF_DEBUG(gc,
2071                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2072                      p, info_type((StgClosure *)p)));
2073         p += sizeofW(StgFetchMeBlockingQueue);
2074         break;
2075       }
2076 #endif
2077
2078     case EVACUATED:
2079       barf("scavenge: unimplemented/strange closure type\n");
2080
2081     default:
2082       barf("scavenge");
2083     }
2084
2085     /* If we didn't manage to promote all the objects pointed to by
2086      * the current object, then we have to designate this object as
2087      * mutable (because it contains old-to-new generation pointers).
2088      */
2089     if (failed_to_evac) {
2090       mkMutCons((StgClosure *)q, &generations[evac_gen]);
2091       failed_to_evac = rtsFalse;
2092     }
2093   }
2094
2095   step->scan_bd = bd;
2096   step->scan = p;
2097 }
2098
2099 /* -----------------------------------------------------------------------------
2100    Scavenge one object.
2101
2102    This is used for objects that are temporarily marked as mutable
2103    because they contain old-to-new generation pointers.  Only certain
2104    objects can have this property.
2105    -------------------------------------------------------------------------- */
2106 //@cindex scavenge_one
2107
2108 static rtsBool
2109 scavenge_one(StgClosure *p)
2110 {
2111   const StgInfoTable *info;
2112   rtsBool no_luck;
2113
2114   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2115                || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2116
2117   info = get_itbl(p);
2118
2119   /* ngoq moHqu'!
2120   if (info->type==RBH)
2121     info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2122   */
2123
2124   switch (info -> type) {
2125
2126   case FUN:
2127   case FUN_1_0:                 /* hardly worth specialising these guys */
2128   case FUN_0_1:
2129   case FUN_1_1:
2130   case FUN_0_2:
2131   case FUN_2_0:
2132   case THUNK:
2133   case THUNK_1_0:
2134   case THUNK_0_1:
2135   case THUNK_1_1:
2136   case THUNK_0_2:
2137   case THUNK_2_0:
2138   case CONSTR:
2139   case CONSTR_1_0:
2140   case CONSTR_0_1:
2141   case CONSTR_1_1:
2142   case CONSTR_0_2:
2143   case CONSTR_2_0:
2144   case WEAK:
2145   case FOREIGN:
2146   case IND_PERM:
2147   case IND_OLDGEN_PERM:
2148   case CAF_UNENTERED:
2149     {
2150       StgPtr q, end;
2151
2152       end = (P_)p->payload + info->layout.payload.ptrs;
2153       for (q = (P_)p->payload; q < end; q++) {
2154         (StgClosure *)*q = evacuate((StgClosure *)*q);
2155       }
2156       break;
2157     }
2158
2159   case CAF_BLACKHOLE:
2160   case SE_CAF_BLACKHOLE:
2161   case SE_BLACKHOLE:
2162   case BLACKHOLE:
2163       break;
2164
2165   case THUNK_SELECTOR:
2166     {
2167       StgSelector *s = (StgSelector *)p;
2168       s->selectee = evacuate(s->selectee);
2169       break;
2170     }
2171
2172   case AP_UPD: /* same as PAPs */
2173   case PAP:
2174     /* Treat a PAP just like a section of stack, not forgetting to
2175      * evacuate the function pointer too...
2176      */
2177     {
2178       StgPAP* pap = (StgPAP *)p;
2179
2180       pap->fun = evacuate(pap->fun);
2181       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2182       break;
2183     }
2184
2185   case IND_OLDGEN:
2186     /* This might happen if for instance a MUT_CONS was pointing to a
2187      * THUNK which has since been updated.  The IND_OLDGEN will
2188      * be on the mutable list anyway, so we don't need to do anything
2189      * here.
2190      */
2191     break;
2192
2193   default:
2194     barf("scavenge_one: strange object");
2195   }
2196
2197   no_luck = failed_to_evac;
2198   failed_to_evac = rtsFalse;
2199   return (no_luck);
2200 }
2201
2202
2203 /* -----------------------------------------------------------------------------
2204    Scavenging mutable lists.
2205
2206    We treat the mutable list of each generation > N (i.e. all the
2207    generations older than the one being collected) as roots.  We also
2208    remove non-mutable objects from the mutable list at this point.
2209    -------------------------------------------------------------------------- */
2210 //@cindex scavenge_mut_once_list
2211
2212 static void
2213 scavenge_mut_once_list(generation *gen)
2214 {
2215   const StgInfoTable *info;
2216   StgMutClosure *p, *next, *new_list;
2217
2218   p = gen->mut_once_list;
2219   new_list = END_MUT_LIST;
2220   next = p->mut_link;
2221
2222   evac_gen = gen->no;
2223   failed_to_evac = rtsFalse;
2224
2225   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2226
2227     /* make sure the info pointer is into text space */
2228     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2229                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2230
2231     info = get_itbl(p);
2232     /*
2233     if (info->type==RBH)
2234       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2235     */
2236     switch(info->type) {
2237
2238     case IND_OLDGEN:
2239     case IND_OLDGEN_PERM:
2240     case IND_STATIC:
2241       /* Try to pull the indirectee into this generation, so we can
2242        * remove the indirection from the mutable list.
2243        */
2244       ((StgIndOldGen *)p)->indirectee =
2245         evacuate(((StgIndOldGen *)p)->indirectee);
2246
2247 #ifdef DEBUG
2248       if (RtsFlags.DebugFlags.gc)
2249       /* Debugging code to print out the size of the thing we just
2250        * promoted
2251        */
2252       {
2253         StgPtr start = gen->steps[0].scan;
2254         bdescr *start_bd = gen->steps[0].scan_bd;
2255         nat size = 0;
2256         scavenge(&gen->steps[0]);
2257         if (start_bd != gen->steps[0].scan_bd) {
2258           size += (P_)BLOCK_ROUND_UP(start) - start;
2259           start_bd = start_bd->link;
2260           while (start_bd != gen->steps[0].scan_bd) {
2261             size += BLOCK_SIZE_W;
2262             start_bd = start_bd->link;
2263           }
2264           size += gen->steps[0].scan -
2265             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
2266         } else {
2267           size = gen->steps[0].scan - start;
2268         }
2269         fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
2270       }
2271 #endif
2272
2273       /* failed_to_evac might happen if we've got more than two
2274        * generations, we're collecting only generation 0, the
2275        * indirection resides in generation 2 and the indirectee is
2276        * in generation 1.
2277        */
2278       if (failed_to_evac) {
2279         failed_to_evac = rtsFalse;
2280         p->mut_link = new_list;
2281         new_list = p;
2282       } else {
2283         /* the mut_link field of an IND_STATIC is overloaded as the
2284          * static link field too (it just so happens that we don't need
2285          * both at the same time), so we need to NULL it out when
2286          * removing this object from the mutable list because the static
2287          * link fields are all assumed to be NULL before doing a major
2288          * collection.
2289          */
2290         p->mut_link = NULL;
2291       }
2292       continue;
2293
2294     case MUT_VAR:
2295       /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
2296        * it from the mutable list if possible by promoting whatever it
2297        * points to.
2298        */
2299       ASSERT(p->header.info == &MUT_CONS_info);
2300       if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
2301         /* didn't manage to promote everything, so put the
2302          * MUT_CONS back on the list.
2303          */
2304         p->mut_link = new_list;
2305         new_list = p;
2306       }
2307       continue;
2308
2309     case CAF_ENTERED:
2310       {
2311         StgCAF *caf = (StgCAF *)p;
2312         caf->body  = evacuate(caf->body);
2313         caf->value = evacuate(caf->value);
2314         if (failed_to_evac) {
2315           failed_to_evac = rtsFalse;
2316           p->mut_link = new_list;
2317           new_list = p;
2318         } else {
2319           p->mut_link = NULL;
2320         }
2321       }
2322       continue;
2323
2324     case CAF_UNENTERED:
2325       {
2326         StgCAF *caf = (StgCAF *)p;
2327         caf->body  = evacuate(caf->body);
2328         if (failed_to_evac) {
2329           failed_to_evac = rtsFalse;
2330           p->mut_link = new_list;
2331           new_list = p;
2332         } else {
2333           p->mut_link = NULL;
2334         }
2335       }
2336       continue;
2337
2338     default:
2339       /* shouldn't have anything else on the mutables list */
2340       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
2341     }
2342   }
2343
2344   gen->mut_once_list = new_list;
2345 }
2346
2347 //@cindex scavenge_mutable_list
2348
2349 static void
2350 scavenge_mutable_list(generation *gen)
2351 {
2352   const StgInfoTable *info;
2353   StgMutClosure *p, *next;
2354
2355   p = gen->saved_mut_list;
2356   next = p->mut_link;
2357
2358   evac_gen = 0;
2359   failed_to_evac = rtsFalse;
2360
2361   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2362
2363     /* make sure the info pointer is into text space */
2364     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2365                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2366
2367     info = get_itbl(p);
2368     /*
2369     if (info->type==RBH)
2370       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2371     */
2372     switch(info->type) {
2373
2374     case MUT_ARR_PTRS_FROZEN:
2375       /* remove this guy from the mutable list, but follow the ptrs
2376        * anyway (and make sure they get promoted to this gen).
2377        */
2378       {
2379         StgPtr end, q;
2380
2381         IF_DEBUG(gc,
2382                  belch("@@ scavenge_mut_list: scavenging MUT_ARR_PTRS_FROZEN %p; size: %#x ; next: %p",
2383                        p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p), p->mut_link));
2384
2385         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2386         evac_gen = gen->no;
2387         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2388           (StgClosure *)*q = evacuate((StgClosure *)*q);
2389         }
2390         evac_gen = 0;
2391
2392         if (failed_to_evac) {
2393           failed_to_evac = rtsFalse;
2394           p->mut_link = gen->mut_list;
2395           gen->mut_list = p;
2396         }
2397         continue;
2398       }
2399
2400     case MUT_ARR_PTRS:
2401       /* follow everything */
2402       p->mut_link = gen->mut_list;
2403       gen->mut_list = p;
2404       {
2405         StgPtr end, q;
2406
2407         IF_DEBUG(gc,
2408                  belch("@@ scavenge_mut_list: scavenging MUT_ARR_PTRS %p; size: %#x ; next: %p",
2409                        p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p), p->mut_link));
2410
2411         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2412         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2413           (StgClosure *)*q = evacuate((StgClosure *)*q);
2414         }
2415         continue;
2416       }
2417
2418     case MUT_VAR:
2419       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2420        * it from the mutable list if possible by promoting whatever it
2421        * points to.
2422        */
2423         IF_DEBUG(gc,
2424                  belch("@@ scavenge_mut_list: scavenging MUT_VAR %p; var: %p ; next: %p",
2425                        p, ((StgMutVar *)p)->var, p->mut_link));
2426
2427       ASSERT(p->header.info != &MUT_CONS_info);
2428       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2429       p->mut_link = gen->mut_list;
2430       gen->mut_list = p;
2431       continue;
2432
2433     case MVAR:
2434       {
2435         StgMVar *mvar = (StgMVar *)p;
2436
2437         IF_DEBUG(gc,
2438                  belch("@@ scavenge_mut_list: scavenging MAVR %p; head: %p; tail: %p; value: %p ; next: %p",
2439                        mvar, mvar->head, mvar->tail, mvar->value, p->mut_link));
2440
2441         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2442         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2443         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2444         p->mut_link = gen->mut_list;
2445         gen->mut_list = p;
2446         continue;
2447       }
2448
2449     case TSO:
2450       {
2451         StgTSO *tso = (StgTSO *)p;
2452
2453         scavengeTSO(tso);
2454
2455         /* Don't take this TSO off the mutable list - it might still
2456          * point to some younger objects (because we set evac_gen to 0
2457          * above).
2458          */
2459         tso->mut_link = gen->mut_list;
2460         gen->mut_list = (StgMutClosure *)tso;
2461         continue;
2462       }
2463
2464     case BLACKHOLE_BQ:
2465       {
2466         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2467
2468         IF_DEBUG(gc,
2469                  belch("@@ scavenge_mut_list: scavenging BLACKHOLE_BQ (%p); next: %p",
2470                        p, p->mut_link));
2471
2472         (StgClosure *)bh->blocking_queue =
2473           evacuate((StgClosure *)bh->blocking_queue);
2474         p->mut_link = gen->mut_list;
2475         gen->mut_list = p;
2476         continue;
2477       }
2478
2479       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
2480        */
2481     case IND_OLDGEN:
2482     case IND_OLDGEN_PERM:
2483       /* Try to pull the indirectee into this generation, so we can
2484        * remove the indirection from the mutable list.
2485        */
2486       evac_gen = gen->no;
2487       ((StgIndOldGen *)p)->indirectee =
2488         evacuate(((StgIndOldGen *)p)->indirectee);
2489       evac_gen = 0;
2490
2491       if (failed_to_evac) {
2492         failed_to_evac = rtsFalse;
2493         p->mut_link = gen->mut_once_list;
2494         gen->mut_once_list = p;
2495       } else {
2496         p->mut_link = NULL;
2497       }
2498       continue;
2499
2500     // HWL: old PAR code deleted here
2501
2502     default:
2503       /* shouldn't have anything else on the mutables list */
2504       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
2505     }
2506   }
2507 }
2508
2509 //@cindex scavenge_static
2510
2511 static void
2512 scavenge_static(void)
2513 {
2514   StgClosure* p = static_objects;
2515   const StgInfoTable *info;
2516
2517   /* Always evacuate straight to the oldest generation for static
2518    * objects */
2519   evac_gen = oldest_gen->no;
2520
2521   /* keep going until we've scavenged all the objects on the linked
2522      list... */
2523   while (p != END_OF_STATIC_LIST) {
2524
2525     info = get_itbl(p);
2526     /*
2527     if (info->type==RBH)
2528       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2529     */
2530     /* make sure the info pointer is into text space */
2531     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2532                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2533
2534     /* Take this object *off* the static_objects list,
2535      * and put it on the scavenged_static_objects list.
2536      */
2537     static_objects = STATIC_LINK(info,p);
2538     STATIC_LINK(info,p) = scavenged_static_objects;
2539     scavenged_static_objects = p;
2540
2541     switch (info -> type) {
2542
2543     case IND_STATIC:
2544       {
2545         StgInd *ind = (StgInd *)p;
2546         ind->indirectee = evacuate(ind->indirectee);
2547
2548         /* might fail to evacuate it, in which case we have to pop it
2549          * back on the mutable list (and take it off the
2550          * scavenged_static list because the static link and mut link
2551          * pointers are one and the same).
2552          */
2553         if (failed_to_evac) {
2554           failed_to_evac = rtsFalse;
2555           scavenged_static_objects = STATIC_LINK(info,p);
2556           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2557           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2558         }
2559         break;
2560       }
2561
2562     case THUNK_STATIC:
2563     case FUN_STATIC:
2564       scavenge_srt(info);
2565       /* fall through */
2566
2567     case CONSTR_STATIC:
2568       {
2569         StgPtr q, next;
2570
2571         next = (P_)p->payload + info->layout.payload.ptrs;
2572         /* evacuate the pointers */
2573         for (q = (P_)p->payload; q < next; q++) {
2574           (StgClosure *)*q = evacuate((StgClosure *)*q);
2575         }
2576         break;
2577       }
2578
2579     default:
2580       barf("scavenge_static");
2581     }
2582
2583     ASSERT(failed_to_evac == rtsFalse);
2584
2585     /* get the next static object from the list.  Remeber, there might
2586      * be more stuff on this list now that we've done some evacuating!
2587      * (static_objects is a global)
2588      */
2589     p = static_objects;
2590   }
2591 }
2592
2593 /* -----------------------------------------------------------------------------
2594    scavenge_stack walks over a section of stack and evacuates all the
2595    objects pointed to by it.  We can use the same code for walking
2596    PAPs, since these are just sections of copied stack.
2597    -------------------------------------------------------------------------- */
2598 //@cindex scavenge_stack
2599
2600 static void
2601 scavenge_stack(StgPtr p, StgPtr stack_end)
2602 {
2603   StgPtr q;
2604   const StgInfoTable* info;
2605   StgWord32 bitmap;
2606
2607   IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
2608
2609   /*
2610    * Each time around this loop, we are looking at a chunk of stack
2611    * that starts with either a pending argument section or an
2612    * activation record.
2613    */
2614
2615   while (p < stack_end) {
2616     q = *(P_ *)p;
2617
2618     /* If we've got a tag, skip over that many words on the stack */
2619     if (IS_ARG_TAG((W_)q)) {
2620       p += ARG_SIZE(q);
2621       p++; continue;
2622     }
2623
2624     /* Is q a pointer to a closure?
2625      */
2626     if (! LOOKS_LIKE_GHC_INFO(q) ) {
2627 #ifdef DEBUG
2628       if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  /* Is it a static closure? */
2629         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2630       }
2631       /* otherwise, must be a pointer into the allocation space. */
2632 #endif
2633
2634       (StgClosure *)*p = evacuate((StgClosure *)q);
2635       p++;
2636       continue;
2637     }
2638
2639     /*
2640      * Otherwise, q must be the info pointer of an activation
2641      * record.  All activation records have 'bitmap' style layout
2642      * info.
2643      */
2644     info  = get_itbl((StgClosure *)p);
2645
2646     switch (info->type) {
2647
2648       /* Dynamic bitmap: the mask is stored on the stack */
2649     case RET_DYN:
2650       bitmap = ((StgRetDyn *)p)->liveness;
2651       p      = (P_)&((StgRetDyn *)p)->payload[0];
2652       goto small_bitmap;
2653
2654       /* probably a slow-entry point return address: */
2655     case FUN:
2656     case FUN_STATIC:
2657       {
2658 #if 0
2659         StgPtr old_p = p;
2660         p++; p++;
2661         IF_DEBUG(sanity,
2662                  belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
2663                        old_p, p, old_p+1));
2664 #else
2665       p++; /* what if FHS!=1 !? -- HWL */
2666 #endif
2667       goto follow_srt;
2668       }
2669
2670       /* Specialised code for update frames, since they're so common.
2671        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2672        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2673        */
2674     case UPDATE_FRAME:
2675       {
2676         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2677         StgClosure *to;
2678         nat type = get_itbl(frame->updatee)->type;
2679
2680         p += sizeofW(StgUpdateFrame);
2681         if (type == EVACUATED) {
2682           frame->updatee = evacuate(frame->updatee);
2683           continue;
2684         } else {
2685           bdescr *bd = Bdescr((P_)frame->updatee);
2686           step *step;
2687           if (bd->gen->no > N) {
2688             if (bd->gen->no < evac_gen) {
2689               failed_to_evac = rtsTrue;
2690             }
2691             continue;
2692           }
2693
2694           /* Don't promote blackholes */
2695           step = bd->step;
2696           if (!(step->gen->no == 0 &&
2697                 step->no != 0 &&
2698                 step->no == step->gen->n_steps-1)) {
2699             step = step->to;
2700           }
2701
2702           switch (type) {
2703           case BLACKHOLE:
2704           case CAF_BLACKHOLE:
2705             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2706                           sizeofW(StgHeader), step);
2707             frame->updatee = to;
2708             continue;
2709           case BLACKHOLE_BQ:
2710             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2711             frame->updatee = to;
2712             recordMutable((StgMutClosure *)to);
2713             continue;
2714           default:
2715             /* will never be SE_{,CAF_}BLACKHOLE, since we
2716                don't push an update frame for single-entry thunks.  KSW 1999-01. */
2717             barf("scavenge_stack: UPDATE_FRAME updatee");
2718           }
2719         }
2720       }
2721
2722       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2723     case STOP_FRAME:
2724     case CATCH_FRAME:
2725     case SEQ_FRAME:
2726       {
2727         StgPtr old_p = p; // debugging only -- HWL
2728       /* stack frames like these are ordinary closures and therefore may
2729          contain setup-specific fixed-header words (as in GranSim!);
2730          therefore, these cases should not use p++ but &(p->payload) -- HWL */
2731       IF_DEBUG(gran, IF_DEBUG(sanity, printObj(p)));
2732       bitmap = info->layout.bitmap;
2733
2734       p = (StgPtr)&(((StgClosure *)p)->payload);
2735       IF_DEBUG(sanity,
2736                  belch("HWL: scavenge_stack: (STOP|CATCH|SEQ)_FRAME adjusting p from %p to %p (instead of %p)",
2737                        old_p, p, old_p+1));
2738       goto small_bitmap;
2739       }
2740     case RET_BCO:
2741     case RET_SMALL:
2742     case RET_VEC_SMALL:
2743       bitmap = info->layout.bitmap;
2744       p++;
2745       /* this assumes that the payload starts immediately after the info-ptr */
2746     small_bitmap:
2747       while (bitmap != 0) {
2748         if ((bitmap & 1) == 0) {
2749           (StgClosure *)*p = evacuate((StgClosure *)*p);
2750         }
2751         p++;
2752         bitmap = bitmap >> 1;
2753       }
2754
2755     follow_srt:
2756       scavenge_srt(info);
2757       continue;
2758
2759       /* large bitmap (> 32 entries) */
2760     case RET_BIG:
2761     case RET_VEC_BIG:
2762       {
2763         StgPtr q;
2764         StgLargeBitmap *large_bitmap;
2765         nat i;
2766
2767         large_bitmap = info->layout.large_bitmap;
2768         p++;
2769
2770         for (i=0; i<large_bitmap->size; i++) {
2771           bitmap = large_bitmap->bitmap[i];
2772           q = p + sizeof(W_) * 8;
2773           while (bitmap != 0) {
2774             if ((bitmap & 1) == 0) {
2775               (StgClosure *)*p = evacuate((StgClosure *)*p);
2776             }
2777             p++;
2778             bitmap = bitmap >> 1;
2779           }
2780           if (i+1 < large_bitmap->size) {
2781             while (p < q) {
2782               (StgClosure *)*p = evacuate((StgClosure *)*p);
2783               p++;
2784             }
2785           }
2786         }
2787
2788         /* and don't forget to follow the SRT */
2789         goto follow_srt;
2790       }
2791
2792     default:
2793       barf("scavenge_stack: weird activation record found on stack.\n");
2794     }
2795   }
2796 }
2797
2798 /*-----------------------------------------------------------------------------
2799   scavenge the large object list.
2800
2801   evac_gen set by caller; similar games played with evac_gen as with
2802   scavenge() - see comment at the top of scavenge().  Most large
2803   objects are (repeatedly) mutable, so most of the time evac_gen will
2804   be zero.
2805   --------------------------------------------------------------------------- */
2806 //@cindex scavenge_large
2807
2808 static void
2809 scavenge_large(step *step)
2810 {
2811   bdescr *bd;
2812   StgPtr p;
2813   const StgInfoTable* info;
2814   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2815
2816   evac_gen = 0;                 /* most objects are mutable */
2817   bd = step->new_large_objects;
2818
2819   for (; bd != NULL; bd = step->new_large_objects) {
2820
2821     /* take this object *off* the large objects list and put it on
2822      * the scavenged large objects list.  This is so that we can
2823      * treat new_large_objects as a stack and push new objects on
2824      * the front when evacuating.
2825      */
2826     step->new_large_objects = bd->link;
2827     dbl_link_onto(bd, &step->scavenged_large_objects);
2828
2829     p = bd->start;
2830     info  = get_itbl(stgCast(StgClosure*,p));
2831
2832     switch (info->type) {
2833
2834     /* only certain objects can be "large"... */
2835
2836     case ARR_WORDS:
2837       /* nothing to follow */
2838       continue;
2839
2840     case MUT_ARR_PTRS:
2841       /* follow everything */
2842       {
2843         StgPtr next;
2844
2845         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2846         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2847           (StgClosure *)*p = evacuate((StgClosure *)*p);
2848         }
2849         continue;
2850       }
2851
2852     case MUT_ARR_PTRS_FROZEN:
2853       /* follow everything */
2854       {
2855         StgPtr start = p, next;
2856
2857         evac_gen = saved_evac_gen; /* not really mutable */
2858         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2859         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2860           (StgClosure *)*p = evacuate((StgClosure *)*p);
2861         }
2862         evac_gen = 0;
2863         if (failed_to_evac) {
2864           recordMutable((StgMutClosure *)start);
2865         }
2866         continue;
2867       }
2868
2869     case BCO:
2870       {
2871         StgBCO* bco = stgCast(StgBCO*,p);
2872         nat i;
2873         evac_gen = saved_evac_gen;
2874         for (i = 0; i < bco->n_ptrs; i++) {
2875           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2876         }
2877         evac_gen = 0;
2878         continue;
2879       }
2880
2881     case TSO:
2882         scavengeTSO((StgTSO *)p);
2883         // HWL: old PAR code deleted here
2884         continue;
2885
2886     default:
2887       barf("scavenge_large: unknown/strange object");
2888     }
2889   }
2890 }
2891
2892 //@cindex zero_static_object_list
2893
2894 static void
2895 zero_static_object_list(StgClosure* first_static)
2896 {
2897   StgClosure* p;
2898   StgClosure* link;
2899   const StgInfoTable *info;
2900
2901   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2902     info = get_itbl(p);
2903     link = STATIC_LINK(info, p);
2904     STATIC_LINK(info,p) = NULL;
2905   }
2906 }
2907
2908 /* This function is only needed because we share the mutable link
2909  * field with the static link field in an IND_STATIC, so we have to
2910  * zero the mut_link field before doing a major GC, which needs the
2911  * static link field.
2912  *
2913  * It doesn't do any harm to zero all the mutable link fields on the
2914  * mutable list.
2915  */
2916 //@cindex zero_mutable_list
2917
2918 static void
2919 zero_mutable_list( StgMutClosure *first )
2920 {
2921   StgMutClosure *next, *c;
2922
2923   for (c = first; c != END_MUT_LIST; c = next) {
2924     next = c->mut_link;
2925     c->mut_link = NULL;
2926   }
2927 }
2928
2929 //@node Reverting CAFs, Sanity code for CAF garbage collection, Scavenging
2930 //@subsection Reverting CAFs
2931
2932 /* -----------------------------------------------------------------------------
2933    Reverting CAFs
2934    -------------------------------------------------------------------------- */
2935 //@cindex RevertCAFs
2936
2937 void RevertCAFs(void)
2938 {
2939   while (enteredCAFs != END_CAF_LIST) {
2940     StgCAF* caf = enteredCAFs;
2941
2942     enteredCAFs = caf->link;
2943     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2944     SET_INFO(caf,&CAF_UNENTERED_info);
2945     caf->value = stgCast(StgClosure*,0xdeadbeef);
2946     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2947   }
2948   enteredCAFs = END_CAF_LIST;
2949 }
2950
2951 //@cindex revert_dead_CAFs
2952
2953 void revert_dead_CAFs(void)
2954 {
2955     StgCAF* caf = enteredCAFs;
2956     enteredCAFs = END_CAF_LIST;
2957     while (caf != END_CAF_LIST) {
2958         StgCAF *next, *new;
2959         next = caf->link;
2960         new = (StgCAF*)isAlive((StgClosure*)caf);
2961         if (new) {
2962            new->link = enteredCAFs;
2963            enteredCAFs = new;
2964         } else {
2965            /* ASSERT(0); */
2966            SET_INFO(caf,&CAF_UNENTERED_info);
2967            caf->value = (StgClosure*)0xdeadbeef;
2968            caf->link  = (StgCAF*)0xdeadbeef;
2969         }
2970         caf = next;
2971     }
2972 }
2973
2974 //@node Sanity code for CAF garbage collection, Lazy black holing, Reverting CAFs
2975 //@subsection Sanity code for CAF garbage collection
2976
2977 /* -----------------------------------------------------------------------------
2978    Sanity code for CAF garbage collection.
2979
2980    With DEBUG turned on, we manage a CAF list in addition to the SRT
2981    mechanism.  After GC, we run down the CAF list and blackhole any
2982    CAFs which have been garbage collected.  This means we get an error
2983    whenever the program tries to enter a garbage collected CAF.
2984
2985    Any garbage collected CAFs are taken off the CAF list at the same
2986    time.
2987    -------------------------------------------------------------------------- */
2988
2989 #ifdef DEBUG
2990 //@cindex gcCAFs
2991
2992 static void
2993 gcCAFs(void)
2994 {
2995   StgClosure*  p;
2996   StgClosure** pp;
2997   const StgInfoTable *info;
2998   nat i;
2999
3000   i = 0;
3001   p = caf_list;
3002   pp = &caf_list;
3003
3004   while (p != NULL) {
3005
3006     info = get_itbl(p);
3007
3008     ASSERT(info->type == IND_STATIC);
3009
3010     if (STATIC_LINK(info,p) == NULL) {
3011       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
3012       /* black hole it */
3013       SET_INFO(p,&BLACKHOLE_info);
3014       p = STATIC_LINK2(info,p);
3015       *pp = p;
3016     }
3017     else {
3018       pp = &STATIC_LINK2(info,p);
3019       p = *pp;
3020       i++;
3021     }
3022
3023   }
3024
3025   /*  fprintf(stderr, "%d CAFs live\n", i); */
3026 }
3027 #endif
3028
3029 //@node Lazy black holing, Stack squeezing, Sanity code for CAF garbage collection
3030 //@subsection Lazy black holing
3031
3032 /* -----------------------------------------------------------------------------
3033    Lazy black holing.
3034
3035    Whenever a thread returns to the scheduler after possibly doing
3036    some work, we have to run down the stack and black-hole all the
3037    closures referred to by update frames.
3038    -------------------------------------------------------------------------- */
3039 //@cindex threadLazyBlackHole
3040
3041 static void
3042 threadLazyBlackHole(StgTSO *tso)
3043 {
3044   StgUpdateFrame *update_frame;
3045   StgBlockingQueue *bh;
3046   StgPtr stack_end;
3047
3048   stack_end = &tso->stack[tso->stack_size];
3049   update_frame = tso->su;
3050
3051   while (1) {
3052     switch (get_itbl(update_frame)->type) {
3053
3054     case CATCH_FRAME:
3055       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
3056       break;
3057
3058     case UPDATE_FRAME:
3059       bh = (StgBlockingQueue *)update_frame->updatee;
3060
3061       /* if the thunk is already blackholed, it means we've also
3062        * already blackholed the rest of the thunks on this stack,
3063        * so we can stop early.
3064        *
3065        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3066        * don't interfere with this optimisation.
3067        */
3068       if (bh->header.info == &BLACKHOLE_info) {
3069         return;
3070       }
3071
3072       if (bh->header.info != &BLACKHOLE_BQ_info &&
3073           bh->header.info != &CAF_BLACKHOLE_info) {
3074 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3075         fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
3076 #endif
3077         SET_INFO(bh,&BLACKHOLE_info);
3078       }
3079
3080       update_frame = update_frame->link;
3081       break;
3082
3083     case SEQ_FRAME:
3084       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
3085       break;
3086
3087     case STOP_FRAME:
3088       return;
3089     default:
3090       barf("threadPaused");
3091     }
3092   }
3093 }
3094
3095 //@node Stack squeezing, Pausing a thread, Lazy black holing
3096 //@subsection Stack squeezing
3097
3098 /* -----------------------------------------------------------------------------
3099  * Stack squeezing
3100  *
3101  * Code largely pinched from old RTS, then hacked to bits.  We also do
3102  * lazy black holing here.
3103  *
3104  * -------------------------------------------------------------------------- */
3105 //@cindex threadSqueezeStack
3106
3107 static void
3108 threadSqueezeStack(StgTSO *tso)
3109 {
3110   lnat displacement = 0;
3111   StgUpdateFrame *frame;
3112   StgUpdateFrame *next_frame;                   /* Temporally next */
3113   StgUpdateFrame *prev_frame;                   /* Temporally previous */
3114   StgPtr bottom;
3115   rtsBool prev_was_update_frame;
3116 #if DEBUG
3117   StgUpdateFrame *top_frame;
3118   nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
3119       bhs=0, squeezes=0;
3120   void printObj( StgClosure *obj ); // from Printer.c
3121
3122   top_frame  = tso->su;
3123 #endif
3124
3125   bottom = &(tso->stack[tso->stack_size]);
3126   frame  = tso->su;
3127
3128   /* There must be at least one frame, namely the STOP_FRAME.
3129    */
3130   ASSERT((P_)frame < bottom);
3131
3132   /* Walk down the stack, reversing the links between frames so that
3133    * we can walk back up as we squeeze from the bottom.  Note that
3134    * next_frame and prev_frame refer to next and previous as they were
3135    * added to the stack, rather than the way we see them in this
3136    * walk. (It makes the next loop less confusing.)
3137    *
3138    * Stop if we find an update frame pointing to a black hole
3139    * (see comment in threadLazyBlackHole()).
3140    */
3141
3142   next_frame = NULL;
3143   /* bottom - sizeof(StgStopFrame) is the STOP_FRAME */
3144   while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
3145     prev_frame = frame->link;
3146     frame->link = next_frame;
3147     next_frame = frame;
3148     frame = prev_frame;
3149 #if DEBUG
3150     IF_DEBUG(sanity,
3151              if (!(frame>=top_frame && frame<=bottom)) {
3152                printObj((StgClosure *)prev_frame);
3153                barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
3154                     frame, prev_frame);
3155              })
3156     switch (get_itbl(frame)->type) {
3157     case UPDATE_FRAME: upd_frames++;
3158                        if (frame->updatee->header.info == &BLACKHOLE_info)
3159                          bhs++;
3160                        break;
3161     case STOP_FRAME:  stop_frames++;
3162                       break;
3163     case CATCH_FRAME: catch_frames++;
3164                       break;
3165     case SEQ_FRAME: seq_frames++;
3166                     break;
3167     default:
3168       barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
3169            frame, prev_frame);
3170       printObj((StgClosure *)prev_frame);
3171     }
3172 #endif
3173     if (get_itbl(frame)->type == UPDATE_FRAME
3174         && frame->updatee->header.info == &BLACKHOLE_info) {
3175         break;
3176     }
3177   }
3178
3179   /* Now, we're at the bottom.  Frame points to the lowest update
3180    * frame on the stack, and its link actually points to the frame
3181    * above. We have to walk back up the stack, squeezing out empty
3182    * update frames and turning the pointers back around on the way
3183    * back up.
3184    *
3185    * The bottom-most frame (the STOP_FRAME) has not been altered, and
3186    * we never want to eliminate it anyway.  Just walk one step up
3187    * before starting to squeeze. When you get to the topmost frame,
3188    * remember that there are still some words above it that might have
3189    * to be moved.
3190    */
3191
3192   prev_frame = frame;
3193   frame = next_frame;
3194
3195   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
3196
3197   /*
3198    * Loop through all of the frames (everything except the very
3199    * bottom).  Things are complicated by the fact that we have
3200    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
3201    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
3202    */
3203   while (frame != NULL) {
3204     StgPtr sp;
3205     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
3206     rtsBool is_update_frame;
3207
3208     next_frame = frame->link;
3209     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
3210
3211     /* Check to see if
3212      *   1. both the previous and current frame are update frames
3213      *   2. the current frame is empty
3214      */
3215     if (prev_was_update_frame && is_update_frame &&
3216         (P_)prev_frame == frame_bottom + displacement) {
3217
3218       /* Now squeeze out the current frame */
3219       StgClosure *updatee_keep   = prev_frame->updatee;
3220       StgClosure *updatee_bypass = frame->updatee;
3221
3222 #if DEBUG
3223       IF_DEBUG(gc, fprintf(stderr, "@@ squeezing frame at %p\n", frame));
3224       squeezes++;
3225 #endif
3226
3227       /* Deal with blocking queues.  If both updatees have blocked
3228        * threads, then we should merge the queues into the update
3229        * frame that we're keeping.
3230        *
3231        * Alternatively, we could just wake them up: they'll just go
3232        * straight to sleep on the proper blackhole!  This is less code
3233        * and probably less bug prone, although it's probably much
3234        * slower --SDM
3235        */
3236 #if 0 /* do it properly... */
3237 #  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3238 #    error Unimplemented lazy BH warning.  (KSW 1999-01)
3239 #  endif
3240       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info
3241           || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
3242           ) {
3243         /* Sigh.  It has one.  Don't lose those threads! */
3244           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
3245           /* Urgh.  Two queues.  Merge them. */
3246           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
3247
3248           while (keep_tso->link != END_TSO_QUEUE) {
3249             keep_tso = keep_tso->link;
3250           }
3251           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
3252
3253         } else {
3254           /* For simplicity, just swap the BQ for the BH */
3255           P_ temp = updatee_keep;
3256
3257           updatee_keep = updatee_bypass;
3258           updatee_bypass = temp;
3259
3260           /* Record the swap in the kept frame (below) */
3261           prev_frame->updatee = updatee_keep;
3262         }
3263       }
3264 #endif
3265
3266       TICK_UPD_SQUEEZED();
3267       /* wasn't there something about update squeezing and ticky to be
3268        * sorted out?  oh yes: we aren't counting each enter properly
3269        * in this case.  See the log somewhere.  KSW 1999-04-21
3270        */
3271       UPD_IND_NOLOCK(updatee_bypass, updatee_keep); /* this wakes the threads up */
3272
3273       sp = (P_)frame - 1;       /* sp = stuff to slide */
3274       displacement += sizeofW(StgUpdateFrame);
3275
3276     } else {
3277       /* No squeeze for this frame */
3278       sp = frame_bottom - 1;    /* Keep the current frame */
3279
3280       /* Do lazy black-holing.
3281        */
3282       if (is_update_frame) {
3283         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
3284         if (bh->header.info != &BLACKHOLE_info &&
3285             bh->header.info != &BLACKHOLE_BQ_info &&
3286             bh->header.info != &CAF_BLACKHOLE_info) {
3287 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3288           fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
3289 #endif
3290           SET_INFO(bh,&BLACKHOLE_info);
3291         }
3292       }
3293
3294       /* Fix the link in the current frame (should point to the frame below) */
3295       frame->link = prev_frame;
3296       prev_was_update_frame = is_update_frame;
3297     }
3298
3299     /* Now slide all words from sp up to the next frame */
3300
3301     if (displacement > 0) {
3302       P_ next_frame_bottom;
3303
3304       if (next_frame != NULL)
3305         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
3306       else
3307         next_frame_bottom = tso->sp - 1;
3308
3309 #if DEBUG
3310       IF_DEBUG(gc,
3311                fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
3312                        displacement))
3313 #endif
3314
3315       while (sp >= next_frame_bottom) {
3316         sp[displacement] = *sp;
3317         sp -= 1;
3318       }
3319     }
3320     (P_)prev_frame = (P_)frame + displacement;
3321     frame = next_frame;
3322   }
3323
3324   tso->sp += displacement;
3325   tso->su = prev_frame;
3326 #if DEBUG
3327   IF_DEBUG(gc,
3328            fprintf(stderr, "@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames\n",
3329                    squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
3330 #endif
3331 }
3332
3333 //@node Pausing a thread, Index, Stack squeezing
3334 //@subsection Pausing a thread
3335
3336 /* -----------------------------------------------------------------------------
3337  * Pausing a thread
3338  *
3339  * We have to prepare for GC - this means doing lazy black holing
3340  * here.  We also take the opportunity to do stack squeezing if it's
3341  * turned on.
3342  * -------------------------------------------------------------------------- */
3343 //@cindex threadPaused
3344
3345 void
3346 threadPaused(StgTSO *tso)
3347 {
3348   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
3349     threadSqueezeStack(tso);    /* does black holing too */
3350   else
3351     threadLazyBlackHole(tso);
3352 }
3353
3354 #if DEBUG
3355 //@cindex printMutOnceList
3356 void
3357 printMutOnceList(generation *gen)
3358 {
3359   const StgInfoTable *info;
3360   StgMutClosure *p, *next, *new_list;
3361
3362   p = gen->mut_once_list;
3363   new_list = END_MUT_LIST;
3364   next = p->mut_link;
3365
3366   evac_gen = gen->no;
3367   failed_to_evac = rtsFalse;
3368
3369   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
3370   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3371     fprintf(stderr, "%p (%s), ",
3372             p, info_type((StgClosure *)p));
3373   }
3374   fputc('\n', stderr);
3375 }
3376
3377 //@cindex printMutableList
3378 void
3379 printMutableList(generation *gen)
3380 {
3381   const StgInfoTable *info;
3382   StgMutClosure *p, *next;
3383
3384   p = gen->saved_mut_list;
3385   next = p->mut_link;
3386
3387   evac_gen = 0;
3388   failed_to_evac = rtsFalse;
3389
3390   fprintf(stderr, "@@ Mutable list %p: ", gen->saved_mut_list);
3391   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3392     fprintf(stderr, "%p (%s), ",
3393             p, info_type((StgClosure *)p));
3394   }
3395   fputc('\n', stderr);
3396 }
3397 #endif /* DEBUG */
3398
3399 //@node Index,  , Pausing a thread
3400 //@subsection Index
3401
3402 //@index
3403 //* GarbageCollect::  @cindex\s-+GarbageCollect
3404 //* MarkRoot::  @cindex\s-+MarkRoot
3405 //* RevertCAFs::  @cindex\s-+RevertCAFs
3406 //* addBlock::  @cindex\s-+addBlock
3407 //* cleanup_weak_ptr_list::  @cindex\s-+cleanup_weak_ptr_list
3408 //* copy::  @cindex\s-+copy
3409 //* copyPart::  @cindex\s-+copyPart
3410 //* evacuate::  @cindex\s-+evacuate
3411 //* evacuate_large::  @cindex\s-+evacuate_large
3412 //* gcCAFs::  @cindex\s-+gcCAFs
3413 //* isAlive::  @cindex\s-+isAlive
3414 //* mkMutCons::  @cindex\s-+mkMutCons
3415 //* relocate_TSO::  @cindex\s-+relocate_TSO
3416 //* revert_dead_CAFs::  @cindex\s-+revert_dead_CAFs
3417 //* scavenge::  @cindex\s-+scavenge
3418 //* scavenge_large::  @cindex\s-+scavenge_large
3419 //* scavenge_mut_once_list::  @cindex\s-+scavenge_mut_once_list
3420 //* scavenge_mutable_list::  @cindex\s-+scavenge_mutable_list
3421 //* scavenge_one::  @cindex\s-+scavenge_one
3422 //* scavenge_srt::  @cindex\s-+scavenge_srt
3423 //* scavenge_stack::  @cindex\s-+scavenge_stack
3424 //* scavenge_static::  @cindex\s-+scavenge_static
3425 //* threadLazyBlackHole::  @cindex\s-+threadLazyBlackHole
3426 //* threadPaused::  @cindex\s-+threadPaused
3427 //* threadSqueezeStack::  @cindex\s-+threadSqueezeStack
3428 //* traverse_weak_ptr_list::  @cindex\s-+traverse_weak_ptr_list
3429 //* upd_evacuee::  @cindex\s-+upd_evacuee
3430 //* zero_mutable_list::  @cindex\s-+zero_mutable_list
3431 //* zero_static_object_list::  @cindex\s-+zero_static_object_list
3432 //@end index