ghc/rts/GC.c

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