ghc/rts/GC.c

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