ghc/rts/GC.c

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