ghc/rts/GC.c

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