ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.75 2000/03/23 14:30:13 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     /* these are special - the payload is a copy of a chunk of stack,
1534        tagging and all. */
1535     return copy(q,pap_sizeW((StgPAP *)q),step);
1536
1537   case EVACUATED:
1538     /* Already evacuated, just return the forwarding address.
1539      * HOWEVER: if the requested destination generation (evac_gen) is
1540      * older than the actual generation (because the object was
1541      * already evacuated to a younger generation) then we have to
1542      * set the failed_to_evac flag to indicate that we couldn't
1543      * manage to promote the object to the desired generation.
1544      */
1545     if (evac_gen > 0) {         /* optimisation */
1546       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1547       if (Bdescr((P_)p)->gen->no < evac_gen) {
1548         IF_DEBUG(gc, belch("@@ evacuate: evac of EVACUATED node %p failed!", p));
1549         failed_to_evac = rtsTrue;
1550         TICK_GC_FAILED_PROMOTION();
1551       }
1552     }
1553     return ((StgEvacuated*)q)->evacuee;
1554
1555   case ARR_WORDS:
1556     {
1557       nat size = arr_words_sizeW((StgArrWords *)q);
1558
1559       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1560         evacuate_large((P_)q, rtsFalse);
1561         return q;
1562       } else {
1563         /* just copy the block */
1564         return copy(q,size,step);
1565       }
1566     }
1567
1568   case MUT_ARR_PTRS:
1569   case MUT_ARR_PTRS_FROZEN:
1570     {
1571       nat size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)q);
1572
1573       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1574         evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1575         to = q;
1576       } else {
1577         /* just copy the block */
1578         to = copy(q,size,step);
1579         if (info->type == MUT_ARR_PTRS) {
1580           recordMutable((StgMutClosure *)to);
1581         }
1582       }
1583       return to;
1584     }
1585
1586   case TSO:
1587     {
1588       StgTSO *tso = (StgTSO *)q;
1589       nat size = tso_sizeW(tso);
1590       int diff;
1591
1592       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1593        */
1594       if (tso->what_next == ThreadRelocated) {
1595         q = (StgClosure *)tso->link;
1596         goto loop;
1597       }
1598
1599       /* Large TSOs don't get moved, so no relocation is required.
1600        */
1601       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1602         evacuate_large((P_)q, rtsTrue);
1603         return q;
1604
1605       /* To evacuate a small TSO, we need to relocate the update frame
1606        * list it contains.
1607        */
1608       } else {
1609         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1610
1611         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1612
1613         /* relocate the stack pointers... */
1614         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1615         new_tso->sp = (StgPtr)new_tso->sp + diff;
1616         new_tso->splim = (StgPtr)new_tso->splim + diff;
1617
1618         relocate_TSO(tso, new_tso);
1619
1620         recordMutable((StgMutClosure *)new_tso);
1621         return (StgClosure *)new_tso;
1622       }
1623     }
1624
1625 #if defined(PAR)
1626   case RBH: // cf. BLACKHOLE_BQ
1627     {
1628       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1629       to = copy(q,BLACKHOLE_sizeW(),step);
1630       //ToDo: derive size etc from reverted IP
1631       //to = copy(q,size,step);
1632       recordMutable((StgMutClosure *)to);
1633       IF_DEBUG(gc,
1634                belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1635                      q, info_type(q), to, info_type(to)));
1636       return to;
1637     }
1638
1639   case BLOCKED_FETCH:
1640     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1641     to = copy(q,sizeofW(StgBlockedFetch),step);
1642     IF_DEBUG(gc,
1643              belch("@@ evacuate: %p (%s) to %p (%s)",
1644                    q, info_type(q), to, info_type(to)));
1645     return to;
1646
1647   case FETCH_ME:
1648     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1649     to = copy(q,sizeofW(StgFetchMe),step);
1650     IF_DEBUG(gc,
1651              belch("@@ evacuate: %p (%s) to %p (%s)",
1652                    q, info_type(q), to, info_type(to)));
1653     return to;
1654
1655   case FETCH_ME_BQ:
1656     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1657     to = copy(q,sizeofW(StgFetchMeBlockingQueue),step);
1658     IF_DEBUG(gc,
1659              belch("@@ evacuate: %p (%s) to %p (%s)",
1660                    q, info_type(q), to, info_type(to)));
1661     return to;
1662 #endif
1663
1664   default:
1665     barf("evacuate: strange closure type %d", (int)(info->type));
1666   }
1667
1668   barf("evacuate");
1669 }
1670
1671 /* -----------------------------------------------------------------------------
1672    relocate_TSO is called just after a TSO has been copied from src to
1673    dest.  It adjusts the update frame list for the new location.
1674    -------------------------------------------------------------------------- */
1675 //@cindex relocate_TSO
1676
1677 StgTSO *
1678 relocate_TSO(StgTSO *src, StgTSO *dest)
1679 {
1680   StgUpdateFrame *su;
1681   StgCatchFrame  *cf;
1682   StgSeqFrame    *sf;
1683   int diff;
1684
1685   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1686
1687   su = dest->su;
1688
1689   while ((P_)su < dest->stack + dest->stack_size) {
1690     switch (get_itbl(su)->type) {
1691
1692       /* GCC actually manages to common up these three cases! */
1693
1694     case UPDATE_FRAME:
1695       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1696       su = su->link;
1697       continue;
1698
1699     case CATCH_FRAME:
1700       cf = (StgCatchFrame *)su;
1701       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1702       su = cf->link;
1703       continue;
1704
1705     case SEQ_FRAME:
1706       sf = (StgSeqFrame *)su;
1707       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1708       su = sf->link;
1709       continue;
1710
1711     case STOP_FRAME:
1712       /* all done! */
1713       break;
1714
1715     default:
1716       barf("relocate_TSO %d", (int)(get_itbl(su)->type));
1717     }
1718     break;
1719   }
1720
1721   return dest;
1722 }
1723
1724 //@node Scavenging, Reverting CAFs, Evacuation
1725 //@subsection Scavenging
1726
1727 //@cindex scavenge_srt
1728
1729 static inline void
1730 scavenge_srt(const StgInfoTable *info)
1731 {
1732   StgClosure **srt, **srt_end;
1733
1734   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1735    * srt field in the info table.  That's ok, because we'll
1736    * never dereference it.
1737    */
1738   srt = (StgClosure **)(info->srt);
1739   srt_end = srt + info->srt_len;
1740   for (; srt < srt_end; srt++) {
1741     /* Special-case to handle references to closures hiding out in DLLs, since
1742        double indirections required to get at those. The code generator knows
1743        which is which when generating the SRT, so it stores the (indirect)
1744        reference to the DLL closure in the table by first adding one to it.
1745        We check for this here, and undo the addition before evacuating it.
1746
1747        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1748        closure that's fixed at link-time, and no extra magic is required.
1749     */
1750 #ifdef ENABLE_WIN32_DLL_SUPPORT
1751     if ( (unsigned long)(*srt) & 0x1 ) {
1752        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
1753     } else {
1754        evacuate(*srt);
1755     }
1756 #else
1757        evacuate(*srt);
1758 #endif
1759   }
1760 }
1761
1762 /* -----------------------------------------------------------------------------
1763    Scavenge a TSO.
1764    -------------------------------------------------------------------------- */
1765
1766 static void
1767 scavengeTSO (StgTSO *tso)
1768 {
1769   /* chase the link field for any TSOs on the same queue */
1770   (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1771   if (   tso->why_blocked == BlockedOnMVar
1772          || tso->why_blocked == BlockedOnBlackHole
1773          || tso->why_blocked == BlockedOnException) {
1774     tso->block_info.closure = evacuate(tso->block_info.closure);
1775   }
1776   if ( tso->blocked_exceptions != NULL ) {
1777     tso->blocked_exceptions =
1778       (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
1779   }
1780   /* scavenge this thread's stack */
1781   scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1782 }
1783
1784 /* -----------------------------------------------------------------------------
1785    Scavenge a given step until there are no more objects in this step
1786    to scavenge.
1787
1788    evac_gen is set by the caller to be either zero (for a step in a
1789    generation < N) or G where G is the generation of the step being
1790    scavenged.
1791
1792    We sometimes temporarily change evac_gen back to zero if we're
1793    scavenging a mutable object where early promotion isn't such a good
1794    idea.
1795    -------------------------------------------------------------------------- */
1796 //@cindex scavenge
1797
1798 static void
1799 scavenge(step *step)
1800 {
1801   StgPtr p, q;
1802   const StgInfoTable *info;
1803   bdescr *bd;
1804   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1805
1806   p = step->scan;
1807   bd = step->scan_bd;
1808
1809   failed_to_evac = rtsFalse;
1810
1811   /* scavenge phase - standard breadth-first scavenging of the
1812    * evacuated objects
1813    */
1814
1815   while (bd != step->hp_bd || p < step->hp) {
1816
1817     /* If we're at the end of this block, move on to the next block */
1818     if (bd != step->hp_bd && p == bd->free) {
1819       bd = bd->link;
1820       p = bd->start;
1821       continue;
1822     }
1823
1824     q = p;                      /* save ptr to object */
1825
1826     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1827                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1828
1829     info = get_itbl((StgClosure *)p);
1830     /*
1831     if (info->type==RBH)
1832       info = REVERT_INFOPTR(info);
1833     */
1834
1835     switch (info -> type) {
1836
1837     case BCO:
1838       {
1839         StgBCO* bco = (StgBCO *)p;
1840         nat i;
1841         for (i = 0; i < bco->n_ptrs; i++) {
1842           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1843         }
1844         p += bco_sizeW(bco);
1845         break;
1846       }
1847
1848     case MVAR:
1849       /* treat MVars specially, because we don't want to evacuate the
1850        * mut_link field in the middle of the closure.
1851        */
1852       {
1853         StgMVar *mvar = ((StgMVar *)p);
1854         evac_gen = 0;
1855         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1856         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1857         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1858         p += sizeofW(StgMVar);
1859         evac_gen = saved_evac_gen;
1860         break;
1861       }
1862
1863     case THUNK_2_0:
1864     case FUN_2_0:
1865       scavenge_srt(info);
1866     case CONSTR_2_0:
1867       ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1868       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1869       p += sizeofW(StgHeader) + 2;
1870       break;
1871
1872     case THUNK_1_0:
1873       scavenge_srt(info);
1874       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1875       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1876       break;
1877
1878     case FUN_1_0:
1879       scavenge_srt(info);
1880     case CONSTR_1_0:
1881       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1882       p += sizeofW(StgHeader) + 1;
1883       break;
1884
1885     case THUNK_0_1:
1886       scavenge_srt(info);
1887       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1888       break;
1889
1890     case FUN_0_1:
1891       scavenge_srt(info);
1892     case CONSTR_0_1:
1893       p += sizeofW(StgHeader) + 1;
1894       break;
1895
1896     case THUNK_0_2:
1897     case FUN_0_2:
1898       scavenge_srt(info);
1899     case CONSTR_0_2:
1900       p += sizeofW(StgHeader) + 2;
1901       break;
1902
1903     case THUNK_1_1:
1904     case FUN_1_1:
1905       scavenge_srt(info);
1906     case CONSTR_1_1:
1907       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1908       p += sizeofW(StgHeader) + 2;
1909       break;
1910
1911     case FUN:
1912     case THUNK:
1913       scavenge_srt(info);
1914       /* fall through */
1915
1916     case CONSTR:
1917     case WEAK:
1918     case FOREIGN:
1919     case STABLE_NAME:
1920       {
1921         StgPtr end;
1922
1923         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1924         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1925           (StgClosure *)*p = evacuate((StgClosure *)*p);
1926         }
1927         p += info->layout.payload.nptrs;
1928         break;
1929       }
1930
1931     case IND_PERM:
1932       if (step->gen->no != 0) {
1933         SET_INFO(((StgClosure *)p), &IND_OLDGEN_PERM_info);
1934       }
1935       /* fall through */
1936     case IND_OLDGEN_PERM:
1937       ((StgIndOldGen *)p)->indirectee =
1938         evacuate(((StgIndOldGen *)p)->indirectee);
1939       if (failed_to_evac) {
1940         failed_to_evac = rtsFalse;
1941         recordOldToNewPtrs((StgMutClosure *)p);
1942       }
1943       p += sizeofW(StgIndOldGen);
1944       break;
1945
1946     case CAF_UNENTERED:
1947       {
1948         StgCAF *caf = (StgCAF *)p;
1949
1950         caf->body = evacuate(caf->body);
1951         if (failed_to_evac) {
1952           failed_to_evac = rtsFalse;
1953           recordOldToNewPtrs((StgMutClosure *)p);
1954         } else {
1955           caf->mut_link = NULL;
1956         }
1957         p += sizeofW(StgCAF);
1958         break;
1959       }
1960
1961     case CAF_ENTERED:
1962       {
1963         StgCAF *caf = (StgCAF *)p;
1964
1965         caf->body = evacuate(caf->body);
1966         caf->value = evacuate(caf->value);
1967         if (failed_to_evac) {
1968           failed_to_evac = rtsFalse;
1969           recordOldToNewPtrs((StgMutClosure *)p);
1970         } else {
1971           caf->mut_link = NULL;
1972         }
1973         p += sizeofW(StgCAF);
1974         break;
1975       }
1976
1977     case MUT_VAR:
1978       /* ignore MUT_CONSs */
1979       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1980         evac_gen = 0;
1981         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1982         evac_gen = saved_evac_gen;
1983       }
1984       p += sizeofW(StgMutVar);
1985       break;
1986
1987     case CAF_BLACKHOLE:
1988     case SE_CAF_BLACKHOLE:
1989     case SE_BLACKHOLE:
1990     case BLACKHOLE:
1991         p += BLACKHOLE_sizeW();
1992         break;
1993
1994     case BLACKHOLE_BQ:
1995       {
1996         StgBlockingQueue *bh = (StgBlockingQueue *)p;
1997         (StgClosure *)bh->blocking_queue =
1998           evacuate((StgClosure *)bh->blocking_queue);
1999         if (failed_to_evac) {
2000           failed_to_evac = rtsFalse;
2001           recordMutable((StgMutClosure *)bh);
2002         }
2003         p += BLACKHOLE_sizeW();
2004         break;
2005       }
2006
2007     case THUNK_SELECTOR:
2008       {
2009         StgSelector *s = (StgSelector *)p;
2010         s->selectee = evacuate(s->selectee);
2011         p += THUNK_SELECTOR_sizeW();
2012         break;
2013       }
2014
2015     case IND:
2016     case IND_OLDGEN:
2017       barf("scavenge:IND???\n");
2018
2019     case CONSTR_INTLIKE:
2020     case CONSTR_CHARLIKE:
2021     case CONSTR_STATIC:
2022     case CONSTR_NOCAF_STATIC:
2023     case THUNK_STATIC:
2024     case FUN_STATIC:
2025     case IND_STATIC:
2026       /* Shouldn't see a static object here. */
2027       barf("scavenge: STATIC object\n");
2028
2029     case RET_BCO:
2030     case RET_SMALL:
2031     case RET_VEC_SMALL:
2032     case RET_BIG:
2033     case RET_VEC_BIG:
2034     case RET_DYN:
2035     case UPDATE_FRAME:
2036     case STOP_FRAME:
2037     case CATCH_FRAME:
2038     case SEQ_FRAME:
2039       /* Shouldn't see stack frames here. */
2040       barf("scavenge: stack frame\n");
2041
2042     case AP_UPD: /* same as PAPs */
2043     case PAP:
2044       /* Treat a PAP just like a section of stack, not forgetting to
2045        * evacuate the function pointer too...
2046        */
2047       {
2048         StgPAP* pap = (StgPAP *)p;
2049
2050         pap->fun = evacuate(pap->fun);
2051         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2052         p += pap_sizeW(pap);
2053         break;
2054       }
2055
2056     case ARR_WORDS:
2057       /* nothing to follow */
2058       p += arr_words_sizeW((StgArrWords *)p);
2059       break;
2060
2061     case MUT_ARR_PTRS:
2062       /* follow everything */
2063       {
2064         StgPtr next;
2065
2066         evac_gen = 0;           /* repeatedly mutable */
2067         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2068         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2069           (StgClosure *)*p = evacuate((StgClosure *)*p);
2070         }
2071         evac_gen = saved_evac_gen;
2072         break;
2073       }
2074
2075     case MUT_ARR_PTRS_FROZEN:
2076       /* follow everything */
2077       {
2078         StgPtr start = p, next;
2079
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         if (failed_to_evac) {
2085           /* we can do this easier... */
2086           recordMutable((StgMutClosure *)start);
2087           failed_to_evac = rtsFalse;
2088         }
2089         break;
2090       }
2091
2092     case TSO:
2093       {
2094         StgTSO *tso = (StgTSO *)p;
2095         evac_gen = 0;
2096         scavengeTSO(tso);
2097         evac_gen = saved_evac_gen;
2098         p += tso_sizeW(tso);
2099         break;
2100       }
2101
2102 #if defined(PAR)
2103     case RBH: // cf. BLACKHOLE_BQ
2104       {
2105         // nat size, ptrs, nonptrs, vhs;
2106         // char str[80];
2107         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2108         StgRBH *rbh = (StgRBH *)p;
2109         (StgClosure *)rbh->blocking_queue =
2110           evacuate((StgClosure *)rbh->blocking_queue);
2111         if (failed_to_evac) {
2112           failed_to_evac = rtsFalse;
2113           recordMutable((StgMutClosure *)rbh);
2114         }
2115         IF_DEBUG(gc,
2116                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2117                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2118         // ToDo: use size of reverted closure here!
2119         p += BLACKHOLE_sizeW();
2120         break;
2121       }
2122
2123     case BLOCKED_FETCH:
2124       {
2125         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2126         /* follow the pointer to the node which is being demanded */
2127         (StgClosure *)bf->node =
2128           evacuate((StgClosure *)bf->node);
2129         /* follow the link to the rest of the blocking queue */
2130         (StgClosure *)bf->link =
2131           evacuate((StgClosure *)bf->link);
2132         if (failed_to_evac) {
2133           failed_to_evac = rtsFalse;
2134           recordMutable((StgMutClosure *)bf);
2135         }
2136         IF_DEBUG(gc,
2137                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2138                      bf, info_type((StgClosure *)bf),
2139                      bf->node, info_type(bf->node)));
2140         p += sizeofW(StgBlockedFetch);
2141         break;
2142       }
2143
2144     case FETCH_ME:
2145       IF_DEBUG(gc,
2146                belch("@@ scavenge: HWL claims nothing to do for %p (%s)",
2147                      p, info_type((StgClosure *)p)));
2148       p += sizeofW(StgFetchMe);
2149       break; // nothing to do in this case
2150
2151     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2152       {
2153         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2154         (StgClosure *)fmbq->blocking_queue =
2155           evacuate((StgClosure *)fmbq->blocking_queue);
2156         if (failed_to_evac) {
2157           failed_to_evac = rtsFalse;
2158           recordMutable((StgMutClosure *)fmbq);
2159         }
2160         IF_DEBUG(gc,
2161                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2162                      p, info_type((StgClosure *)p)));
2163         p += sizeofW(StgFetchMeBlockingQueue);
2164         break;
2165       }
2166 #endif
2167
2168     case EVACUATED:
2169       barf("scavenge: unimplemented/strange closure type\n");
2170
2171     default:
2172       barf("scavenge");
2173     }
2174
2175     /* If we didn't manage to promote all the objects pointed to by
2176      * the current object, then we have to designate this object as
2177      * mutable (because it contains old-to-new generation pointers).
2178      */
2179     if (failed_to_evac) {
2180       mkMutCons((StgClosure *)q, &generations[evac_gen]);
2181       failed_to_evac = rtsFalse;
2182     }
2183   }
2184
2185   step->scan_bd = bd;
2186   step->scan = p;
2187 }
2188
2189 /* -----------------------------------------------------------------------------
2190    Scavenge one object.
2191
2192    This is used for objects that are temporarily marked as mutable
2193    because they contain old-to-new generation pointers.  Only certain
2194    objects can have this property.
2195    -------------------------------------------------------------------------- */
2196 //@cindex scavenge_one
2197
2198 static rtsBool
2199 scavenge_one(StgClosure *p)
2200 {
2201   const StgInfoTable *info;
2202   rtsBool no_luck;
2203
2204   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2205                || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2206
2207   info = get_itbl(p);
2208
2209   /* ngoq moHqu'!
2210   if (info->type==RBH)
2211     info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2212   */
2213
2214   switch (info -> type) {
2215
2216   case FUN:
2217   case FUN_1_0:                 /* hardly worth specialising these guys */
2218   case FUN_0_1:
2219   case FUN_1_1:
2220   case FUN_0_2:
2221   case FUN_2_0:
2222   case THUNK:
2223   case THUNK_1_0:
2224   case THUNK_0_1:
2225   case THUNK_1_1:
2226   case THUNK_0_2:
2227   case THUNK_2_0:
2228   case CONSTR:
2229   case CONSTR_1_0:
2230   case CONSTR_0_1:
2231   case CONSTR_1_1:
2232   case CONSTR_0_2:
2233   case CONSTR_2_0:
2234   case WEAK:
2235   case FOREIGN:
2236   case IND_PERM:
2237   case IND_OLDGEN_PERM:
2238   case CAF_UNENTERED:
2239     {
2240       StgPtr q, end;
2241
2242       end = (P_)p->payload + info->layout.payload.ptrs;
2243       for (q = (P_)p->payload; q < end; q++) {
2244         (StgClosure *)*q = evacuate((StgClosure *)*q);
2245       }
2246       break;
2247     }
2248
2249   case CAF_BLACKHOLE:
2250   case SE_CAF_BLACKHOLE:
2251   case SE_BLACKHOLE:
2252   case BLACKHOLE:
2253       break;
2254
2255   case THUNK_SELECTOR:
2256     {
2257       StgSelector *s = (StgSelector *)p;
2258       s->selectee = evacuate(s->selectee);
2259       break;
2260     }
2261
2262   case AP_UPD: /* same as PAPs */
2263   case PAP:
2264     /* Treat a PAP just like a section of stack, not forgetting to
2265      * evacuate the function pointer too...
2266      */
2267     {
2268       StgPAP* pap = (StgPAP *)p;
2269
2270       pap->fun = evacuate(pap->fun);
2271       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2272       break;
2273     }
2274
2275   case IND_OLDGEN:
2276     /* This might happen if for instance a MUT_CONS was pointing to a
2277      * THUNK which has since been updated.  The IND_OLDGEN will
2278      * be on the mutable list anyway, so we don't need to do anything
2279      * here.
2280      */
2281     break;
2282
2283   default:
2284     barf("scavenge_one: strange object");
2285   }
2286
2287   no_luck = failed_to_evac;
2288   failed_to_evac = rtsFalse;
2289   return (no_luck);
2290 }
2291
2292
2293 /* -----------------------------------------------------------------------------
2294    Scavenging mutable lists.
2295
2296    We treat the mutable list of each generation > N (i.e. all the
2297    generations older than the one being collected) as roots.  We also
2298    remove non-mutable objects from the mutable list at this point.
2299    -------------------------------------------------------------------------- */
2300 //@cindex scavenge_mut_once_list
2301
2302 static void
2303 scavenge_mut_once_list(generation *gen)
2304 {
2305   const StgInfoTable *info;
2306   StgMutClosure *p, *next, *new_list;
2307
2308   p = gen->mut_once_list;
2309   new_list = END_MUT_LIST;
2310   next = p->mut_link;
2311
2312   evac_gen = gen->no;
2313   failed_to_evac = rtsFalse;
2314
2315   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2316
2317     /* make sure the info pointer is into text space */
2318     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2319                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2320
2321     info = get_itbl(p);
2322     /*
2323     if (info->type==RBH)
2324       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2325     */
2326     switch(info->type) {
2327
2328     case IND_OLDGEN:
2329     case IND_OLDGEN_PERM:
2330     case IND_STATIC:
2331       /* Try to pull the indirectee into this generation, so we can
2332        * remove the indirection from the mutable list.
2333        */
2334       ((StgIndOldGen *)p)->indirectee =
2335         evacuate(((StgIndOldGen *)p)->indirectee);
2336
2337 #ifdef DEBUG
2338       if (RtsFlags.DebugFlags.gc)
2339       /* Debugging code to print out the size of the thing we just
2340        * promoted
2341        */
2342       {
2343         StgPtr start = gen->steps[0].scan;
2344         bdescr *start_bd = gen->steps[0].scan_bd;
2345         nat size = 0;
2346         scavenge(&gen->steps[0]);
2347         if (start_bd != gen->steps[0].scan_bd) {
2348           size += (P_)BLOCK_ROUND_UP(start) - start;
2349           start_bd = start_bd->link;
2350           while (start_bd != gen->steps[0].scan_bd) {
2351             size += BLOCK_SIZE_W;
2352             start_bd = start_bd->link;
2353           }
2354           size += gen->steps[0].scan -
2355             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
2356         } else {
2357           size = gen->steps[0].scan - start;
2358         }
2359         fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
2360       }
2361 #endif
2362
2363       /* failed_to_evac might happen if we've got more than two
2364        * generations, we're collecting only generation 0, the
2365        * indirection resides in generation 2 and the indirectee is
2366        * in generation 1.
2367        */
2368       if (failed_to_evac) {
2369         failed_to_evac = rtsFalse;
2370         p->mut_link = new_list;
2371         new_list = p;
2372       } else {
2373         /* the mut_link field of an IND_STATIC is overloaded as the
2374          * static link field too (it just so happens that we don't need
2375          * both at the same time), so we need to NULL it out when
2376          * removing this object from the mutable list because the static
2377          * link fields are all assumed to be NULL before doing a major
2378          * collection.
2379          */
2380         p->mut_link = NULL;
2381       }
2382       continue;
2383
2384     case MUT_VAR:
2385       /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
2386        * it from the mutable list if possible by promoting whatever it
2387        * points to.
2388        */
2389       ASSERT(p->header.info == &MUT_CONS_info);
2390       if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
2391         /* didn't manage to promote everything, so put the
2392          * MUT_CONS back on the list.
2393          */
2394         p->mut_link = new_list;
2395         new_list = p;
2396       }
2397       continue;
2398
2399     case CAF_ENTERED:
2400       {
2401         StgCAF *caf = (StgCAF *)p;
2402         caf->body  = evacuate(caf->body);
2403         caf->value = evacuate(caf->value);
2404         if (failed_to_evac) {
2405           failed_to_evac = rtsFalse;
2406           p->mut_link = new_list;
2407           new_list = p;
2408         } else {
2409           p->mut_link = NULL;
2410         }
2411       }
2412       continue;
2413
2414     case CAF_UNENTERED:
2415       {
2416         StgCAF *caf = (StgCAF *)p;
2417         caf->body  = evacuate(caf->body);
2418         if (failed_to_evac) {
2419           failed_to_evac = rtsFalse;
2420           p->mut_link = new_list;
2421           new_list = p;
2422         } else {
2423           p->mut_link = NULL;
2424         }
2425       }
2426       continue;
2427
2428     default:
2429       /* shouldn't have anything else on the mutables list */
2430       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
2431     }
2432   }
2433
2434   gen->mut_once_list = new_list;
2435 }
2436
2437 //@cindex scavenge_mutable_list
2438
2439 static void
2440 scavenge_mutable_list(generation *gen)
2441 {
2442   const StgInfoTable *info;
2443   StgMutClosure *p, *next;
2444
2445   p = gen->saved_mut_list;
2446   next = p->mut_link;
2447
2448   evac_gen = 0;
2449   failed_to_evac = rtsFalse;
2450
2451   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2452
2453     /* make sure the info pointer is into text space */
2454     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2455                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2456
2457     info = get_itbl(p);
2458     /*
2459     if (info->type==RBH)
2460       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2461     */
2462     switch(info->type) {
2463
2464     case MUT_ARR_PTRS_FROZEN:
2465       /* remove this guy from the mutable list, but follow the ptrs
2466        * anyway (and make sure they get promoted to this gen).
2467        */
2468       {
2469         StgPtr end, q;
2470
2471         IF_DEBUG(gc,
2472                  belch("@@ scavenge_mut_list: scavenging MUT_ARR_PTRS_FROZEN %p; size: %#x ; next: %p",
2473                        p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p), p->mut_link));
2474
2475         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2476         evac_gen = gen->no;
2477         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2478           (StgClosure *)*q = evacuate((StgClosure *)*q);
2479         }
2480         evac_gen = 0;
2481
2482         if (failed_to_evac) {
2483           failed_to_evac = rtsFalse;
2484           p->mut_link = gen->mut_list;
2485           gen->mut_list = p;
2486         }
2487         continue;
2488       }
2489
2490     case MUT_ARR_PTRS:
2491       /* follow everything */
2492       p->mut_link = gen->mut_list;
2493       gen->mut_list = p;
2494       {
2495         StgPtr end, q;
2496
2497         IF_DEBUG(gc,
2498                  belch("@@ scavenge_mut_list: scavenging MUT_ARR_PTRS %p; size: %#x ; next: %p",
2499                        p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p), p->mut_link));
2500
2501         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2502         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2503           (StgClosure *)*q = evacuate((StgClosure *)*q);
2504         }
2505         continue;
2506       }
2507
2508     case MUT_VAR:
2509       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2510        * it from the mutable list if possible by promoting whatever it
2511        * points to.
2512        */
2513         IF_DEBUG(gc,
2514                  belch("@@ scavenge_mut_list: scavenging MUT_VAR %p; var: %p ; next: %p",
2515                        p, ((StgMutVar *)p)->var, p->mut_link));
2516
2517       ASSERT(p->header.info != &MUT_CONS_info);
2518       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2519       p->mut_link = gen->mut_list;
2520       gen->mut_list = p;
2521       continue;
2522
2523     case MVAR:
2524       {
2525         StgMVar *mvar = (StgMVar *)p;
2526
2527         IF_DEBUG(gc,
2528                  belch("@@ scavenge_mut_list: scavenging MAVR %p; head: %p; tail: %p; value: %p ; next: %p",
2529                        mvar, mvar->head, mvar->tail, mvar->value, p->mut_link));
2530
2531         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2532         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2533         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2534         p->mut_link = gen->mut_list;
2535         gen->mut_list = p;
2536         continue;
2537       }
2538
2539     case TSO:
2540       {
2541         StgTSO *tso = (StgTSO *)p;
2542
2543         scavengeTSO(tso);
2544
2545         /* Don't take this TSO off the mutable list - it might still
2546          * point to some younger objects (because we set evac_gen to 0
2547          * above).
2548          */
2549         tso->mut_link = gen->mut_list;
2550         gen->mut_list = (StgMutClosure *)tso;
2551         continue;
2552       }
2553
2554     case BLACKHOLE_BQ:
2555       {
2556         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2557
2558         IF_DEBUG(gc,
2559                  belch("@@ scavenge_mut_list: scavenging BLACKHOLE_BQ (%p); next: %p",
2560                        p, p->mut_link));
2561
2562         (StgClosure *)bh->blocking_queue =
2563           evacuate((StgClosure *)bh->blocking_queue);
2564         p->mut_link = gen->mut_list;
2565         gen->mut_list = p;
2566         continue;
2567       }
2568
2569       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
2570        */
2571     case IND_OLDGEN:
2572     case IND_OLDGEN_PERM:
2573       /* Try to pull the indirectee into this generation, so we can
2574        * remove the indirection from the mutable list.
2575        */
2576       evac_gen = gen->no;
2577       ((StgIndOldGen *)p)->indirectee =
2578         evacuate(((StgIndOldGen *)p)->indirectee);
2579       evac_gen = 0;
2580
2581       if (failed_to_evac) {
2582         failed_to_evac = rtsFalse;
2583         p->mut_link = gen->mut_once_list;
2584         gen->mut_once_list = p;
2585       } else {
2586         p->mut_link = NULL;
2587       }
2588       continue;
2589
2590     // HWL: old PAR code deleted here
2591
2592     default:
2593       /* shouldn't have anything else on the mutables list */
2594       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
2595     }
2596   }
2597 }
2598
2599 //@cindex scavenge_static
2600
2601 static void
2602 scavenge_static(void)
2603 {
2604   StgClosure* p = static_objects;
2605   const StgInfoTable *info;
2606
2607   /* Always evacuate straight to the oldest generation for static
2608    * objects */
2609   evac_gen = oldest_gen->no;
2610
2611   /* keep going until we've scavenged all the objects on the linked
2612      list... */
2613   while (p != END_OF_STATIC_LIST) {
2614
2615     info = get_itbl(p);
2616     /*
2617     if (info->type==RBH)
2618       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2619     */
2620     /* make sure the info pointer is into text space */
2621     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2622                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2623
2624     /* Take this object *off* the static_objects list,
2625      * and put it on the scavenged_static_objects list.
2626      */
2627     static_objects = STATIC_LINK(info,p);
2628     STATIC_LINK(info,p) = scavenged_static_objects;
2629     scavenged_static_objects = p;
2630
2631     switch (info -> type) {
2632
2633     case IND_STATIC:
2634       {
2635         StgInd *ind = (StgInd *)p;
2636         ind->indirectee = evacuate(ind->indirectee);
2637
2638         /* might fail to evacuate it, in which case we have to pop it
2639          * back on the mutable list (and take it off the
2640          * scavenged_static list because the static link and mut link
2641          * pointers are one and the same).
2642          */
2643         if (failed_to_evac) {
2644           failed_to_evac = rtsFalse;
2645           scavenged_static_objects = STATIC_LINK(info,p);
2646           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2647           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2648         }
2649         break;
2650       }
2651
2652     case THUNK_STATIC:
2653     case FUN_STATIC:
2654       scavenge_srt(info);
2655       /* fall through */
2656
2657     case CONSTR_STATIC:
2658       {
2659         StgPtr q, next;
2660
2661         next = (P_)p->payload + info->layout.payload.ptrs;
2662         /* evacuate the pointers */
2663         for (q = (P_)p->payload; q < next; q++) {
2664           (StgClosure *)*q = evacuate((StgClosure *)*q);
2665         }
2666         break;
2667       }
2668
2669     default:
2670       barf("scavenge_static");
2671     }
2672
2673     ASSERT(failed_to_evac == rtsFalse);
2674
2675     /* get the next static object from the list.  Remeber, there might
2676      * be more stuff on this list now that we've done some evacuating!
2677      * (static_objects is a global)
2678      */
2679     p = static_objects;
2680   }
2681 }
2682
2683 /* -----------------------------------------------------------------------------
2684    scavenge_stack walks over a section of stack and evacuates all the
2685    objects pointed to by it.  We can use the same code for walking
2686    PAPs, since these are just sections of copied stack.
2687    -------------------------------------------------------------------------- */
2688 //@cindex scavenge_stack
2689
2690 static void
2691 scavenge_stack(StgPtr p, StgPtr stack_end)
2692 {
2693   StgPtr q;
2694   const StgInfoTable* info;
2695   StgWord32 bitmap;
2696
2697   IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
2698
2699   /*
2700    * Each time around this loop, we are looking at a chunk of stack
2701    * that starts with either a pending argument section or an
2702    * activation record.
2703    */
2704
2705   while (p < stack_end) {
2706     q = *(P_ *)p;
2707
2708     /* If we've got a tag, skip over that many words on the stack */
2709     if (IS_ARG_TAG((W_)q)) {
2710       p += ARG_SIZE(q);
2711       p++; continue;
2712     }
2713
2714     /* Is q a pointer to a closure?
2715      */
2716     if (! LOOKS_LIKE_GHC_INFO(q) ) {
2717 #ifdef DEBUG
2718       if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  /* Is it a static closure? */
2719         ASSERT(closure_STATIC((StgClosure *)q));
2720       }
2721       /* otherwise, must be a pointer into the allocation space. */
2722 #endif
2723
2724       (StgClosure *)*p = evacuate((StgClosure *)q);
2725       p++;
2726       continue;
2727     }
2728
2729     /*
2730      * Otherwise, q must be the info pointer of an activation
2731      * record.  All activation records have 'bitmap' style layout
2732      * info.
2733      */
2734     info  = get_itbl((StgClosure *)p);
2735
2736     switch (info->type) {
2737
2738       /* Dynamic bitmap: the mask is stored on the stack */
2739     case RET_DYN:
2740       bitmap = ((StgRetDyn *)p)->liveness;
2741       p      = (P_)&((StgRetDyn *)p)->payload[0];
2742       goto small_bitmap;
2743
2744       /* probably a slow-entry point return address: */
2745     case FUN:
2746     case FUN_STATIC:
2747       {
2748 #if 0
2749         StgPtr old_p = p;
2750         p++; p++;
2751         IF_DEBUG(sanity,
2752                  belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
2753                        old_p, p, old_p+1));
2754 #else
2755       p++; /* what if FHS!=1 !? -- HWL */
2756 #endif
2757       goto follow_srt;
2758       }
2759
2760       /* Specialised code for update frames, since they're so common.
2761        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2762        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2763        */
2764     case UPDATE_FRAME:
2765       {
2766         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2767         StgClosure *to;
2768         nat type = get_itbl(frame->updatee)->type;
2769
2770         p += sizeofW(StgUpdateFrame);
2771         if (type == EVACUATED) {
2772           frame->updatee = evacuate(frame->updatee);
2773           continue;
2774         } else {
2775           bdescr *bd = Bdescr((P_)frame->updatee);
2776           step *step;
2777           if (bd->gen->no > N) {
2778             if (bd->gen->no < evac_gen) {
2779               failed_to_evac = rtsTrue;
2780             }
2781             continue;
2782           }
2783
2784           /* Don't promote blackholes */
2785           step = bd->step;
2786           if (!(step->gen->no == 0 &&
2787                 step->no != 0 &&
2788                 step->no == step->gen->n_steps-1)) {
2789             step = step->to;
2790           }
2791
2792           switch (type) {
2793           case BLACKHOLE:
2794           case CAF_BLACKHOLE:
2795             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2796                           sizeofW(StgHeader), step);
2797             frame->updatee = to;
2798             continue;
2799           case BLACKHOLE_BQ:
2800             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2801             frame->updatee = to;
2802             recordMutable((StgMutClosure *)to);
2803             continue;
2804           default:
2805             /* will never be SE_{,CAF_}BLACKHOLE, since we
2806                don't push an update frame for single-entry thunks.  KSW 1999-01. */
2807             barf("scavenge_stack: UPDATE_FRAME updatee");
2808           }
2809         }
2810       }
2811
2812       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2813     case STOP_FRAME:
2814     case CATCH_FRAME:
2815     case SEQ_FRAME:
2816     case RET_BCO:
2817     case RET_SMALL:
2818     case RET_VEC_SMALL:
2819       bitmap = info->layout.bitmap;
2820       p++;
2821       /* this assumes that the payload starts immediately after the info-ptr */
2822     small_bitmap:
2823       while (bitmap != 0) {
2824         if ((bitmap & 1) == 0) {
2825           (StgClosure *)*p = evacuate((StgClosure *)*p);
2826         }
2827         p++;
2828         bitmap = bitmap >> 1;
2829       }
2830
2831     follow_srt:
2832       scavenge_srt(info);
2833       continue;
2834
2835       /* large bitmap (> 32 entries) */
2836     case RET_BIG:
2837     case RET_VEC_BIG:
2838       {
2839         StgPtr q;
2840         StgLargeBitmap *large_bitmap;
2841         nat i;
2842
2843         large_bitmap = info->layout.large_bitmap;
2844         p++;
2845
2846         for (i=0; i<large_bitmap->size; i++) {
2847           bitmap = large_bitmap->bitmap[i];
2848           q = p + sizeof(W_) * 8;
2849           while (bitmap != 0) {
2850             if ((bitmap & 1) == 0) {
2851               (StgClosure *)*p = evacuate((StgClosure *)*p);
2852             }
2853             p++;
2854             bitmap = bitmap >> 1;
2855           }
2856           if (i+1 < large_bitmap->size) {
2857             while (p < q) {
2858               (StgClosure *)*p = evacuate((StgClosure *)*p);
2859               p++;
2860             }
2861           }
2862         }
2863
2864         /* and don't forget to follow the SRT */
2865         goto follow_srt;
2866       }
2867
2868     default:
2869       barf("scavenge_stack: weird activation record found on stack.\n");
2870     }
2871   }
2872 }
2873
2874 /*-----------------------------------------------------------------------------
2875   scavenge the large object list.
2876
2877   evac_gen set by caller; similar games played with evac_gen as with
2878   scavenge() - see comment at the top of scavenge().  Most large
2879   objects are (repeatedly) mutable, so most of the time evac_gen will
2880   be zero.
2881   --------------------------------------------------------------------------- */
2882 //@cindex scavenge_large
2883
2884 static void
2885 scavenge_large(step *step)
2886 {
2887   bdescr *bd;
2888   StgPtr p;
2889   const StgInfoTable* info;
2890   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2891
2892   evac_gen = 0;                 /* most objects are mutable */
2893   bd = step->new_large_objects;
2894
2895   for (; bd != NULL; bd = step->new_large_objects) {
2896
2897     /* take this object *off* the large objects list and put it on
2898      * the scavenged large objects list.  This is so that we can
2899      * treat new_large_objects as a stack and push new objects on
2900      * the front when evacuating.
2901      */
2902     step->new_large_objects = bd->link;
2903     dbl_link_onto(bd, &step->scavenged_large_objects);
2904
2905     p = bd->start;
2906     info  = get_itbl((StgClosure *)p);
2907
2908     switch (info->type) {
2909
2910     /* only certain objects can be "large"... */
2911
2912     case ARR_WORDS:
2913       /* nothing to follow */
2914       continue;
2915
2916     case MUT_ARR_PTRS:
2917       /* follow everything */
2918       {
2919         StgPtr next;
2920
2921         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2922         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2923           (StgClosure *)*p = evacuate((StgClosure *)*p);
2924         }
2925         continue;
2926       }
2927
2928     case MUT_ARR_PTRS_FROZEN:
2929       /* follow everything */
2930       {
2931         StgPtr start = p, next;
2932
2933         evac_gen = saved_evac_gen; /* not really mutable */
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         evac_gen = 0;
2939         if (failed_to_evac) {
2940           recordMutable((StgMutClosure *)start);
2941         }
2942         continue;
2943       }
2944
2945     case BCO:
2946       {
2947         StgBCO* bco = (StgBCO *)p;
2948         nat i;
2949         evac_gen = saved_evac_gen;
2950         for (i = 0; i < bco->n_ptrs; i++) {
2951           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2952         }
2953         evac_gen = 0;
2954         continue;
2955       }
2956
2957     case TSO:
2958         scavengeTSO((StgTSO *)p);
2959         // HWL: old PAR code deleted here
2960         continue;
2961
2962     default:
2963       barf("scavenge_large: unknown/strange object");
2964     }
2965   }
2966 }
2967
2968 //@cindex zero_static_object_list
2969
2970 static void
2971 zero_static_object_list(StgClosure* first_static)
2972 {
2973   StgClosure* p;
2974   StgClosure* link;
2975   const StgInfoTable *info;
2976
2977   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2978     info = get_itbl(p);
2979     link = STATIC_LINK(info, p);
2980     STATIC_LINK(info,p) = NULL;
2981   }
2982 }
2983
2984 /* This function is only needed because we share the mutable link
2985  * field with the static link field in an IND_STATIC, so we have to
2986  * zero the mut_link field before doing a major GC, which needs the
2987  * static link field.
2988  *
2989  * It doesn't do any harm to zero all the mutable link fields on the
2990  * mutable list.
2991  */
2992 //@cindex zero_mutable_list
2993
2994 static void
2995 zero_mutable_list( StgMutClosure *first )
2996 {
2997   StgMutClosure *next, *c;
2998
2999   for (c = first; c != END_MUT_LIST; c = next) {
3000     next = c->mut_link;
3001     c->mut_link = NULL;
3002   }
3003 }
3004
3005 //@node Reverting CAFs, Sanity code for CAF garbage collection, Scavenging
3006 //@subsection Reverting CAFs
3007
3008 /* -----------------------------------------------------------------------------
3009    Reverting CAFs
3010    -------------------------------------------------------------------------- */
3011 //@cindex RevertCAFs
3012
3013 void RevertCAFs(void)
3014 {
3015   while (enteredCAFs != END_CAF_LIST) {
3016     StgCAF* caf = enteredCAFs;
3017
3018     enteredCAFs = caf->link;
3019     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
3020     SET_INFO(caf,&CAF_UNENTERED_info);
3021     caf->value = (StgClosure *)0xdeadbeef;
3022     caf->link  = (StgCAF *)0xdeadbeef;
3023   }
3024   enteredCAFs = END_CAF_LIST;
3025 }
3026
3027 //@cindex revert_dead_CAFs
3028
3029 void revert_dead_CAFs(void)
3030 {
3031     StgCAF* caf = enteredCAFs;
3032     enteredCAFs = END_CAF_LIST;
3033     while (caf != END_CAF_LIST) {
3034         StgCAF *next, *new;
3035         next = caf->link;
3036         new = (StgCAF*)isAlive((StgClosure*)caf);
3037         if (new) {
3038            new->link = enteredCAFs;
3039            enteredCAFs = new;
3040         } else {
3041            /* ASSERT(0); */
3042            SET_INFO(caf,&CAF_UNENTERED_info);
3043            caf->value = (StgClosure*)0xdeadbeef;
3044            caf->link  = (StgCAF*)0xdeadbeef;
3045         }
3046         caf = next;
3047     }
3048 }
3049
3050 //@node Sanity code for CAF garbage collection, Lazy black holing, Reverting CAFs
3051 //@subsection Sanity code for CAF garbage collection
3052
3053 /* -----------------------------------------------------------------------------
3054    Sanity code for CAF garbage collection.
3055
3056    With DEBUG turned on, we manage a CAF list in addition to the SRT
3057    mechanism.  After GC, we run down the CAF list and blackhole any
3058    CAFs which have been garbage collected.  This means we get an error
3059    whenever the program tries to enter a garbage collected CAF.
3060
3061    Any garbage collected CAFs are taken off the CAF list at the same
3062    time.
3063    -------------------------------------------------------------------------- */
3064
3065 #ifdef DEBUG
3066 //@cindex gcCAFs
3067
3068 static void
3069 gcCAFs(void)
3070 {
3071   StgClosure*  p;
3072   StgClosure** pp;
3073   const StgInfoTable *info;
3074   nat i;
3075
3076   i = 0;
3077   p = caf_list;
3078   pp = &caf_list;
3079
3080   while (p != NULL) {
3081
3082     info = get_itbl(p);
3083
3084     ASSERT(info->type == IND_STATIC);
3085
3086     if (STATIC_LINK(info,p) == NULL) {
3087       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
3088       /* black hole it */
3089       SET_INFO(p,&BLACKHOLE_info);
3090       p = STATIC_LINK2(info,p);
3091       *pp = p;
3092     }
3093     else {
3094       pp = &STATIC_LINK2(info,p);
3095       p = *pp;
3096       i++;
3097     }
3098
3099   }
3100
3101   /*  fprintf(stderr, "%d CAFs live\n", i); */
3102 }
3103 #endif
3104
3105 //@node Lazy black holing, Stack squeezing, Sanity code for CAF garbage collection
3106 //@subsection Lazy black holing
3107
3108 /* -----------------------------------------------------------------------------
3109    Lazy black holing.
3110
3111    Whenever a thread returns to the scheduler after possibly doing
3112    some work, we have to run down the stack and black-hole all the
3113    closures referred to by update frames.
3114    -------------------------------------------------------------------------- */
3115 //@cindex threadLazyBlackHole
3116
3117 static void
3118 threadLazyBlackHole(StgTSO *tso)
3119 {
3120   StgUpdateFrame *update_frame;
3121   StgBlockingQueue *bh;
3122   StgPtr stack_end;
3123
3124   stack_end = &tso->stack[tso->stack_size];
3125   update_frame = tso->su;
3126
3127   while (1) {
3128     switch (get_itbl(update_frame)->type) {
3129
3130     case CATCH_FRAME:
3131       update_frame = ((StgCatchFrame *)update_frame)->link;
3132       break;
3133
3134     case UPDATE_FRAME:
3135       bh = (StgBlockingQueue *)update_frame->updatee;
3136
3137       /* if the thunk is already blackholed, it means we've also
3138        * already blackholed the rest of the thunks on this stack,
3139        * so we can stop early.
3140        *
3141        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3142        * don't interfere with this optimisation.
3143        */
3144       if (bh->header.info == &BLACKHOLE_info) {
3145         return;
3146       }
3147
3148       if (bh->header.info != &BLACKHOLE_BQ_info &&
3149           bh->header.info != &CAF_BLACKHOLE_info) {
3150 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3151         fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
3152 #endif
3153         SET_INFO(bh,&BLACKHOLE_info);
3154       }
3155
3156       update_frame = update_frame->link;
3157       break;
3158
3159     case SEQ_FRAME:
3160       update_frame = ((StgSeqFrame *)update_frame)->link;
3161       break;
3162
3163     case STOP_FRAME:
3164       return;
3165     default:
3166       barf("threadPaused");
3167     }
3168   }
3169 }
3170
3171 //@node Stack squeezing, Pausing a thread, Lazy black holing
3172 //@subsection Stack squeezing
3173
3174 /* -----------------------------------------------------------------------------
3175  * Stack squeezing
3176  *
3177  * Code largely pinched from old RTS, then hacked to bits.  We also do
3178  * lazy black holing here.
3179  *
3180  * -------------------------------------------------------------------------- */
3181 //@cindex threadSqueezeStack
3182
3183 static void
3184 threadSqueezeStack(StgTSO *tso)
3185 {
3186   lnat displacement = 0;
3187   StgUpdateFrame *frame;
3188   StgUpdateFrame *next_frame;                   /* Temporally next */
3189   StgUpdateFrame *prev_frame;                   /* Temporally previous */
3190   StgPtr bottom;
3191   rtsBool prev_was_update_frame;
3192 #if DEBUG
3193   StgUpdateFrame *top_frame;
3194   nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
3195       bhs=0, squeezes=0;
3196   void printObj( StgClosure *obj ); // from Printer.c
3197
3198   top_frame  = tso->su;
3199 #endif
3200
3201   bottom = &(tso->stack[tso->stack_size]);
3202   frame  = tso->su;
3203
3204   /* There must be at least one frame, namely the STOP_FRAME.
3205    */
3206   ASSERT((P_)frame < bottom);
3207
3208   /* Walk down the stack, reversing the links between frames so that
3209    * we can walk back up as we squeeze from the bottom.  Note that
3210    * next_frame and prev_frame refer to next and previous as they were
3211    * added to the stack, rather than the way we see them in this
3212    * walk. (It makes the next loop less confusing.)
3213    *
3214    * Stop if we find an update frame pointing to a black hole
3215    * (see comment in threadLazyBlackHole()).
3216    */
3217
3218   next_frame = NULL;
3219   /* bottom - sizeof(StgStopFrame) is the STOP_FRAME */
3220   while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
3221     prev_frame = frame->link;
3222     frame->link = next_frame;
3223     next_frame = frame;
3224     frame = prev_frame;
3225 #if DEBUG
3226     IF_DEBUG(sanity,
3227              if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
3228                printObj((StgClosure *)prev_frame);
3229                barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
3230                     frame, prev_frame);
3231              })
3232     switch (get_itbl(frame)->type) {
3233     case UPDATE_FRAME: upd_frames++;
3234                        if (frame->updatee->header.info == &BLACKHOLE_info)
3235                          bhs++;
3236                        break;
3237     case STOP_FRAME:  stop_frames++;
3238                       break;
3239     case CATCH_FRAME: catch_frames++;
3240                       break;
3241     case SEQ_FRAME: seq_frames++;
3242                     break;
3243     default:
3244       barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
3245            frame, prev_frame);
3246       printObj((StgClosure *)prev_frame);
3247     }
3248 #endif
3249     if (get_itbl(frame)->type == UPDATE_FRAME
3250         && frame->updatee->header.info == &BLACKHOLE_info) {
3251         break;
3252     }
3253   }
3254
3255   /* Now, we're at the bottom.  Frame points to the lowest update
3256    * frame on the stack, and its link actually points to the frame
3257    * above. We have to walk back up the stack, squeezing out empty
3258    * update frames and turning the pointers back around on the way
3259    * back up.
3260    *
3261    * The bottom-most frame (the STOP_FRAME) has not been altered, and
3262    * we never want to eliminate it anyway.  Just walk one step up
3263    * before starting to squeeze. When you get to the topmost frame,
3264    * remember that there are still some words above it that might have
3265    * to be moved.
3266    */
3267
3268   prev_frame = frame;
3269   frame = next_frame;
3270
3271   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
3272
3273   /*
3274    * Loop through all of the frames (everything except the very
3275    * bottom).  Things are complicated by the fact that we have
3276    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
3277    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
3278    */
3279   while (frame != NULL) {
3280     StgPtr sp;
3281     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
3282     rtsBool is_update_frame;
3283
3284     next_frame = frame->link;
3285     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
3286
3287     /* Check to see if
3288      *   1. both the previous and current frame are update frames
3289      *   2. the current frame is empty
3290      */
3291     if (prev_was_update_frame && is_update_frame &&
3292         (P_)prev_frame == frame_bottom + displacement) {
3293
3294       /* Now squeeze out the current frame */
3295       StgClosure *updatee_keep   = prev_frame->updatee;
3296       StgClosure *updatee_bypass = frame->updatee;
3297
3298 #if DEBUG
3299       IF_DEBUG(gc, fprintf(stderr, "@@ squeezing frame at %p\n", frame));
3300       squeezes++;
3301 #endif
3302
3303       /* Deal with blocking queues.  If both updatees have blocked
3304        * threads, then we should merge the queues into the update
3305        * frame that we're keeping.
3306        *
3307        * Alternatively, we could just wake them up: they'll just go
3308        * straight to sleep on the proper blackhole!  This is less code
3309        * and probably less bug prone, although it's probably much
3310        * slower --SDM
3311        */
3312 #if 0 /* do it properly... */
3313 #  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3314 #    error Unimplemented lazy BH warning.  (KSW 1999-01)
3315 #  endif
3316       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info
3317           || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
3318           ) {
3319         /* Sigh.  It has one.  Don't lose those threads! */
3320           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
3321           /* Urgh.  Two queues.  Merge them. */
3322           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
3323
3324           while (keep_tso->link != END_TSO_QUEUE) {
3325             keep_tso = keep_tso->link;
3326           }
3327           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
3328
3329         } else {
3330           /* For simplicity, just swap the BQ for the BH */
3331           P_ temp = updatee_keep;
3332
3333           updatee_keep = updatee_bypass;
3334           updatee_bypass = temp;
3335
3336           /* Record the swap in the kept frame (below) */
3337           prev_frame->updatee = updatee_keep;
3338         }
3339       }
3340 #endif
3341
3342       TICK_UPD_SQUEEZED();
3343       /* wasn't there something about update squeezing and ticky to be
3344        * sorted out?  oh yes: we aren't counting each enter properly
3345        * in this case.  See the log somewhere.  KSW 1999-04-21
3346        */
3347       UPD_IND_NOLOCK(updatee_bypass, updatee_keep); /* this wakes the threads up */
3348
3349       sp = (P_)frame - 1;       /* sp = stuff to slide */
3350       displacement += sizeofW(StgUpdateFrame);
3351
3352     } else {
3353       /* No squeeze for this frame */
3354       sp = frame_bottom - 1;    /* Keep the current frame */
3355
3356       /* Do lazy black-holing.
3357        */
3358       if (is_update_frame) {
3359         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
3360         if (bh->header.info != &BLACKHOLE_info &&
3361             bh->header.info != &BLACKHOLE_BQ_info &&
3362             bh->header.info != &CAF_BLACKHOLE_info) {
3363 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3364           fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
3365 #endif
3366           SET_INFO(bh,&BLACKHOLE_info);
3367         }
3368       }
3369
3370       /* Fix the link in the current frame (should point to the frame below) */
3371       frame->link = prev_frame;
3372       prev_was_update_frame = is_update_frame;
3373     }
3374
3375     /* Now slide all words from sp up to the next frame */
3376
3377     if (displacement > 0) {
3378       P_ next_frame_bottom;
3379
3380       if (next_frame != NULL)
3381         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
3382       else
3383         next_frame_bottom = tso->sp - 1;
3384
3385 #if DEBUG
3386       IF_DEBUG(gc,
3387                fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
3388                        displacement))
3389 #endif
3390
3391       while (sp >= next_frame_bottom) {
3392         sp[displacement] = *sp;
3393         sp -= 1;
3394       }
3395     }
3396     (P_)prev_frame = (P_)frame + displacement;
3397     frame = next_frame;
3398   }
3399
3400   tso->sp += displacement;
3401   tso->su = prev_frame;
3402 #if DEBUG
3403   IF_DEBUG(gc,
3404            fprintf(stderr, "@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames\n",
3405                    squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
3406 #endif
3407 }
3408
3409 //@node Pausing a thread, Index, Stack squeezing
3410 //@subsection Pausing a thread
3411
3412 /* -----------------------------------------------------------------------------
3413  * Pausing a thread
3414  *
3415  * We have to prepare for GC - this means doing lazy black holing
3416  * here.  We also take the opportunity to do stack squeezing if it's
3417  * turned on.
3418  * -------------------------------------------------------------------------- */
3419 //@cindex threadPaused
3420
3421 void
3422 threadPaused(StgTSO *tso)
3423 {
3424   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
3425     threadSqueezeStack(tso);    /* does black holing too */
3426   else
3427     threadLazyBlackHole(tso);
3428 }
3429
3430 /* -----------------------------------------------------------------------------
3431  * Debugging
3432  * -------------------------------------------------------------------------- */
3433
3434 #if DEBUG
3435 //@cindex printMutOnceList
3436 void
3437 printMutOnceList(generation *gen)
3438 {
3439   StgMutClosure *p, *next;
3440
3441   p = gen->mut_once_list;
3442   next = p->mut_link;
3443
3444   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
3445   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3446     fprintf(stderr, "%p (%s), ",
3447             p, info_type((StgClosure *)p));
3448   }
3449   fputc('\n', stderr);
3450 }
3451
3452 //@cindex printMutableList
3453 void
3454 printMutableList(generation *gen)
3455 {
3456   StgMutClosure *p, *next;
3457
3458   p = gen->saved_mut_list;
3459   next = p->mut_link;
3460
3461   fprintf(stderr, "@@ Mutable list %p: ", gen->saved_mut_list);
3462   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3463     fprintf(stderr, "%p (%s), ",
3464             p, info_type((StgClosure *)p));
3465   }
3466   fputc('\n', stderr);
3467 }
3468 #endif /* DEBUG */
3469
3470 //@node Index,  , Pausing a thread
3471 //@subsection Index
3472
3473 //@index
3474 //* GarbageCollect::  @cindex\s-+GarbageCollect
3475 //* MarkRoot::  @cindex\s-+MarkRoot
3476 //* RevertCAFs::  @cindex\s-+RevertCAFs
3477 //* addBlock::  @cindex\s-+addBlock
3478 //* cleanup_weak_ptr_list::  @cindex\s-+cleanup_weak_ptr_list
3479 //* copy::  @cindex\s-+copy
3480 //* copyPart::  @cindex\s-+copyPart
3481 //* evacuate::  @cindex\s-+evacuate
3482 //* evacuate_large::  @cindex\s-+evacuate_large
3483 //* gcCAFs::  @cindex\s-+gcCAFs
3484 //* isAlive::  @cindex\s-+isAlive
3485 //* mkMutCons::  @cindex\s-+mkMutCons
3486 //* relocate_TSO::  @cindex\s-+relocate_TSO
3487 //* revert_dead_CAFs::  @cindex\s-+revert_dead_CAFs
3488 //* scavenge::  @cindex\s-+scavenge
3489 //* scavenge_large::  @cindex\s-+scavenge_large
3490 //* scavenge_mut_once_list::  @cindex\s-+scavenge_mut_once_list
3491 //* scavenge_mutable_list::  @cindex\s-+scavenge_mutable_list
3492 //* scavenge_one::  @cindex\s-+scavenge_one
3493 //* scavenge_srt::  @cindex\s-+scavenge_srt
3494 //* scavenge_stack::  @cindex\s-+scavenge_stack
3495 //* scavenge_static::  @cindex\s-+scavenge_static
3496 //* threadLazyBlackHole::  @cindex\s-+threadLazyBlackHole
3497 //* threadPaused::  @cindex\s-+threadPaused
3498 //* threadSqueezeStack::  @cindex\s-+threadSqueezeStack
3499 //* traverse_weak_ptr_list::  @cindex\s-+traverse_weak_ptr_list
3500 //* upd_evacuee::  @cindex\s-+upd_evacuee
3501 //* zero_mutable_list::  @cindex\s-+zero_mutable_list
3502 //* zero_static_object_list::  @cindex\s-+zero_static_object_list
3503 //@end index