ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.72 2000/01/22 18:00:03 simonmar 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   return evacuate(root);
 937 }
 938
 939 //@cindex addBlock
 940 static void addBlock(step *step)
 941 {
 942   bdescr *bd = allocBlock();
 943   bd->gen = step->gen;
 944   bd->step = step;
 945
 946   if (step->gen->no <= N) {
 947     bd->evacuated = 1;
 948   } else {
 949     bd->evacuated = 0;
 950   }
 951
 952   step->hp_bd->free = step->hp;
 953   step->hp_bd->link = bd;
 954   step->hp = bd->start;
 955   step->hpLim = step->hp + BLOCK_SIZE_W;
 956   step->hp_bd = bd;
 957   step->to_blocks++;
 958   new_blocks++;
 959 }
 960
 961 //@cindex upd_evacuee
 962
 963 static __inline__ void
 964 upd_evacuee(StgClosure *p, StgClosure *dest)
 965 {
 966   p->header.info = &EVACUATED_info;
 967   ((StgEvacuated *)p)->evacuee = dest;
 968 }
 969
 970 //@cindex copy
 971
 972 static __inline__ StgClosure *
 973 copy(StgClosure *src, nat size, step *step)
 974 {
 975   P_ to, from, dest;
 976
 977   TICK_GC_WORDS_COPIED(size);
 978   /* Find out where we're going, using the handy "to" pointer in
 979    * the step of the source object.  If it turns out we need to
 980    * evacuate to an older generation, adjust it here (see comment
 981    * by evacuate()).
 982    */
 983   if (step->gen->no < evac_gen) {
 984 #ifdef NO_EAGER_PROMOTION
 985     failed_to_evac = rtsTrue;
 986 #else
 987     step = &generations[evac_gen].steps[0];
 988 #endif
 989   }
 990
 991   /* chain a new block onto the to-space for the destination step if
 992    * necessary.
 993    */
 994   if (step->hp + size >= step->hpLim) {
 995     addBlock(step);
 996   }
 997
 998   for(to = step->hp, from = (P_)src; size>0; --size) {
 999     *to++ = *from++;
1000   }
1001
1002   dest = step->hp;
1003   step->hp = to;
1004   upd_evacuee(src,(StgClosure *)dest);
1005   return (StgClosure *)dest;
1006 }
1007
1008 /* Special version of copy() for when we only want to copy the info
1009  * pointer of an object, but reserve some padding after it.  This is
1010  * used to optimise evacuation of BLACKHOLEs.
1011  */
1012
1013 //@cindex copyPart
1014
1015 static __inline__ StgClosure *
1016 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
1017 {
1018   P_ dest, to, from;
1019
1020   TICK_GC_WORDS_COPIED(size_to_copy);
1021   if (step->gen->no < evac_gen) {
1022 #ifdef NO_EAGER_PROMOTION
1023     failed_to_evac = rtsTrue;
1024 #else
1025     step = &generations[evac_gen].steps[0];
1026 #endif
1027   }
1028
1029   if (step->hp + size_to_reserve >= step->hpLim) {
1030     addBlock(step);
1031   }
1032
1033   for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1034     *to++ = *from++;
1035   }
1036
1037   dest = step->hp;
1038   step->hp += size_to_reserve;
1039   upd_evacuee(src,(StgClosure *)dest);
1040   return (StgClosure *)dest;
1041 }
1042
1043 //@node Evacuation, Scavenging, Weak Pointers
1044 //@subsection Evacuation
1045
1046 /* -----------------------------------------------------------------------------
1047    Evacuate a large object
1048
1049    This just consists of removing the object from the (doubly-linked)
1050    large_alloc_list, and linking it on to the (singly-linked)
1051    new_large_objects list, from where it will be scavenged later.
1052
1053    Convention: bd->evacuated is /= 0 for a large object that has been
1054    evacuated, or 0 otherwise.
1055    -------------------------------------------------------------------------- */
1056
1057 //@cindex evacuate_large
1058
1059 static inline void
1060 evacuate_large(StgPtr p, rtsBool mutable)
1061 {
1062   bdescr *bd = Bdescr(p);
1063   step *step;
1064
1065   /* should point to the beginning of the block */
1066   ASSERT(((W_)p & BLOCK_MASK) == 0);
1067
1068   /* already evacuated? */
1069   if (bd->evacuated) {
1070     /* Don't forget to set the failed_to_evac flag if we didn't get
1071      * the desired destination (see comments in evacuate()).
1072      */
1073     if (bd->gen->no < evac_gen) {
1074       failed_to_evac = rtsTrue;
1075       TICK_GC_FAILED_PROMOTION();
1076     }
1077     return;
1078   }
1079
1080   step = bd->step;
1081   /* remove from large_object list */
1082   if (bd->back) {
1083     bd->back->link = bd->link;
1084   } else { /* first object in the list */
1085     step->large_objects = bd->link;
1086   }
1087   if (bd->link) {
1088     bd->link->back = bd->back;
1089   }
1090
1091   /* link it on to the evacuated large object list of the destination step
1092    */
1093   step = bd->step->to;
1094   if (step->gen->no < evac_gen) {
1095 #ifdef NO_EAGER_PROMOTION
1096     failed_to_evac = rtsTrue;
1097 #else
1098     step = &generations[evac_gen].steps[0];
1099 #endif
1100   }
1101
1102   bd->step = step;
1103   bd->gen = step->gen;
1104   bd->link = step->new_large_objects;
1105   step->new_large_objects = bd;
1106   bd->evacuated = 1;
1107
1108   if (mutable) {
1109     recordMutable((StgMutClosure *)p);
1110   }
1111 }
1112
1113 /* -----------------------------------------------------------------------------
1114    Adding a MUT_CONS to an older generation.
1115
1116    This is necessary from time to time when we end up with an
1117    old-to-new generation pointer in a non-mutable object.  We defer
1118    the promotion until the next GC.
1119    -------------------------------------------------------------------------- */
1120
1121 //@cindex mkMutCons
1122
1123 static StgClosure *
1124 mkMutCons(StgClosure *ptr, generation *gen)
1125 {
1126   StgMutVar *q;
1127   step *step;
1128
1129   step = &gen->steps[0];
1130
1131   /* chain a new block onto the to-space for the destination step if
1132    * necessary.
1133    */
1134   if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
1135     addBlock(step);
1136   }
1137
1138   q = (StgMutVar *)step->hp;
1139   step->hp += sizeofW(StgMutVar);
1140
1141   SET_HDR(q,&MUT_CONS_info,CCS_GC);
1142   q->var = ptr;
1143   recordOldToNewPtrs((StgMutClosure *)q);
1144
1145   return (StgClosure *)q;
1146 }
1147
1148 /* -----------------------------------------------------------------------------
1149    Evacuate
1150
1151    This is called (eventually) for every live object in the system.
1152
1153    The caller to evacuate specifies a desired generation in the
1154    evac_gen global variable.  The following conditions apply to
1155    evacuating an object which resides in generation M when we're
1156    collecting up to generation N
1157
1158    if  M >= evac_gen
1159            if  M > N     do nothing
1160            else          evac to step->to
1161
1162    if  M < evac_gen      evac to evac_gen, step 0
1163
1164    if the object is already evacuated, then we check which generation
1165    it now resides in.
1166
1167    if  M >= evac_gen     do nothing
1168    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1169                          didn't manage to evacuate this object into evac_gen.
1170
1171    -------------------------------------------------------------------------- */
1172 //@cindex evacuate
1173
1174 static StgClosure *
1175 evacuate(StgClosure *q)
1176 {
1177   StgClosure *to;
1178   bdescr *bd = NULL;
1179   step *step;
1180   const StgInfoTable *info;
1181
1182 loop:
1183   if (HEAP_ALLOCED(q)) {
1184     bd = Bdescr((P_)q);
1185     if (bd->gen->no > N) {
1186       /* Can't evacuate this object, because it's in a generation
1187        * older than the ones we're collecting.  Let's hope that it's
1188        * in evac_gen or older, or we will have to make an IND_OLDGEN object.
1189        */
1190       if (bd->gen->no < evac_gen) {
1191         /* nope */
1192         failed_to_evac = rtsTrue;
1193         TICK_GC_FAILED_PROMOTION();
1194       }
1195       return q;
1196     }
1197     step = bd->step->to;
1198   }
1199 #ifdef DEBUG
1200   else step = NULL; /* make sure copy() will crash if HEAP_ALLOCED is wrong */
1201 #endif
1202
1203   /* make sure the info pointer is into text space */
1204   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1205                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1206   info = get_itbl(q);
1207   /*
1208   if (info->type==RBH) {
1209     info = REVERT_INFOPTR(info);
1210     IF_DEBUG(gc,
1211              belch("@_ Trying to evacuate an RBH %p (%s); reverting to IP %p (%s)",
1212                      q, info_type(q), info, info_type_by_ip(info)));
1213   }
1214   */
1215
1216   switch (info -> type) {
1217
1218   case BCO:
1219     {
1220       nat size = bco_sizeW((StgBCO*)q);
1221
1222       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1223         evacuate_large((P_)q, rtsFalse);
1224         to = q;
1225       } else {
1226         /* just copy the block */
1227         to = copy(q,size,step);
1228       }
1229       return to;
1230     }
1231
1232   case MUT_VAR:
1233     ASSERT(q->header.info != &MUT_CONS_info);
1234   case MVAR:
1235     to = copy(q,sizeW_fromITBL(info),step);
1236     recordMutable((StgMutClosure *)to);
1237     return to;
1238
1239   case FUN_1_0:
1240   case FUN_0_1:
1241   case CONSTR_1_0:
1242   case CONSTR_0_1:
1243     return copy(q,sizeofW(StgHeader)+1,step);
1244
1245   case THUNK_1_0:               /* here because of MIN_UPD_SIZE */
1246   case THUNK_0_1:
1247   case THUNK_1_1:
1248   case THUNK_0_2:
1249   case THUNK_2_0:
1250 #ifdef NO_PROMOTE_THUNKS
1251     if (bd->gen->no == 0 &&
1252         bd->step->no != 0 &&
1253         bd->step->no == bd->gen->n_steps-1) {
1254       step = bd->step;
1255     }
1256 #endif
1257     return copy(q,sizeofW(StgHeader)+2,step);
1258
1259   case FUN_1_1:
1260   case FUN_0_2:
1261   case FUN_2_0:
1262   case CONSTR_1_1:
1263   case CONSTR_0_2:
1264   case CONSTR_2_0:
1265     return copy(q,sizeofW(StgHeader)+2,step);
1266
1267   case FUN:
1268   case THUNK:
1269   case CONSTR:
1270   case IND_PERM:
1271   case IND_OLDGEN_PERM:
1272   case CAF_UNENTERED:
1273   case CAF_ENTERED:
1274   case WEAK:
1275   case FOREIGN:
1276   case STABLE_NAME:
1277     return copy(q,sizeW_fromITBL(info),step);
1278
1279   case CAF_BLACKHOLE:
1280   case SE_CAF_BLACKHOLE:
1281   case SE_BLACKHOLE:
1282   case BLACKHOLE:
1283     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1284
1285   case BLACKHOLE_BQ:
1286     to = copy(q,BLACKHOLE_sizeW(),step);
1287     recordMutable((StgMutClosure *)to);
1288     return to;
1289
1290   case THUNK_SELECTOR:
1291     {
1292       const StgInfoTable* selectee_info;
1293       StgClosure* selectee = ((StgSelector*)q)->selectee;
1294
1295     selector_loop:
1296       selectee_info = get_itbl(selectee);
1297       switch (selectee_info->type) {
1298       case CONSTR:
1299       case CONSTR_1_0:
1300       case CONSTR_0_1:
1301       case CONSTR_2_0:
1302       case CONSTR_1_1:
1303       case CONSTR_0_2:
1304       case CONSTR_STATIC:
1305         {
1306           StgWord32 offset = info->layout.selector_offset;
1307
1308           /* check that the size is in range */
1309           ASSERT(offset <
1310                  (StgWord32)(selectee_info->layout.payload.ptrs +
1311                             selectee_info->layout.payload.nptrs));
1312
1313           /* perform the selection! */
1314           q = selectee->payload[offset];
1315
1316           /* if we're already in to-space, there's no need to continue
1317            * with the evacuation, just update the source address with
1318            * a pointer to the (evacuated) constructor field.
1319            */
1320           if (HEAP_ALLOCED(q)) {
1321             bdescr *bd = Bdescr((P_)q);
1322             if (bd->evacuated) {
1323               if (bd->gen->no < evac_gen) {
1324                 failed_to_evac = rtsTrue;
1325                 TICK_GC_FAILED_PROMOTION();
1326               }
1327               return q;
1328             }
1329           }
1330
1331           /* otherwise, carry on and evacuate this constructor field,
1332            * (but not the constructor itself)
1333            */
1334           goto loop;
1335         }
1336
1337       case IND:
1338       case IND_STATIC:
1339       case IND_PERM:
1340       case IND_OLDGEN:
1341       case IND_OLDGEN_PERM:
1342         selectee = stgCast(StgInd *,selectee)->indirectee;
1343         goto selector_loop;
1344
1345       case CAF_ENTERED:
1346         selectee = stgCast(StgCAF *,selectee)->value;
1347         goto selector_loop;
1348
1349       case EVACUATED:
1350         selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1351         goto selector_loop;
1352
1353       case THUNK:
1354       case THUNK_1_0:
1355       case THUNK_0_1:
1356       case THUNK_2_0:
1357       case THUNK_1_1:
1358       case THUNK_0_2:
1359       case THUNK_STATIC:
1360       case THUNK_SELECTOR:
1361         /* aargh - do recursively???? */
1362       case CAF_UNENTERED:
1363       case CAF_BLACKHOLE:
1364       case SE_CAF_BLACKHOLE:
1365       case SE_BLACKHOLE:
1366       case BLACKHOLE:
1367       case BLACKHOLE_BQ:
1368         /* not evaluated yet */
1369         break;
1370
1371       default:
1372         barf("evacuate: THUNK_SELECTOR: strange selectee %d",
1373              (int)(selectee_info->type));
1374       }
1375     }
1376     return copy(q,THUNK_SELECTOR_sizeW(),step);
1377
1378   case IND:
1379   case IND_OLDGEN:
1380     /* follow chains of indirections, don't evacuate them */
1381     q = ((StgInd*)q)->indirectee;
1382     goto loop;
1383
1384   case THUNK_STATIC:
1385     if (info->srt_len > 0 && major_gc &&
1386         THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1387       THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1388       static_objects = (StgClosure *)q;
1389     }
1390     return q;
1391
1392   case FUN_STATIC:
1393     if (info->srt_len > 0 && major_gc &&
1394         FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1395       FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1396       static_objects = (StgClosure *)q;
1397     }
1398     return q;
1399
1400   case IND_STATIC:
1401     if (major_gc && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1402       IND_STATIC_LINK((StgClosure *)q) = static_objects;
1403       static_objects = (StgClosure *)q;
1404     }
1405     return q;
1406
1407   case CONSTR_STATIC:
1408     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1409       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1410       static_objects = (StgClosure *)q;
1411     }
1412     return q;
1413
1414   case CONSTR_INTLIKE:
1415   case CONSTR_CHARLIKE:
1416   case CONSTR_NOCAF_STATIC:
1417     /* no need to put these on the static linked list, they don't need
1418      * to be scavenged.
1419      */
1420     return q;
1421
1422   case RET_BCO:
1423   case RET_SMALL:
1424   case RET_VEC_SMALL:
1425   case RET_BIG:
1426   case RET_VEC_BIG:
1427   case RET_DYN:
1428   case UPDATE_FRAME:
1429   case STOP_FRAME:
1430   case CATCH_FRAME:
1431   case SEQ_FRAME:
1432     /* shouldn't see these */
1433     barf("evacuate: stack frame at %p\n", q);
1434
1435   case AP_UPD:
1436   case PAP:
1437     /* these are special - the payload is a copy of a chunk of stack,
1438        tagging and all. */
1439     return copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1440
1441   case EVACUATED:
1442     /* Already evacuated, just return the forwarding address.
1443      * HOWEVER: if the requested destination generation (evac_gen) is
1444      * older than the actual generation (because the object was
1445      * already evacuated to a younger generation) then we have to
1446      * set the failed_to_evac flag to indicate that we couldn't
1447      * manage to promote the object to the desired generation.
1448      */
1449     if (evac_gen > 0) {         /* optimisation */
1450       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1451       if (Bdescr((P_)p)->gen->no < evac_gen) {
1452         IF_DEBUG(gc, belch("@@ evacuate: evac of EVACUATED node %p failed!", p));
1453         failed_to_evac = rtsTrue;
1454         TICK_GC_FAILED_PROMOTION();
1455       }
1456     }
1457     return ((StgEvacuated*)q)->evacuee;
1458
1459   case ARR_WORDS:
1460     {
1461       nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1462
1463       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1464         evacuate_large((P_)q, rtsFalse);
1465         return q;
1466       } else {
1467         /* just copy the block */
1468         return copy(q,size,step);
1469       }
1470     }
1471
1472   case MUT_ARR_PTRS:
1473   case MUT_ARR_PTRS_FROZEN:
1474     {
1475       nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1476
1477       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1478         evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1479         to = q;
1480       } else {
1481         /* just copy the block */
1482         to = copy(q,size,step);
1483         if (info->type == MUT_ARR_PTRS) {
1484           recordMutable((StgMutClosure *)to);
1485         }
1486       }
1487       return to;
1488     }
1489
1490   case TSO:
1491     {
1492       StgTSO *tso = (StgTSO *)q;
1493       nat size = tso_sizeW(tso);
1494       int diff;
1495
1496       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1497        */
1498       if (tso->whatNext == ThreadRelocated) {
1499         q = (StgClosure *)tso->link;
1500         goto loop;
1501       }
1502
1503       /* Large TSOs don't get moved, so no relocation is required.
1504        */
1505       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1506         evacuate_large((P_)q, rtsTrue);
1507         return q;
1508
1509       /* To evacuate a small TSO, we need to relocate the update frame
1510        * list it contains.
1511        */
1512       } else {
1513         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1514
1515         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1516
1517         /* relocate the stack pointers... */
1518         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1519         new_tso->sp = (StgPtr)new_tso->sp + diff;
1520         new_tso->splim = (StgPtr)new_tso->splim + diff;
1521
1522         relocate_TSO(tso, new_tso);
1523
1524         recordMutable((StgMutClosure *)new_tso);
1525         return (StgClosure *)new_tso;
1526       }
1527     }
1528
1529 #if defined(PAR)
1530   case RBH: // cf. BLACKHOLE_BQ
1531     {
1532       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1533       to = copy(q,BLACKHOLE_sizeW(),step);
1534       //ToDo: derive size etc from reverted IP
1535       //to = copy(q,size,step);
1536       recordMutable((StgMutClosure *)to);
1537       IF_DEBUG(gc,
1538                belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1539                      q, info_type(q), to, info_type(to)));
1540       return to;
1541     }
1542
1543   case BLOCKED_FETCH:
1544     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1545     to = copy(q,sizeofW(StgBlockedFetch),step);
1546     IF_DEBUG(gc,
1547              belch("@@ evacuate: %p (%s) to %p (%s)",
1548                    q, info_type(q), to, info_type(to)));
1549     return to;
1550
1551   case FETCH_ME:
1552     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1553     to = copy(q,sizeofW(StgFetchMe),step);
1554     IF_DEBUG(gc,
1555              belch("@@ evacuate: %p (%s) to %p (%s)",
1556                    q, info_type(q), to, info_type(to)));
1557     return to;
1558
1559   case FETCH_ME_BQ:
1560     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1561     to = copy(q,sizeofW(StgFetchMeBlockingQueue),step);
1562     IF_DEBUG(gc,
1563              belch("@@ evacuate: %p (%s) to %p (%s)",
1564                    q, info_type(q), to, info_type(to)));
1565     return to;
1566 #endif
1567
1568   default:
1569     barf("evacuate: strange closure type %d", (int)(info->type));
1570   }
1571
1572   barf("evacuate");
1573 }
1574
1575 /* -----------------------------------------------------------------------------
1576    relocate_TSO is called just after a TSO has been copied from src to
1577    dest.  It adjusts the update frame list for the new location.
1578    -------------------------------------------------------------------------- */
1579 //@cindex relocate_TSO
1580
1581 StgTSO *
1582 relocate_TSO(StgTSO *src, StgTSO *dest)
1583 {
1584   StgUpdateFrame *su;
1585   StgCatchFrame  *cf;
1586   StgSeqFrame    *sf;
1587   int diff;
1588
1589   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1590
1591   su = dest->su;
1592
1593   while ((P_)su < dest->stack + dest->stack_size) {
1594     switch (get_itbl(su)->type) {
1595
1596       /* GCC actually manages to common up these three cases! */
1597
1598     case UPDATE_FRAME:
1599       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1600       su = su->link;
1601       continue;
1602
1603     case CATCH_FRAME:
1604       cf = (StgCatchFrame *)su;
1605       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1606       su = cf->link;
1607       continue;
1608
1609     case SEQ_FRAME:
1610       sf = (StgSeqFrame *)su;
1611       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1612       su = sf->link;
1613       continue;
1614
1615     case STOP_FRAME:
1616       /* all done! */
1617       break;
1618
1619     default:
1620       barf("relocate_TSO %d", (int)(get_itbl(su)->type));
1621     }
1622     break;
1623   }
1624
1625   return dest;
1626 }
1627
1628 //@node Scavenging, Reverting CAFs, Evacuation
1629 //@subsection Scavenging
1630
1631 //@cindex scavenge_srt
1632
1633 static inline void
1634 scavenge_srt(const StgInfoTable *info)
1635 {
1636   StgClosure **srt, **srt_end;
1637
1638   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1639    * srt field in the info table.  That's ok, because we'll
1640    * never dereference it.
1641    */
1642   srt = stgCast(StgClosure **,info->srt);
1643   srt_end = srt + info->srt_len;
1644   for (; srt < srt_end; srt++) {
1645     /* Special-case to handle references to closures hiding out in DLLs, since
1646        double indirections required to get at those. The code generator knows
1647        which is which when generating the SRT, so it stores the (indirect)
1648        reference to the DLL closure in the table by first adding one to it.
1649        We check for this here, and undo the addition before evacuating it.
1650
1651        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1652        closure that's fixed at link-time, and no extra magic is required.
1653     */
1654 #ifdef ENABLE_WIN32_DLL_SUPPORT
1655     if ( stgCast(unsigned long,*srt) & 0x1 ) {
1656        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
1657     } else {
1658        evacuate(*srt);
1659     }
1660 #else
1661        evacuate(*srt);
1662 #endif
1663   }
1664 }
1665
1666 /* -----------------------------------------------------------------------------
1667    Scavenge a TSO.
1668    -------------------------------------------------------------------------- */
1669
1670 static void
1671 scavengeTSO (StgTSO *tso)
1672 {
1673   /* chase the link field for any TSOs on the same queue */
1674   (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1675   if (   tso->why_blocked == BlockedOnMVar
1676          || tso->why_blocked == BlockedOnBlackHole
1677          || tso->why_blocked == BlockedOnException) {
1678     tso->block_info.closure = evacuate(tso->block_info.closure);
1679   }
1680   if ( tso->blocked_exceptions != NULL ) {
1681     tso->blocked_exceptions =
1682       (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
1683   }
1684   /* scavenge this thread's stack */
1685   scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1686 }
1687
1688 /* -----------------------------------------------------------------------------
1689    Scavenge a given step until there are no more objects in this step
1690    to scavenge.
1691
1692    evac_gen is set by the caller to be either zero (for a step in a
1693    generation < N) or G where G is the generation of the step being
1694    scavenged.
1695
1696    We sometimes temporarily change evac_gen back to zero if we're
1697    scavenging a mutable object where early promotion isn't such a good
1698    idea.
1699    -------------------------------------------------------------------------- */
1700 //@cindex scavenge
1701
1702 static void
1703 scavenge(step *step)
1704 {
1705   StgPtr p, q;
1706   const StgInfoTable *info;
1707   bdescr *bd;
1708   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1709
1710   p = step->scan;
1711   bd = step->scan_bd;
1712
1713   failed_to_evac = rtsFalse;
1714
1715   /* scavenge phase - standard breadth-first scavenging of the
1716    * evacuated objects
1717    */
1718
1719   while (bd != step->hp_bd || p < step->hp) {
1720
1721     /* If we're at the end of this block, move on to the next block */
1722     if (bd != step->hp_bd && p == bd->free) {
1723       bd = bd->link;
1724       p = bd->start;
1725       continue;
1726     }
1727
1728     q = p;                      /* save ptr to object */
1729
1730     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1731                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1732
1733     info = get_itbl((StgClosure *)p);
1734     /*
1735     if (info->type==RBH)
1736       info = REVERT_INFOPTR(info);
1737     */
1738
1739     switch (info -> type) {
1740
1741     case BCO:
1742       {
1743         StgBCO* bco = stgCast(StgBCO*,p);
1744         nat i;
1745         for (i = 0; i < bco->n_ptrs; i++) {
1746           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1747         }
1748         p += bco_sizeW(bco);
1749         break;
1750       }
1751
1752     case MVAR:
1753       /* treat MVars specially, because we don't want to evacuate the
1754        * mut_link field in the middle of the closure.
1755        */
1756       {
1757         StgMVar *mvar = ((StgMVar *)p);
1758         evac_gen = 0;
1759         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1760         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1761         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1762         p += sizeofW(StgMVar);
1763         evac_gen = saved_evac_gen;
1764         break;
1765       }
1766
1767     case THUNK_2_0:
1768     case FUN_2_0:
1769       scavenge_srt(info);
1770     case CONSTR_2_0:
1771       ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1772       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1773       p += sizeofW(StgHeader) + 2;
1774       break;
1775
1776     case THUNK_1_0:
1777       scavenge_srt(info);
1778       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1779       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1780       break;
1781
1782     case FUN_1_0:
1783       scavenge_srt(info);
1784     case CONSTR_1_0:
1785       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1786       p += sizeofW(StgHeader) + 1;
1787       break;
1788
1789     case THUNK_0_1:
1790       scavenge_srt(info);
1791       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1792       break;
1793
1794     case FUN_0_1:
1795       scavenge_srt(info);
1796     case CONSTR_0_1:
1797       p += sizeofW(StgHeader) + 1;
1798       break;
1799
1800     case THUNK_0_2:
1801     case FUN_0_2:
1802       scavenge_srt(info);
1803     case CONSTR_0_2:
1804       p += sizeofW(StgHeader) + 2;
1805       break;
1806
1807     case THUNK_1_1:
1808     case FUN_1_1:
1809       scavenge_srt(info);
1810     case CONSTR_1_1:
1811       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1812       p += sizeofW(StgHeader) + 2;
1813       break;
1814
1815     case FUN:
1816     case THUNK:
1817       scavenge_srt(info);
1818       /* fall through */
1819
1820     case CONSTR:
1821     case WEAK:
1822     case FOREIGN:
1823     case STABLE_NAME:
1824       {
1825         StgPtr end;
1826
1827         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1828         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1829           (StgClosure *)*p = evacuate((StgClosure *)*p);
1830         }
1831         p += info->layout.payload.nptrs;
1832         break;
1833       }
1834
1835     case IND_PERM:
1836       if (step->gen->no != 0) {
1837         SET_INFO(((StgClosure *)p), &IND_OLDGEN_PERM_info);
1838       }
1839       /* fall through */
1840     case IND_OLDGEN_PERM:
1841       ((StgIndOldGen *)p)->indirectee =
1842         evacuate(((StgIndOldGen *)p)->indirectee);
1843       if (failed_to_evac) {
1844         failed_to_evac = rtsFalse;
1845         recordOldToNewPtrs((StgMutClosure *)p);
1846       }
1847       p += sizeofW(StgIndOldGen);
1848       break;
1849
1850     case CAF_UNENTERED:
1851       {
1852         StgCAF *caf = (StgCAF *)p;
1853
1854         caf->body = evacuate(caf->body);
1855         if (failed_to_evac) {
1856           failed_to_evac = rtsFalse;
1857           recordOldToNewPtrs((StgMutClosure *)p);
1858         } else {
1859           caf->mut_link = NULL;
1860         }
1861         p += sizeofW(StgCAF);
1862         break;
1863       }
1864
1865     case CAF_ENTERED:
1866       {
1867         StgCAF *caf = (StgCAF *)p;
1868
1869         caf->body = evacuate(caf->body);
1870         caf->value = evacuate(caf->value);
1871         if (failed_to_evac) {
1872           failed_to_evac = rtsFalse;
1873           recordOldToNewPtrs((StgMutClosure *)p);
1874         } else {
1875           caf->mut_link = NULL;
1876         }
1877         p += sizeofW(StgCAF);
1878         break;
1879       }
1880
1881     case MUT_VAR:
1882       /* ignore MUT_CONSs */
1883       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1884         evac_gen = 0;
1885         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1886         evac_gen = saved_evac_gen;
1887       }
1888       p += sizeofW(StgMutVar);
1889       break;
1890
1891     case CAF_BLACKHOLE:
1892     case SE_CAF_BLACKHOLE:
1893     case SE_BLACKHOLE:
1894     case BLACKHOLE:
1895         p += BLACKHOLE_sizeW();
1896         break;
1897
1898     case BLACKHOLE_BQ:
1899       {
1900         StgBlockingQueue *bh = (StgBlockingQueue *)p;
1901         (StgClosure *)bh->blocking_queue =
1902           evacuate((StgClosure *)bh->blocking_queue);
1903         if (failed_to_evac) {
1904           failed_to_evac = rtsFalse;
1905           recordMutable((StgMutClosure *)bh);
1906         }
1907         p += BLACKHOLE_sizeW();
1908         break;
1909       }
1910
1911     case THUNK_SELECTOR:
1912       {
1913         StgSelector *s = (StgSelector *)p;
1914         s->selectee = evacuate(s->selectee);
1915         p += THUNK_SELECTOR_sizeW();
1916         break;
1917       }
1918
1919     case IND:
1920     case IND_OLDGEN:
1921       barf("scavenge:IND???\n");
1922
1923     case CONSTR_INTLIKE:
1924     case CONSTR_CHARLIKE:
1925     case CONSTR_STATIC:
1926     case CONSTR_NOCAF_STATIC:
1927     case THUNK_STATIC:
1928     case FUN_STATIC:
1929     case IND_STATIC:
1930       /* Shouldn't see a static object here. */
1931       barf("scavenge: STATIC object\n");
1932
1933     case RET_BCO:
1934     case RET_SMALL:
1935     case RET_VEC_SMALL:
1936     case RET_BIG:
1937     case RET_VEC_BIG:
1938     case RET_DYN:
1939     case UPDATE_FRAME:
1940     case STOP_FRAME:
1941     case CATCH_FRAME:
1942     case SEQ_FRAME:
1943       /* Shouldn't see stack frames here. */
1944       barf("scavenge: stack frame\n");
1945
1946     case AP_UPD: /* same as PAPs */
1947     case PAP:
1948       /* Treat a PAP just like a section of stack, not forgetting to
1949        * evacuate the function pointer too...
1950        */
1951       {
1952         StgPAP* pap = stgCast(StgPAP*,p);
1953
1954         pap->fun = evacuate(pap->fun);
1955         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1956         p += pap_sizeW(pap);
1957         break;
1958       }
1959
1960     case ARR_WORDS:
1961       /* nothing to follow */
1962       p += arr_words_sizeW(stgCast(StgArrWords*,p));
1963       break;
1964
1965     case MUT_ARR_PTRS:
1966       /* follow everything */
1967       {
1968         StgPtr next;
1969
1970         evac_gen = 0;           /* repeatedly mutable */
1971         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1972         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1973           (StgClosure *)*p = evacuate((StgClosure *)*p);
1974         }
1975         evac_gen = saved_evac_gen;
1976         break;
1977       }
1978
1979     case MUT_ARR_PTRS_FROZEN:
1980       /* follow everything */
1981       {
1982         StgPtr start = p, next;
1983
1984         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1985         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1986           (StgClosure *)*p = evacuate((StgClosure *)*p);
1987         }
1988         if (failed_to_evac) {
1989           /* we can do this easier... */
1990           recordMutable((StgMutClosure *)start);
1991           failed_to_evac = rtsFalse;
1992         }
1993         break;
1994       }
1995
1996     case TSO:
1997       {
1998         StgTSO *tso = (StgTSO *)p;
1999         evac_gen = 0;
2000         scavengeTSO(tso);
2001         evac_gen = saved_evac_gen;
2002         p += tso_sizeW(tso);
2003         break;
2004       }
2005
2006 #if defined(PAR)
2007     case RBH: // cf. BLACKHOLE_BQ
2008       {
2009         // nat size, ptrs, nonptrs, vhs;
2010         // char str[80];
2011         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2012         StgRBH *rbh = (StgRBH *)p;
2013         (StgClosure *)rbh->blocking_queue =
2014           evacuate((StgClosure *)rbh->blocking_queue);
2015         if (failed_to_evac) {
2016           failed_to_evac = rtsFalse;
2017           recordMutable((StgMutClosure *)rbh);
2018         }
2019         IF_DEBUG(gc,
2020                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2021                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2022         // ToDo: use size of reverted closure here!
2023         p += BLACKHOLE_sizeW();
2024         break;
2025       }
2026
2027     case BLOCKED_FETCH:
2028       {
2029         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2030         /* follow the pointer to the node which is being demanded */
2031         (StgClosure *)bf->node =
2032           evacuate((StgClosure *)bf->node);
2033         /* follow the link to the rest of the blocking queue */
2034         (StgClosure *)bf->link =
2035           evacuate((StgClosure *)bf->link);
2036         if (failed_to_evac) {
2037           failed_to_evac = rtsFalse;
2038           recordMutable((StgMutClosure *)bf);
2039         }
2040         IF_DEBUG(gc,
2041                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2042                      bf, info_type((StgClosure *)bf),
2043                      bf->node, info_type(bf->node)));
2044         p += sizeofW(StgBlockedFetch);
2045         break;
2046       }
2047
2048     case FETCH_ME:
2049       IF_DEBUG(gc,
2050                belch("@@ scavenge: HWL claims nothing to do for %p (%s)",
2051                      p, info_type((StgClosure *)p)));
2052       p += sizeofW(StgFetchMe);
2053       break; // nothing to do in this case
2054
2055     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2056       {
2057         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2058         (StgClosure *)fmbq->blocking_queue =
2059           evacuate((StgClosure *)fmbq->blocking_queue);
2060         if (failed_to_evac) {
2061           failed_to_evac = rtsFalse;
2062           recordMutable((StgMutClosure *)fmbq);
2063         }
2064         IF_DEBUG(gc,
2065                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2066                      p, info_type((StgClosure *)p)));
2067         p += sizeofW(StgFetchMeBlockingQueue);
2068         break;
2069       }
2070 #endif
2071
2072     case EVACUATED:
2073       barf("scavenge: unimplemented/strange closure type\n");
2074
2075     default:
2076       barf("scavenge");
2077     }
2078
2079     /* If we didn't manage to promote all the objects pointed to by
2080      * the current object, then we have to designate this object as
2081      * mutable (because it contains old-to-new generation pointers).
2082      */
2083     if (failed_to_evac) {
2084       mkMutCons((StgClosure *)q, &generations[evac_gen]);
2085       failed_to_evac = rtsFalse;
2086     }
2087   }
2088
2089   step->scan_bd = bd;
2090   step->scan = p;
2091 }
2092
2093 /* -----------------------------------------------------------------------------
2094    Scavenge one object.
2095
2096    This is used for objects that are temporarily marked as mutable
2097    because they contain old-to-new generation pointers.  Only certain
2098    objects can have this property.
2099    -------------------------------------------------------------------------- */
2100 //@cindex scavenge_one
2101
2102 static rtsBool
2103 scavenge_one(StgClosure *p)
2104 {
2105   const StgInfoTable *info;
2106   rtsBool no_luck;
2107
2108   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2109                || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2110
2111   info = get_itbl(p);
2112
2113   /* ngoq moHqu'!
2114   if (info->type==RBH)
2115     info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2116   */
2117
2118   switch (info -> type) {
2119
2120   case FUN:
2121   case FUN_1_0:                 /* hardly worth specialising these guys */
2122   case FUN_0_1:
2123   case FUN_1_1:
2124   case FUN_0_2:
2125   case FUN_2_0:
2126   case THUNK:
2127   case THUNK_1_0:
2128   case THUNK_0_1:
2129   case THUNK_1_1:
2130   case THUNK_0_2:
2131   case THUNK_2_0:
2132   case CONSTR:
2133   case CONSTR_1_0:
2134   case CONSTR_0_1:
2135   case CONSTR_1_1:
2136   case CONSTR_0_2:
2137   case CONSTR_2_0:
2138   case WEAK:
2139   case FOREIGN:
2140   case IND_PERM:
2141   case IND_OLDGEN_PERM:
2142   case CAF_UNENTERED:
2143     {
2144       StgPtr q, end;
2145
2146       end = (P_)p->payload + info->layout.payload.ptrs;
2147       for (q = (P_)p->payload; q < end; q++) {
2148         (StgClosure *)*q = evacuate((StgClosure *)*q);
2149       }
2150       break;
2151     }
2152
2153   case CAF_BLACKHOLE:
2154   case SE_CAF_BLACKHOLE:
2155   case SE_BLACKHOLE:
2156   case BLACKHOLE:
2157       break;
2158
2159   case THUNK_SELECTOR:
2160     {
2161       StgSelector *s = (StgSelector *)p;
2162       s->selectee = evacuate(s->selectee);
2163       break;
2164     }
2165
2166   case AP_UPD: /* same as PAPs */
2167   case PAP:
2168     /* Treat a PAP just like a section of stack, not forgetting to
2169      * evacuate the function pointer too...
2170      */
2171     {
2172       StgPAP* pap = (StgPAP *)p;
2173
2174       pap->fun = evacuate(pap->fun);
2175       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2176       break;
2177     }
2178
2179   case IND_OLDGEN:
2180     /* This might happen if for instance a MUT_CONS was pointing to a
2181      * THUNK which has since been updated.  The IND_OLDGEN will
2182      * be on the mutable list anyway, so we don't need to do anything
2183      * here.
2184      */
2185     break;
2186
2187   default:
2188     barf("scavenge_one: strange object");
2189   }
2190
2191   no_luck = failed_to_evac;
2192   failed_to_evac = rtsFalse;
2193   return (no_luck);
2194 }
2195
2196
2197 /* -----------------------------------------------------------------------------
2198    Scavenging mutable lists.
2199
2200    We treat the mutable list of each generation > N (i.e. all the
2201    generations older than the one being collected) as roots.  We also
2202    remove non-mutable objects from the mutable list at this point.
2203    -------------------------------------------------------------------------- */
2204 //@cindex scavenge_mut_once_list
2205
2206 static void
2207 scavenge_mut_once_list(generation *gen)
2208 {
2209   const StgInfoTable *info;
2210   StgMutClosure *p, *next, *new_list;
2211
2212   p = gen->mut_once_list;
2213   new_list = END_MUT_LIST;
2214   next = p->mut_link;
2215
2216   evac_gen = gen->no;
2217   failed_to_evac = rtsFalse;
2218
2219   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2220
2221     /* make sure the info pointer is into text space */
2222     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2223                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2224
2225     info = get_itbl(p);
2226     /*
2227     if (info->type==RBH)
2228       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2229     */
2230     switch(info->type) {
2231
2232     case IND_OLDGEN:
2233     case IND_OLDGEN_PERM:
2234     case IND_STATIC:
2235       /* Try to pull the indirectee into this generation, so we can
2236        * remove the indirection from the mutable list.
2237        */
2238       ((StgIndOldGen *)p)->indirectee =
2239         evacuate(((StgIndOldGen *)p)->indirectee);
2240
2241 #ifdef DEBUG
2242       if (RtsFlags.DebugFlags.gc)
2243       /* Debugging code to print out the size of the thing we just
2244        * promoted
2245        */
2246       {
2247         StgPtr start = gen->steps[0].scan;
2248         bdescr *start_bd = gen->steps[0].scan_bd;
2249         nat size = 0;
2250         scavenge(&gen->steps[0]);
2251         if (start_bd != gen->steps[0].scan_bd) {
2252           size += (P_)BLOCK_ROUND_UP(start) - start;
2253           start_bd = start_bd->link;
2254           while (start_bd != gen->steps[0].scan_bd) {
2255             size += BLOCK_SIZE_W;
2256             start_bd = start_bd->link;
2257           }
2258           size += gen->steps[0].scan -
2259             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
2260         } else {
2261           size = gen->steps[0].scan - start;
2262         }
2263         fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
2264       }
2265 #endif
2266
2267       /* failed_to_evac might happen if we've got more than two
2268        * generations, we're collecting only generation 0, the
2269        * indirection resides in generation 2 and the indirectee is
2270        * in generation 1.
2271        */
2272       if (failed_to_evac) {
2273         failed_to_evac = rtsFalse;
2274         p->mut_link = new_list;
2275         new_list = p;
2276       } else {
2277         /* the mut_link field of an IND_STATIC is overloaded as the
2278          * static link field too (it just so happens that we don't need
2279          * both at the same time), so we need to NULL it out when
2280          * removing this object from the mutable list because the static
2281          * link fields are all assumed to be NULL before doing a major
2282          * collection.
2283          */
2284         p->mut_link = NULL;
2285       }
2286       continue;
2287
2288     case MUT_VAR:
2289       /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
2290        * it from the mutable list if possible by promoting whatever it
2291        * points to.
2292        */
2293       ASSERT(p->header.info == &MUT_CONS_info);
2294       if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
2295         /* didn't manage to promote everything, so put the
2296          * MUT_CONS back on the list.
2297          */
2298         p->mut_link = new_list;
2299         new_list = p;
2300       }
2301       continue;
2302
2303     case CAF_ENTERED:
2304       {
2305         StgCAF *caf = (StgCAF *)p;
2306         caf->body  = evacuate(caf->body);
2307         caf->value = evacuate(caf->value);
2308         if (failed_to_evac) {
2309           failed_to_evac = rtsFalse;
2310           p->mut_link = new_list;
2311           new_list = p;
2312         } else {
2313           p->mut_link = NULL;
2314         }
2315       }
2316       continue;
2317
2318     case CAF_UNENTERED:
2319       {
2320         StgCAF *caf = (StgCAF *)p;
2321         caf->body  = evacuate(caf->body);
2322         if (failed_to_evac) {
2323           failed_to_evac = rtsFalse;
2324           p->mut_link = new_list;
2325           new_list = p;
2326         } else {
2327           p->mut_link = NULL;
2328         }
2329       }
2330       continue;
2331
2332     default:
2333       /* shouldn't have anything else on the mutables list */
2334       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
2335     }
2336   }
2337
2338   gen->mut_once_list = new_list;
2339 }
2340
2341 //@cindex scavenge_mutable_list
2342
2343 static void
2344 scavenge_mutable_list(generation *gen)
2345 {
2346   const StgInfoTable *info;
2347   StgMutClosure *p, *next;
2348
2349   p = gen->saved_mut_list;
2350   next = p->mut_link;
2351
2352   evac_gen = 0;
2353   failed_to_evac = rtsFalse;
2354
2355   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2356
2357     /* make sure the info pointer is into text space */
2358     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2359                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2360
2361     info = get_itbl(p);
2362     /*
2363     if (info->type==RBH)
2364       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2365     */
2366     switch(info->type) {
2367
2368     case MUT_ARR_PTRS_FROZEN:
2369       /* remove this guy from the mutable list, but follow the ptrs
2370        * anyway (and make sure they get promoted to this gen).
2371        */
2372       {
2373         StgPtr end, q;
2374
2375         IF_DEBUG(gc,
2376                  belch("@@ scavenge_mut_list: scavenging MUT_ARR_PTRS_FROZEN %p; size: %#x ; next: %p",
2377                        p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p), p->mut_link));
2378
2379         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2380         evac_gen = gen->no;
2381         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2382           (StgClosure *)*q = evacuate((StgClosure *)*q);
2383         }
2384         evac_gen = 0;
2385
2386         if (failed_to_evac) {
2387           failed_to_evac = rtsFalse;
2388           p->mut_link = gen->mut_list;
2389           gen->mut_list = p;
2390         }
2391         continue;
2392       }
2393
2394     case MUT_ARR_PTRS:
2395       /* follow everything */
2396       p->mut_link = gen->mut_list;
2397       gen->mut_list = p;
2398       {
2399         StgPtr end, q;
2400
2401         IF_DEBUG(gc,
2402                  belch("@@ scavenge_mut_list: scavenging MUT_ARR_PTRS %p; size: %#x ; next: %p",
2403                        p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p), p->mut_link));
2404
2405         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2406         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2407           (StgClosure *)*q = evacuate((StgClosure *)*q);
2408         }
2409         continue;
2410       }
2411
2412     case MUT_VAR:
2413       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2414        * it from the mutable list if possible by promoting whatever it
2415        * points to.
2416        */
2417         IF_DEBUG(gc,
2418                  belch("@@ scavenge_mut_list: scavenging MUT_VAR %p; var: %p ; next: %p",
2419                        p, ((StgMutVar *)p)->var, p->mut_link));
2420
2421       ASSERT(p->header.info != &MUT_CONS_info);
2422       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2423       p->mut_link = gen->mut_list;
2424       gen->mut_list = p;
2425       continue;
2426
2427     case MVAR:
2428       {
2429         StgMVar *mvar = (StgMVar *)p;
2430
2431         IF_DEBUG(gc,
2432                  belch("@@ scavenge_mut_list: scavenging MAVR %p; head: %p; tail: %p; value: %p ; next: %p",
2433                        mvar, mvar->head, mvar->tail, mvar->value, p->mut_link));
2434
2435         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2436         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2437         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2438         p->mut_link = gen->mut_list;
2439         gen->mut_list = p;
2440         continue;
2441       }
2442
2443     case TSO:
2444       {
2445         StgTSO *tso = (StgTSO *)p;
2446
2447         scavengeTSO(tso);
2448
2449         /* Don't take this TSO off the mutable list - it might still
2450          * point to some younger objects (because we set evac_gen to 0
2451          * above).
2452          */
2453         tso->mut_link = gen->mut_list;
2454         gen->mut_list = (StgMutClosure *)tso;
2455         continue;
2456       }
2457
2458     case BLACKHOLE_BQ:
2459       {
2460         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2461
2462         IF_DEBUG(gc,
2463                  belch("@@ scavenge_mut_list: scavenging BLACKHOLE_BQ (%p); next: %p",
2464                        p, p->mut_link));
2465
2466         (StgClosure *)bh->blocking_queue =
2467           evacuate((StgClosure *)bh->blocking_queue);
2468         p->mut_link = gen->mut_list;
2469         gen->mut_list = p;
2470         continue;
2471       }
2472
2473       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
2474        */
2475     case IND_OLDGEN:
2476     case IND_OLDGEN_PERM:
2477       /* Try to pull the indirectee into this generation, so we can
2478        * remove the indirection from the mutable list.
2479        */
2480       evac_gen = gen->no;
2481       ((StgIndOldGen *)p)->indirectee =
2482         evacuate(((StgIndOldGen *)p)->indirectee);
2483       evac_gen = 0;
2484
2485       if (failed_to_evac) {
2486         failed_to_evac = rtsFalse;
2487         p->mut_link = gen->mut_once_list;
2488         gen->mut_once_list = p;
2489       } else {
2490         p->mut_link = NULL;
2491       }
2492       continue;
2493
2494     // HWL: old PAR code deleted here
2495
2496     default:
2497       /* shouldn't have anything else on the mutables list */
2498       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
2499     }
2500   }
2501 }
2502
2503 //@cindex scavenge_static
2504
2505 static void
2506 scavenge_static(void)
2507 {
2508   StgClosure* p = static_objects;
2509   const StgInfoTable *info;
2510
2511   /* Always evacuate straight to the oldest generation for static
2512    * objects */
2513   evac_gen = oldest_gen->no;
2514
2515   /* keep going until we've scavenged all the objects on the linked
2516      list... */
2517   while (p != END_OF_STATIC_LIST) {
2518
2519     info = get_itbl(p);
2520     /*
2521     if (info->type==RBH)
2522       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2523     */
2524     /* make sure the info pointer is into text space */
2525     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2526                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2527
2528     /* Take this object *off* the static_objects list,
2529      * and put it on the scavenged_static_objects list.
2530      */
2531     static_objects = STATIC_LINK(info,p);
2532     STATIC_LINK(info,p) = scavenged_static_objects;
2533     scavenged_static_objects = p;
2534
2535     switch (info -> type) {
2536
2537     case IND_STATIC:
2538       {
2539         StgInd *ind = (StgInd *)p;
2540         ind->indirectee = evacuate(ind->indirectee);
2541
2542         /* might fail to evacuate it, in which case we have to pop it
2543          * back on the mutable list (and take it off the
2544          * scavenged_static list because the static link and mut link
2545          * pointers are one and the same).
2546          */
2547         if (failed_to_evac) {
2548           failed_to_evac = rtsFalse;
2549           scavenged_static_objects = STATIC_LINK(info,p);
2550           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2551           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2552         }
2553         break;
2554       }
2555
2556     case THUNK_STATIC:
2557     case FUN_STATIC:
2558       scavenge_srt(info);
2559       /* fall through */
2560
2561     case CONSTR_STATIC:
2562       {
2563         StgPtr q, next;
2564
2565         next = (P_)p->payload + info->layout.payload.ptrs;
2566         /* evacuate the pointers */
2567         for (q = (P_)p->payload; q < next; q++) {
2568           (StgClosure *)*q = evacuate((StgClosure *)*q);
2569         }
2570         break;
2571       }
2572
2573     default:
2574       barf("scavenge_static");
2575     }
2576
2577     ASSERT(failed_to_evac == rtsFalse);
2578
2579     /* get the next static object from the list.  Remeber, there might
2580      * be more stuff on this list now that we've done some evacuating!
2581      * (static_objects is a global)
2582      */
2583     p = static_objects;
2584   }
2585 }
2586
2587 /* -----------------------------------------------------------------------------
2588    scavenge_stack walks over a section of stack and evacuates all the
2589    objects pointed to by it.  We can use the same code for walking
2590    PAPs, since these are just sections of copied stack.
2591    -------------------------------------------------------------------------- */
2592 //@cindex scavenge_stack
2593
2594 static void
2595 scavenge_stack(StgPtr p, StgPtr stack_end)
2596 {
2597   StgPtr q;
2598   const StgInfoTable* info;
2599   StgWord32 bitmap;
2600
2601   IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
2602
2603   /*
2604    * Each time around this loop, we are looking at a chunk of stack
2605    * that starts with either a pending argument section or an
2606    * activation record.
2607    */
2608
2609   while (p < stack_end) {
2610     q = *(P_ *)p;
2611
2612     /* If we've got a tag, skip over that many words on the stack */
2613     if (IS_ARG_TAG((W_)q)) {
2614       p += ARG_SIZE(q);
2615       p++; continue;
2616     }
2617
2618     /* Is q a pointer to a closure?
2619      */
2620     if (! LOOKS_LIKE_GHC_INFO(q) ) {
2621 #ifdef DEBUG
2622       if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  /* Is it a static closure? */
2623         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2624       }
2625       /* otherwise, must be a pointer into the allocation space. */
2626 #endif
2627
2628       (StgClosure *)*p = evacuate((StgClosure *)q);
2629       p++;
2630       continue;
2631     }
2632
2633     /*
2634      * Otherwise, q must be the info pointer of an activation
2635      * record.  All activation records have 'bitmap' style layout
2636      * info.
2637      */
2638     info  = get_itbl((StgClosure *)p);
2639
2640     switch (info->type) {
2641
2642       /* Dynamic bitmap: the mask is stored on the stack */
2643     case RET_DYN:
2644       bitmap = ((StgRetDyn *)p)->liveness;
2645       p      = (P_)&((StgRetDyn *)p)->payload[0];
2646       goto small_bitmap;
2647
2648       /* probably a slow-entry point return address: */
2649     case FUN:
2650     case FUN_STATIC:
2651       {
2652 #if 0
2653         StgPtr old_p = p;
2654         p++; p++;
2655         IF_DEBUG(sanity,
2656                  belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
2657                        old_p, p, old_p+1));
2658 #else
2659       p++; /* what if FHS!=1 !? -- HWL */
2660 #endif
2661       goto follow_srt;
2662       }
2663
2664       /* Specialised code for update frames, since they're so common.
2665        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2666        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2667        */
2668     case UPDATE_FRAME:
2669       {
2670         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2671         StgClosure *to;
2672         nat type = get_itbl(frame->updatee)->type;
2673
2674         p += sizeofW(StgUpdateFrame);
2675         if (type == EVACUATED) {
2676           frame->updatee = evacuate(frame->updatee);
2677           continue;
2678         } else {
2679           bdescr *bd = Bdescr((P_)frame->updatee);
2680           step *step;
2681           if (bd->gen->no > N) {
2682             if (bd->gen->no < evac_gen) {
2683               failed_to_evac = rtsTrue;
2684             }
2685             continue;
2686           }
2687
2688           /* Don't promote blackholes */
2689           step = bd->step;
2690           if (!(step->gen->no == 0 &&
2691                 step->no != 0 &&
2692                 step->no == step->gen->n_steps-1)) {
2693             step = step->to;
2694           }
2695
2696           switch (type) {
2697           case BLACKHOLE:
2698           case CAF_BLACKHOLE:
2699             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2700                           sizeofW(StgHeader), step);
2701             frame->updatee = to;
2702             continue;
2703           case BLACKHOLE_BQ:
2704             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2705             frame->updatee = to;
2706             recordMutable((StgMutClosure *)to);
2707             continue;
2708           default:
2709             /* will never be SE_{,CAF_}BLACKHOLE, since we
2710                don't push an update frame for single-entry thunks.  KSW 1999-01. */
2711             barf("scavenge_stack: UPDATE_FRAME updatee");
2712           }
2713         }
2714       }
2715
2716       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2717     case STOP_FRAME:
2718     case CATCH_FRAME:
2719     case SEQ_FRAME:
2720       {
2721         // StgPtr old_p = p; // debugging only -- HWL
2722       /* stack frames like these are ordinary closures and therefore may
2723          contain setup-specific fixed-header words (as in GranSim!);
2724          therefore, these cases should not use p++ but &(p->payload) -- HWL */
2725       // IF_DEBUG(gran, IF_DEBUG(sanity, printObj(p)));
2726       bitmap = info->layout.bitmap;
2727
2728       p = (StgPtr)&(((StgClosure *)p)->payload);
2729       // IF_DEBUG(sanity, belch("HWL: scavenge_stack: (STOP|CATCH|SEQ)_FRAME adjusting p from %p to %p (instead of %p)",                       old_p, p, old_p+1));
2730       goto small_bitmap;
2731       }
2732     case RET_BCO:
2733     case RET_SMALL:
2734     case RET_VEC_SMALL:
2735       bitmap = info->layout.bitmap;
2736       p++;
2737       /* this assumes that the payload starts immediately after the info-ptr */
2738     small_bitmap:
2739       while (bitmap != 0) {
2740         if ((bitmap & 1) == 0) {
2741           (StgClosure *)*p = evacuate((StgClosure *)*p);
2742         }
2743         p++;
2744         bitmap = bitmap >> 1;
2745       }
2746
2747     follow_srt:
2748       scavenge_srt(info);
2749       continue;
2750
2751       /* large bitmap (> 32 entries) */
2752     case RET_BIG:
2753     case RET_VEC_BIG:
2754       {
2755         StgPtr q;
2756         StgLargeBitmap *large_bitmap;
2757         nat i;
2758
2759         large_bitmap = info->layout.large_bitmap;
2760         p++;
2761
2762         for (i=0; i<large_bitmap->size; i++) {
2763           bitmap = large_bitmap->bitmap[i];
2764           q = p + sizeof(W_) * 8;
2765           while (bitmap != 0) {
2766             if ((bitmap & 1) == 0) {
2767               (StgClosure *)*p = evacuate((StgClosure *)*p);
2768             }
2769             p++;
2770             bitmap = bitmap >> 1;
2771           }
2772           if (i+1 < large_bitmap->size) {
2773             while (p < q) {
2774               (StgClosure *)*p = evacuate((StgClosure *)*p);
2775               p++;
2776             }
2777           }
2778         }
2779
2780         /* and don't forget to follow the SRT */
2781         goto follow_srt;
2782       }
2783
2784     default:
2785       barf("scavenge_stack: weird activation record found on stack.\n");
2786     }
2787   }
2788 }
2789
2790 /*-----------------------------------------------------------------------------
2791   scavenge the large object list.
2792
2793   evac_gen set by caller; similar games played with evac_gen as with
2794   scavenge() - see comment at the top of scavenge().  Most large
2795   objects are (repeatedly) mutable, so most of the time evac_gen will
2796   be zero.
2797   --------------------------------------------------------------------------- */
2798 //@cindex scavenge_large
2799
2800 static void
2801 scavenge_large(step *step)
2802 {
2803   bdescr *bd;
2804   StgPtr p;
2805   const StgInfoTable* info;
2806   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2807
2808   evac_gen = 0;                 /* most objects are mutable */
2809   bd = step->new_large_objects;
2810
2811   for (; bd != NULL; bd = step->new_large_objects) {
2812
2813     /* take this object *off* the large objects list and put it on
2814      * the scavenged large objects list.  This is so that we can
2815      * treat new_large_objects as a stack and push new objects on
2816      * the front when evacuating.
2817      */
2818     step->new_large_objects = bd->link;
2819     dbl_link_onto(bd, &step->scavenged_large_objects);
2820
2821     p = bd->start;
2822     info  = get_itbl(stgCast(StgClosure*,p));
2823
2824     switch (info->type) {
2825
2826     /* only certain objects can be "large"... */
2827
2828     case ARR_WORDS:
2829       /* nothing to follow */
2830       continue;
2831
2832     case MUT_ARR_PTRS:
2833       /* follow everything */
2834       {
2835         StgPtr next;
2836
2837         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2838         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2839           (StgClosure *)*p = evacuate((StgClosure *)*p);
2840         }
2841         continue;
2842       }
2843
2844     case MUT_ARR_PTRS_FROZEN:
2845       /* follow everything */
2846       {
2847         StgPtr start = p, next;
2848
2849         evac_gen = saved_evac_gen; /* not really mutable */
2850         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2851         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2852           (StgClosure *)*p = evacuate((StgClosure *)*p);
2853         }
2854         evac_gen = 0;
2855         if (failed_to_evac) {
2856           recordMutable((StgMutClosure *)start);
2857         }
2858         continue;
2859       }
2860
2861     case BCO:
2862       {
2863         StgBCO* bco = stgCast(StgBCO*,p);
2864         nat i;
2865         evac_gen = saved_evac_gen;
2866         for (i = 0; i < bco->n_ptrs; i++) {
2867           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2868         }
2869         evac_gen = 0;
2870         continue;
2871       }
2872
2873     case TSO:
2874         scavengeTSO((StgTSO *)p);
2875         // HWL: old PAR code deleted here
2876         continue;
2877
2878     default:
2879       barf("scavenge_large: unknown/strange object");
2880     }
2881   }
2882 }
2883
2884 //@cindex zero_static_object_list
2885
2886 static void
2887 zero_static_object_list(StgClosure* first_static)
2888 {
2889   StgClosure* p;
2890   StgClosure* link;
2891   const StgInfoTable *info;
2892
2893   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2894     info = get_itbl(p);
2895     link = STATIC_LINK(info, p);
2896     STATIC_LINK(info,p) = NULL;
2897   }
2898 }
2899
2900 /* This function is only needed because we share the mutable link
2901  * field with the static link field in an IND_STATIC, so we have to
2902  * zero the mut_link field before doing a major GC, which needs the
2903  * static link field.
2904  *
2905  * It doesn't do any harm to zero all the mutable link fields on the
2906  * mutable list.
2907  */
2908 //@cindex zero_mutable_list
2909
2910 static void
2911 zero_mutable_list( StgMutClosure *first )
2912 {
2913   StgMutClosure *next, *c;
2914
2915   for (c = first; c != END_MUT_LIST; c = next) {
2916     next = c->mut_link;
2917     c->mut_link = NULL;
2918   }
2919 }
2920
2921 //@node Reverting CAFs, Sanity code for CAF garbage collection, Scavenging
2922 //@subsection Reverting CAFs
2923
2924 /* -----------------------------------------------------------------------------
2925    Reverting CAFs
2926    -------------------------------------------------------------------------- */
2927 //@cindex RevertCAFs
2928
2929 void RevertCAFs(void)
2930 {
2931   while (enteredCAFs != END_CAF_LIST) {
2932     StgCAF* caf = enteredCAFs;
2933
2934     enteredCAFs = caf->link;
2935     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2936     SET_INFO(caf,&CAF_UNENTERED_info);
2937     caf->value = stgCast(StgClosure*,0xdeadbeef);
2938     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2939   }
2940   enteredCAFs = END_CAF_LIST;
2941 }
2942
2943 //@cindex revert_dead_CAFs
2944
2945 void revert_dead_CAFs(void)
2946 {
2947     StgCAF* caf = enteredCAFs;
2948     enteredCAFs = END_CAF_LIST;
2949     while (caf != END_CAF_LIST) {
2950         StgCAF *next, *new;
2951         next = caf->link;
2952         new = (StgCAF*)isAlive((StgClosure*)caf);
2953         if (new) {
2954            new->link = enteredCAFs;
2955            enteredCAFs = new;
2956         } else {
2957            /* ASSERT(0); */
2958            SET_INFO(caf,&CAF_UNENTERED_info);
2959            caf->value = (StgClosure*)0xdeadbeef;
2960            caf->link  = (StgCAF*)0xdeadbeef;
2961         }
2962         caf = next;
2963     }
2964 }
2965
2966 //@node Sanity code for CAF garbage collection, Lazy black holing, Reverting CAFs
2967 //@subsection Sanity code for CAF garbage collection
2968
2969 /* -----------------------------------------------------------------------------
2970    Sanity code for CAF garbage collection.
2971
2972    With DEBUG turned on, we manage a CAF list in addition to the SRT
2973    mechanism.  After GC, we run down the CAF list and blackhole any
2974    CAFs which have been garbage collected.  This means we get an error
2975    whenever the program tries to enter a garbage collected CAF.
2976
2977    Any garbage collected CAFs are taken off the CAF list at the same
2978    time.
2979    -------------------------------------------------------------------------- */
2980
2981 #ifdef DEBUG
2982 //@cindex gcCAFs
2983
2984 static void
2985 gcCAFs(void)
2986 {
2987   StgClosure*  p;
2988   StgClosure** pp;
2989   const StgInfoTable *info;
2990   nat i;
2991
2992   i = 0;
2993   p = caf_list;
2994   pp = &caf_list;
2995
2996   while (p != NULL) {
2997
2998     info = get_itbl(p);
2999
3000     ASSERT(info->type == IND_STATIC);
3001
3002     if (STATIC_LINK(info,p) == NULL) {
3003       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
3004       /* black hole it */
3005       SET_INFO(p,&BLACKHOLE_info);
3006       p = STATIC_LINK2(info,p);
3007       *pp = p;
3008     }
3009     else {
3010       pp = &STATIC_LINK2(info,p);
3011       p = *pp;
3012       i++;
3013     }
3014
3015   }
3016
3017   /*  fprintf(stderr, "%d CAFs live\n", i); */
3018 }
3019 #endif
3020
3021 //@node Lazy black holing, Stack squeezing, Sanity code for CAF garbage collection
3022 //@subsection Lazy black holing
3023
3024 /* -----------------------------------------------------------------------------
3025    Lazy black holing.
3026
3027    Whenever a thread returns to the scheduler after possibly doing
3028    some work, we have to run down the stack and black-hole all the
3029    closures referred to by update frames.
3030    -------------------------------------------------------------------------- */
3031 //@cindex threadLazyBlackHole
3032
3033 static void
3034 threadLazyBlackHole(StgTSO *tso)
3035 {
3036   StgUpdateFrame *update_frame;
3037   StgBlockingQueue *bh;
3038   StgPtr stack_end;
3039
3040   stack_end = &tso->stack[tso->stack_size];
3041   update_frame = tso->su;
3042
3043   while (1) {
3044     switch (get_itbl(update_frame)->type) {
3045
3046     case CATCH_FRAME:
3047       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
3048       break;
3049
3050     case UPDATE_FRAME:
3051       bh = (StgBlockingQueue *)update_frame->updatee;
3052
3053       /* if the thunk is already blackholed, it means we've also
3054        * already blackholed the rest of the thunks on this stack,
3055        * so we can stop early.
3056        *
3057        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3058        * don't interfere with this optimisation.
3059        */
3060       if (bh->header.info == &BLACKHOLE_info) {
3061         return;
3062       }
3063
3064       if (bh->header.info != &BLACKHOLE_BQ_info &&
3065           bh->header.info != &CAF_BLACKHOLE_info) {
3066 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3067         fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
3068 #endif
3069         SET_INFO(bh,&BLACKHOLE_info);
3070       }
3071
3072       update_frame = update_frame->link;
3073       break;
3074
3075     case SEQ_FRAME:
3076       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
3077       break;
3078
3079     case STOP_FRAME:
3080       return;
3081     default:
3082       barf("threadPaused");
3083     }
3084   }
3085 }
3086
3087 //@node Stack squeezing, Pausing a thread, Lazy black holing
3088 //@subsection Stack squeezing
3089
3090 /* -----------------------------------------------------------------------------
3091  * Stack squeezing
3092  *
3093  * Code largely pinched from old RTS, then hacked to bits.  We also do
3094  * lazy black holing here.
3095  *
3096  * -------------------------------------------------------------------------- */
3097 //@cindex threadSqueezeStack
3098
3099 static void
3100 threadSqueezeStack(StgTSO *tso)
3101 {
3102   lnat displacement = 0;
3103   StgUpdateFrame *frame;
3104   StgUpdateFrame *next_frame;                   /* Temporally next */
3105   StgUpdateFrame *prev_frame;                   /* Temporally previous */
3106   StgPtr bottom;
3107   rtsBool prev_was_update_frame;
3108 #if DEBUG
3109   StgUpdateFrame *top_frame;
3110   nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
3111       bhs=0, squeezes=0;
3112   void printObj( StgClosure *obj ); // from Printer.c
3113
3114   top_frame  = tso->su;
3115 #endif
3116
3117   bottom = &(tso->stack[tso->stack_size]);
3118   frame  = tso->su;
3119
3120   /* There must be at least one frame, namely the STOP_FRAME.
3121    */
3122   ASSERT((P_)frame < bottom);
3123
3124   /* Walk down the stack, reversing the links between frames so that
3125    * we can walk back up as we squeeze from the bottom.  Note that
3126    * next_frame and prev_frame refer to next and previous as they were
3127    * added to the stack, rather than the way we see them in this
3128    * walk. (It makes the next loop less confusing.)
3129    *
3130    * Stop if we find an update frame pointing to a black hole
3131    * (see comment in threadLazyBlackHole()).
3132    */
3133
3134   next_frame = NULL;
3135   /* bottom - sizeof(StgStopFrame) is the STOP_FRAME */
3136   while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
3137     prev_frame = frame->link;
3138     frame->link = next_frame;
3139     next_frame = frame;
3140     frame = prev_frame;
3141 #if DEBUG
3142     IF_DEBUG(sanity,
3143              if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
3144                printObj((StgClosure *)prev_frame);
3145                barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
3146                     frame, prev_frame);
3147              })
3148     switch (get_itbl(frame)->type) {
3149     case UPDATE_FRAME: upd_frames++;
3150                        if (frame->updatee->header.info == &BLACKHOLE_info)
3151                          bhs++;
3152                        break;
3153     case STOP_FRAME:  stop_frames++;
3154                       break;
3155     case CATCH_FRAME: catch_frames++;
3156                       break;
3157     case SEQ_FRAME: seq_frames++;
3158                     break;
3159     default:
3160       barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
3161            frame, prev_frame);
3162       printObj((StgClosure *)prev_frame);
3163     }
3164 #endif
3165     if (get_itbl(frame)->type == UPDATE_FRAME
3166         && frame->updatee->header.info == &BLACKHOLE_info) {
3167         break;
3168     }
3169   }
3170
3171   /* Now, we're at the bottom.  Frame points to the lowest update
3172    * frame on the stack, and its link actually points to the frame
3173    * above. We have to walk back up the stack, squeezing out empty
3174    * update frames and turning the pointers back around on the way
3175    * back up.
3176    *
3177    * The bottom-most frame (the STOP_FRAME) has not been altered, and
3178    * we never want to eliminate it anyway.  Just walk one step up
3179    * before starting to squeeze. When you get to the topmost frame,
3180    * remember that there are still some words above it that might have
3181    * to be moved.
3182    */
3183
3184   prev_frame = frame;
3185   frame = next_frame;
3186
3187   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
3188
3189   /*
3190    * Loop through all of the frames (everything except the very
3191    * bottom).  Things are complicated by the fact that we have
3192    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
3193    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
3194    */
3195   while (frame != NULL) {
3196     StgPtr sp;
3197     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
3198     rtsBool is_update_frame;
3199
3200     next_frame = frame->link;
3201     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
3202
3203     /* Check to see if
3204      *   1. both the previous and current frame are update frames
3205      *   2. the current frame is empty
3206      */
3207     if (prev_was_update_frame && is_update_frame &&
3208         (P_)prev_frame == frame_bottom + displacement) {
3209
3210       /* Now squeeze out the current frame */
3211       StgClosure *updatee_keep   = prev_frame->updatee;
3212       StgClosure *updatee_bypass = frame->updatee;
3213
3214 #if DEBUG
3215       IF_DEBUG(gc, fprintf(stderr, "@@ squeezing frame at %p\n", frame));
3216       squeezes++;
3217 #endif
3218
3219       /* Deal with blocking queues.  If both updatees have blocked
3220        * threads, then we should merge the queues into the update
3221        * frame that we're keeping.
3222        *
3223        * Alternatively, we could just wake them up: they'll just go
3224        * straight to sleep on the proper blackhole!  This is less code
3225        * and probably less bug prone, although it's probably much
3226        * slower --SDM
3227        */
3228 #if 0 /* do it properly... */
3229 #  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3230 #    error Unimplemented lazy BH warning.  (KSW 1999-01)
3231 #  endif
3232       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info
3233           || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
3234           ) {
3235         /* Sigh.  It has one.  Don't lose those threads! */
3236           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
3237           /* Urgh.  Two queues.  Merge them. */
3238           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
3239
3240           while (keep_tso->link != END_TSO_QUEUE) {
3241             keep_tso = keep_tso->link;
3242           }
3243           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
3244
3245         } else {
3246           /* For simplicity, just swap the BQ for the BH */
3247           P_ temp = updatee_keep;
3248
3249           updatee_keep = updatee_bypass;
3250           updatee_bypass = temp;
3251
3252           /* Record the swap in the kept frame (below) */
3253           prev_frame->updatee = updatee_keep;
3254         }
3255       }
3256 #endif
3257
3258       TICK_UPD_SQUEEZED();
3259       /* wasn't there something about update squeezing and ticky to be
3260        * sorted out?  oh yes: we aren't counting each enter properly
3261        * in this case.  See the log somewhere.  KSW 1999-04-21
3262        */
3263       UPD_IND_NOLOCK(updatee_bypass, updatee_keep); /* this wakes the threads up */
3264
3265       sp = (P_)frame - 1;       /* sp = stuff to slide */
3266       displacement += sizeofW(StgUpdateFrame);
3267
3268     } else {
3269       /* No squeeze for this frame */
3270       sp = frame_bottom - 1;    /* Keep the current frame */
3271
3272       /* Do lazy black-holing.
3273        */
3274       if (is_update_frame) {
3275         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
3276         if (bh->header.info != &BLACKHOLE_info &&
3277             bh->header.info != &BLACKHOLE_BQ_info &&
3278             bh->header.info != &CAF_BLACKHOLE_info) {
3279 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3280           fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
3281 #endif
3282           SET_INFO(bh,&BLACKHOLE_info);
3283         }
3284       }
3285
3286       /* Fix the link in the current frame (should point to the frame below) */
3287       frame->link = prev_frame;
3288       prev_was_update_frame = is_update_frame;
3289     }
3290
3291     /* Now slide all words from sp up to the next frame */
3292
3293     if (displacement > 0) {
3294       P_ next_frame_bottom;
3295
3296       if (next_frame != NULL)
3297         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
3298       else
3299         next_frame_bottom = tso->sp - 1;
3300
3301 #if DEBUG
3302       IF_DEBUG(gc,
3303                fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
3304                        displacement))
3305 #endif
3306
3307       while (sp >= next_frame_bottom) {
3308         sp[displacement] = *sp;
3309         sp -= 1;
3310       }
3311     }
3312     (P_)prev_frame = (P_)frame + displacement;
3313     frame = next_frame;
3314   }
3315
3316   tso->sp += displacement;
3317   tso->su = prev_frame;
3318 #if DEBUG
3319   IF_DEBUG(gc,
3320            fprintf(stderr, "@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames\n",
3321                    squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
3322 #endif
3323 }
3324
3325 //@node Pausing a thread, Index, Stack squeezing
3326 //@subsection Pausing a thread
3327
3328 /* -----------------------------------------------------------------------------
3329  * Pausing a thread
3330  *
3331  * We have to prepare for GC - this means doing lazy black holing
3332  * here.  We also take the opportunity to do stack squeezing if it's
3333  * turned on.
3334  * -------------------------------------------------------------------------- */
3335 //@cindex threadPaused
3336
3337 void
3338 threadPaused(StgTSO *tso)
3339 {
3340   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
3341     threadSqueezeStack(tso);    /* does black holing too */
3342   else
3343     threadLazyBlackHole(tso);
3344 }
3345
3346 /* -----------------------------------------------------------------------------
3347  * Debugging
3348  * -------------------------------------------------------------------------- */
3349
3350 #if DEBUG
3351 //@cindex printMutOnceList
3352 void
3353 printMutOnceList(generation *gen)
3354 {
3355   StgMutClosure *p, *next;
3356
3357   p = gen->mut_once_list;
3358   next = p->mut_link;
3359
3360   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
3361   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3362     fprintf(stderr, "%p (%s), ",
3363             p, info_type((StgClosure *)p));
3364   }
3365   fputc('\n', stderr);
3366 }
3367
3368 //@cindex printMutableList
3369 void
3370 printMutableList(generation *gen)
3371 {
3372   StgMutClosure *p, *next;
3373
3374   p = gen->saved_mut_list;
3375   next = p->mut_link;
3376
3377   fprintf(stderr, "@@ Mutable list %p: ", gen->saved_mut_list);
3378   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3379     fprintf(stderr, "%p (%s), ",
3380             p, info_type((StgClosure *)p));
3381   }
3382   fputc('\n', stderr);
3383 }
3384 #endif /* DEBUG */
3385
3386 //@node Index,  , Pausing a thread
3387 //@subsection Index
3388
3389 //@index
3390 //* GarbageCollect::  @cindex\s-+GarbageCollect
3391 //* MarkRoot::  @cindex\s-+MarkRoot
3392 //* RevertCAFs::  @cindex\s-+RevertCAFs
3393 //* addBlock::  @cindex\s-+addBlock
3394 //* cleanup_weak_ptr_list::  @cindex\s-+cleanup_weak_ptr_list
3395 //* copy::  @cindex\s-+copy
3396 //* copyPart::  @cindex\s-+copyPart
3397 //* evacuate::  @cindex\s-+evacuate
3398 //* evacuate_large::  @cindex\s-+evacuate_large
3399 //* gcCAFs::  @cindex\s-+gcCAFs
3400 //* isAlive::  @cindex\s-+isAlive
3401 //* mkMutCons::  @cindex\s-+mkMutCons
3402 //* relocate_TSO::  @cindex\s-+relocate_TSO
3403 //* revert_dead_CAFs::  @cindex\s-+revert_dead_CAFs
3404 //* scavenge::  @cindex\s-+scavenge
3405 //* scavenge_large::  @cindex\s-+scavenge_large
3406 //* scavenge_mut_once_list::  @cindex\s-+scavenge_mut_once_list
3407 //* scavenge_mutable_list::  @cindex\s-+scavenge_mutable_list
3408 //* scavenge_one::  @cindex\s-+scavenge_one
3409 //* scavenge_srt::  @cindex\s-+scavenge_srt
3410 //* scavenge_stack::  @cindex\s-+scavenge_stack
3411 //* scavenge_static::  @cindex\s-+scavenge_static
3412 //* threadLazyBlackHole::  @cindex\s-+threadLazyBlackHole
3413 //* threadPaused::  @cindex\s-+threadPaused
3414 //* threadSqueezeStack::  @cindex\s-+threadSqueezeStack
3415 //* traverse_weak_ptr_list::  @cindex\s-+traverse_weak_ptr_list
3416 //* upd_evacuee::  @cindex\s-+upd_evacuee
3417 //* zero_mutable_list::  @cindex\s-+zero_mutable_list
3418 //* zero_static_object_list::  @cindex\s-+zero_static_object_list
3419 //@end index