ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.42 1999/02/25 17:52:33 simonm Exp $
   3  *
   4  * (c) The GHC Team 1998-1999
   5  *
   6  * Generational garbage collector
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "RtsFlags.h"
  12 #include "RtsUtils.h"
  13 #include "Storage.h"
  14 #include "StoragePriv.h"
  15 #include "Stats.h"
  16 #include "Schedule.h"
  17 #include "SchedAPI.h" /* for ReverCAFs prototype */
  18 #include "Sanity.h"
  19 #include "GC.h"
  20 #include "BlockAlloc.h"
  21 #include "Main.h"
  22 #include "DebugProf.h"
  23 #include "SchedAPI.h"
  24 #include "Weak.h"
  25 #include "StablePriv.h"
  26
  27 StgCAF* enteredCAFs;
  28
  29 /* STATIC OBJECT LIST.
  30  *
  31  * During GC:
  32  * We maintain a linked list of static objects that are still live.
  33  * The requirements for this list are:
  34  *
  35  *  - we need to scan the list while adding to it, in order to
  36  *    scavenge all the static objects (in the same way that
  37  *    breadth-first scavenging works for dynamic objects).
  38  *
  39  *  - we need to be able to tell whether an object is already on
  40  *    the list, to break loops.
  41  *
  42  * Each static object has a "static link field", which we use for
  43  * linking objects on to the list.  We use a stack-type list, consing
  44  * objects on the front as they are added (this means that the
  45  * scavenge phase is depth-first, not breadth-first, but that
  46  * shouldn't matter).
  47  *
  48  * A separate list is kept for objects that have been scavenged
  49  * already - this is so that we can zero all the marks afterwards.
  50  *
  51  * An object is on the list if its static link field is non-zero; this
  52  * means that we have to mark the end of the list with '1', not NULL.
  53  *
  54  * Extra notes for generational GC:
  55  *
  56  * Each generation has a static object list associated with it.  When
  57  * collecting generations up to N, we treat the static object lists
  58  * from generations > N as roots.
  59  *
  60  * We build up a static object list while collecting generations 0..N,
  61  * which is then appended to the static object list of generation N+1.
  62  */
  63 StgClosure* static_objects;           /* live static objects */
  64 StgClosure* scavenged_static_objects; /* static objects scavenged so far */
  65
  66 /* N is the oldest generation being collected, where the generations
  67  * are numbered starting at 0.  A major GC (indicated by the major_gc
  68  * flag) is when we're collecting all generations.  We only attempt to
  69  * deal with static objects and GC CAFs when doing a major GC.
  70  */
  71 static nat N;
  72 static rtsBool major_gc;
  73
  74 /* Youngest generation that objects should be evacuated to in
  75  * evacuate().  (Logically an argument to evacuate, but it's static
  76  * a lot of the time so we optimise it into a global variable).
  77  */
  78 static nat evac_gen;
  79
  80 /* WEAK POINTERS
  81  */
  82 static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
  83 static rtsBool weak_done;       /* all done for this pass */
  84
  85 /* Flag indicating failure to evacuate an object to the desired
  86  * generation.
  87  */
  88 static rtsBool failed_to_evac;
  89
  90 /* Old to-space (used for two-space collector only)
  91  */
  92 bdescr *old_to_space;
  93
  94 /* Data used for allocation area sizing.
  95  */
  96 lnat new_blocks;                /* blocks allocated during this GC */
  97 lnat g0s0_pcnt_kept = 30;       /* percentage of g0s0 live at last minor GC */
  98
  99 /* -----------------------------------------------------------------------------
 100    Static function declarations
 101    -------------------------------------------------------------------------- */
 102
 103 static StgClosure *evacuate(StgClosure *q);
 104 static void    zeroStaticObjectList(StgClosure* first_static);
 105 static rtsBool traverse_weak_ptr_list(void);
 106 static void    zeroMutableList(StgMutClosure *first);
 107 static void    revertDeadCAFs(void);
 108
 109 static void           scavenge_stack(StgPtr p, StgPtr stack_end);
 110 static void           scavenge_large(step *step);
 111 static void           scavenge(step *step);
 112 static void           scavenge_static(void);
 113 static void           scavenge_mutable_list(generation *g);
 114 static void           scavenge_mut_once_list(generation *g);
 115
 116 #ifdef DEBUG
 117 static void gcCAFs(void);
 118 #endif
 119
 120 /* -----------------------------------------------------------------------------
 121    GarbageCollect
 122
 123    For garbage collecting generation N (and all younger generations):
 124
 125      - follow all pointers in the root set.  the root set includes all
 126        mutable objects in all steps in all generations.
 127
 128      - for each pointer, evacuate the object it points to into either
 129        + to-space in the next higher step in that generation, if one exists,
 130        + if the object's generation == N, then evacuate it to the next
 131          generation if one exists, or else to-space in the current
 132          generation.
 133        + if the object's generation < N, then evacuate it to to-space
 134          in the next generation.
 135
 136      - repeatedly scavenge to-space from each step in each generation
 137        being collected until no more objects can be evacuated.
 138
 139      - free from-space in each step, and set from-space = to-space.
 140
 141    -------------------------------------------------------------------------- */
 142
 143 void GarbageCollect(void (*get_roots)(void))
 144 {
 145   bdescr *bd;
 146   step *step;
 147   lnat live, allocated, collected = 0, copied = 0;
 148   nat g, s;
 149
 150 #ifdef PROFILING
 151   CostCentreStack *prev_CCS;
 152 #endif
 153
 154   /* tell the stats department that we've started a GC */
 155   stat_startGC();
 156
 157   /* attribute any costs to CCS_GC */
 158 #ifdef PROFILING
 159   prev_CCS = CCCS;
 160   CCCS = CCS_GC;
 161 #endif
 162
 163   /* We might have been called from Haskell land by _ccall_GC, in
 164    * which case we need to call threadPaused() because the scheduler
 165    * won't have done it.
 166    */
 167   if (CurrentTSO) { threadPaused(CurrentTSO); }
 168
 169   /* Approximate how much we allocated: number of blocks in the
 170    * nursery + blocks allocated via allocate() - unused nusery blocks.
 171    * This leaves a little slop at the end of each block, and doesn't
 172    * take into account large objects (ToDo).
 173    */
 174   allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
 175   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 176     allocated -= BLOCK_SIZE_W;
 177   }
 178
 179   /* Figure out which generation to collect
 180    */
 181   N = 0;
 182   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 183     if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
 184       N = g;
 185     }
 186   }
 187   major_gc = (N == RtsFlags.GcFlags.generations-1);
 188
 189   /* check stack sanity *before* GC (ToDo: check all threads) */
 190   /*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
 191   IF_DEBUG(sanity, checkFreeListSanity());
 192
 193   /* Initialise the static object lists
 194    */
 195   static_objects = END_OF_STATIC_LIST;
 196   scavenged_static_objects = END_OF_STATIC_LIST;
 197
 198   /* zero the mutable list for the oldest generation (see comment by
 199    * zeroMutableList below).
 200    */
 201   if (major_gc) {
 202     zeroMutableList(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
 203   }
 204
 205   /* Save the old to-space if we're doing a two-space collection
 206    */
 207   if (RtsFlags.GcFlags.generations == 1) {
 208     old_to_space = g0s0->to_space;
 209     g0s0->to_space = NULL;
 210   }
 211
 212   /* Keep a count of how many new blocks we allocated during this GC
 213    * (used for resizing the allocation area, later).
 214    */
 215   new_blocks = 0;
 216
 217   /* Initialise to-space in all the generations/steps that we're
 218    * collecting.
 219    */
 220   for (g = 0; g <= N; g++) {
 221     generations[g].mut_once_list = END_MUT_LIST;
 222     generations[g].mut_list = END_MUT_LIST;
 223
 224     for (s = 0; s < generations[g].n_steps; s++) {
 225
 226       /* generation 0, step 0 doesn't need to-space */
 227       if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
 228         continue;
 229       }
 230
 231       /* Get a free block for to-space.  Extra blocks will be chained on
 232        * as necessary.
 233        */
 234       bd = allocBlock();
 235       step = &generations[g].steps[s];
 236       ASSERT(step->gen->no == g);
 237       ASSERT(step->hp ? Bdescr(step->hp)->step == step : rtsTrue);
 238       bd->gen  = &generations[g];
 239       bd->step = step;
 240       bd->link = NULL;
 241       bd->evacuated = 1;        /* it's a to-space block */
 242       step->hp        = bd->start;
 243       step->hpLim     = step->hp + BLOCK_SIZE_W;
 244       step->hp_bd     = bd;
 245       step->to_space  = bd;
 246       step->to_blocks = 1;
 247       step->scan      = bd->start;
 248       step->scan_bd   = bd;
 249       step->new_large_objects = NULL;
 250       step->scavenged_large_objects = NULL;
 251       new_blocks++;
 252       /* mark the large objects as not evacuated yet */
 253       for (bd = step->large_objects; bd; bd = bd->link) {
 254         bd->evacuated = 0;
 255       }
 256     }
 257   }
 258
 259   /* make sure the older generations have at least one block to
 260    * allocate into (this makes things easier for copy(), see below.
 261    */
 262   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 263     for (s = 0; s < generations[g].n_steps; s++) {
 264       step = &generations[g].steps[s];
 265       if (step->hp_bd == NULL) {
 266         bd = allocBlock();
 267         bd->gen = &generations[g];
 268         bd->step = step;
 269         bd->link = NULL;
 270         bd->evacuated = 0;      /* *not* a to-space block */
 271         step->hp = bd->start;
 272         step->hpLim = step->hp + BLOCK_SIZE_W;
 273         step->hp_bd = bd;
 274         step->blocks = bd;
 275         step->n_blocks = 1;
 276         new_blocks++;
 277       }
 278       /* Set the scan pointer for older generations: remember we
 279        * still have to scavenge objects that have been promoted. */
 280       step->scan = step->hp;
 281       step->scan_bd = step->hp_bd;
 282       step->to_space = NULL;
 283       step->to_blocks = 0;
 284       step->new_large_objects = NULL;
 285       step->scavenged_large_objects = NULL;
 286     }
 287   }
 288
 289   /* -----------------------------------------------------------------------
 290    * follow all the roots that we know about:
 291    *   - mutable lists from each generation > N
 292    * we want to *scavenge* these roots, not evacuate them: they're not
 293    * going to move in this GC.
 294    * Also: do them in reverse generation order.  This is because we
 295    * often want to promote objects that are pointed to by older
 296    * generations early, so we don't have to repeatedly copy them.
 297    * Doing the generations in reverse order ensures that we don't end
 298    * up in the situation where we want to evac an object to gen 3 and
 299    * it has already been evaced to gen 2.
 300    */
 301   {
 302     int st;
 303     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 304       generations[g].saved_mut_list = generations[g].mut_list;
 305       generations[g].mut_list = END_MUT_LIST;
 306     }
 307
 308     /* Do the mut-once lists first */
 309     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 310       scavenge_mut_once_list(&generations[g]);
 311       evac_gen = g;
 312       for (st = generations[g].n_steps-1; st >= 0; st--) {
 313         scavenge(&generations[g].steps[st]);
 314       }
 315     }
 316
 317     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 318       scavenge_mutable_list(&generations[g]);
 319       evac_gen = g;
 320       for (st = generations[g].n_steps-1; st >= 0; st--) {
 321         scavenge(&generations[g].steps[st]);
 322       }
 323     }
 324   }
 325
 326   /* follow all the roots that the application knows about.
 327    */
 328   evac_gen = 0;
 329   get_roots();
 330
 331   /* And don't forget to mark the TSO if we got here direct from
 332    * Haskell! */
 333   if (CurrentTSO) {
 334     CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
 335   }
 336
 337   /* Mark the weak pointer list, and prepare to detect dead weak
 338    * pointers.
 339    */
 340   markWeakList();
 341   old_weak_ptr_list = weak_ptr_list;
 342   weak_ptr_list = NULL;
 343   weak_done = rtsFalse;
 344
 345   /* Mark the stable pointer table.
 346    */
 347   markStablePtrTable(major_gc);
 348
 349 #ifdef INTERPRETER
 350   {
 351       /* ToDo: To fix the caf leak, we need to make the commented out
 352        * parts of this code do something sensible - as described in
 353        * the CAF document.
 354        */
 355       extern void markHugsObjects(void);
 356 #if 0
 357       /* ToDo: This (undefined) function should contain the scavenge
 358        * loop immediately below this block of code - but I'm not sure
 359        * enough of the details to do this myself.
 360        */
 361       scavengeEverything();
 362       /* revert dead CAFs and update enteredCAFs list */
 363       revertDeadCAFs();
 364 #endif
 365       markHugsObjects();
 366 #if 0
 367       /* This will keep the CAFs and the attached BCOs alive
 368        * but the values will have been reverted
 369        */
 370       scavengeEverything();
 371 #endif
 372   }
 373 #endif
 374
 375   /* -------------------------------------------------------------------------
 376    * Repeatedly scavenge all the areas we know about until there's no
 377    * more scavenging to be done.
 378    */
 379   {
 380     rtsBool flag;
 381   loop:
 382     flag = rtsFalse;
 383
 384     /* scavenge static objects */
 385     if (major_gc && static_objects != END_OF_STATIC_LIST) {
 386       scavenge_static();
 387     }
 388
 389     /* When scavenging the older generations:  Objects may have been
 390      * evacuated from generations <= N into older generations, and we
 391      * need to scavenge these objects.  We're going to try to ensure that
 392      * any evacuations that occur move the objects into at least the
 393      * same generation as the object being scavenged, otherwise we
 394      * have to create new entries on the mutable list for the older
 395      * generation.
 396      */
 397
 398     /* scavenge each step in generations 0..maxgen */
 399     {
 400       int gen, st;
 401     loop2:
 402       for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
 403         for (st = generations[gen].n_steps-1; st >= 0 ; st--) {
 404           if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
 405             continue;
 406           }
 407           step = &generations[gen].steps[st];
 408           evac_gen = gen;
 409           if (step->hp_bd != step->scan_bd || step->scan < step->hp) {
 410             scavenge(step);
 411             flag = rtsTrue;
 412             goto loop2;
 413           }
 414           if (step->new_large_objects != NULL) {
 415             scavenge_large(step);
 416             flag = rtsTrue;
 417             goto loop2;
 418           }
 419         }
 420       }
 421     }
 422     if (flag) { goto loop; }
 423
 424     /* must be last... */
 425     if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
 426       goto loop;
 427     }
 428   }
 429
 430   /* Now see which stable names are still alive
 431    */
 432   gcStablePtrTable(major_gc);
 433
 434   /* Set the maximum blocks for the oldest generation, based on twice
 435    * the amount of live data now, adjusted to fit the maximum heap
 436    * size if necessary.
 437    *
 438    * This is an approximation, since in the worst case we'll need
 439    * twice the amount of live data plus whatever space the other
 440    * generations need.
 441    */
 442   if (RtsFlags.GcFlags.generations > 1) {
 443     if (major_gc) {
 444       oldest_gen->max_blocks =
 445         stg_max(oldest_gen->steps[0].to_blocks * RtsFlags.GcFlags.oldGenFactor,
 446                 RtsFlags.GcFlags.minOldGenSize);
 447       if (oldest_gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
 448         oldest_gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
 449         if (((int)oldest_gen->max_blocks -
 450              (int)oldest_gen->steps[0].to_blocks) <
 451             (RtsFlags.GcFlags.pcFreeHeap *
 452              RtsFlags.GcFlags.maxHeapSize / 200)) {
 453           heapOverflow();
 454         }
 455       }
 456     }
 457   }
 458
 459   /* run through all the generations/steps and tidy up
 460    */
 461   copied = new_blocks * BLOCK_SIZE_W;
 462   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 463
 464     if (g <= N) {
 465       generations[g].collections++; /* for stats */
 466     }
 467
 468     for (s = 0; s < generations[g].n_steps; s++) {
 469       bdescr *next;
 470       step = &generations[g].steps[s];
 471
 472       if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 473         /* Tidy the end of the to-space chains */
 474         step->hp_bd->free = step->hp;
 475         step->hp_bd->link = NULL;
 476         /* stats information: how much we copied */
 477         if (g <= N) {
 478           copied -= step->hp_bd->start + BLOCK_SIZE_W -
 479             step->hp_bd->free;
 480         }
 481       }
 482
 483       /* for generations we collected... */
 484       if (g <= N) {
 485
 486         collected += step->n_blocks * BLOCK_SIZE_W; /* for stats */
 487
 488         /* free old memory and shift to-space into from-space for all
 489          * the collected steps (except the allocation area).  These
 490          * freed blocks will probaby be quickly recycled.
 491          */
 492         if (!(g == 0 && s == 0)) {
 493           freeChain(step->blocks);
 494           step->blocks = step->to_space;
 495           step->n_blocks = step->to_blocks;
 496           step->to_space = NULL;
 497           step->to_blocks = 0;
 498           for (bd = step->blocks; bd != NULL; bd = bd->link) {
 499             bd->evacuated = 0;  /* now from-space */
 500           }
 501         }
 502
 503         /* LARGE OBJECTS.  The current live large objects are chained on
 504          * scavenged_large, having been moved during garbage
 505          * collection from large_objects.  Any objects left on
 506          * large_objects list are therefore dead, so we free them here.
 507          */
 508         for (bd = step->large_objects; bd != NULL; bd = next) {
 509           next = bd->link;
 510           freeGroup(bd);
 511           bd = next;
 512         }
 513         for (bd = step->scavenged_large_objects; bd != NULL; bd = bd->link) {
 514           bd->evacuated = 0;
 515         }
 516         step->large_objects = step->scavenged_large_objects;
 517
 518         /* Set the maximum blocks for this generation, interpolating
 519          * between the maximum size of the oldest and youngest
 520          * generations.
 521          *
 522          * max_blocks =    oldgen_max_blocks * G
 523          *                 ----------------------
 524          *                      oldest_gen
 525          */
 526         if (g != 0) {
 527 #if 0
 528           generations[g].max_blocks = (oldest_gen->max_blocks * g)
 529                / (RtsFlags.GcFlags.generations-1);
 530 #endif
 531           generations[g].max_blocks = oldest_gen->max_blocks;
 532         }
 533
 534       /* for older generations... */
 535       } else {
 536
 537         /* For older generations, we need to append the
 538          * scavenged_large_object list (i.e. large objects that have been
 539          * promoted during this GC) to the large_object list for that step.
 540          */
 541         for (bd = step->scavenged_large_objects; bd; bd = next) {
 542           next = bd->link;
 543           bd->evacuated = 0;
 544           dbl_link_onto(bd, &step->large_objects);
 545         }
 546
 547         /* add the new blocks we promoted during this GC */
 548         step->n_blocks += step->to_blocks;
 549       }
 550     }
 551   }
 552
 553   /* Guess the amount of live data for stats. */
 554   live = calcLive();
 555
 556   /* Free the small objects allocated via allocate(), since this will
 557    * all have been copied into G0S1 now.
 558    */
 559   if (small_alloc_list != NULL) {
 560     freeChain(small_alloc_list);
 561   }
 562   small_alloc_list = NULL;
 563   alloc_blocks = 0;
 564   alloc_Hp = NULL;
 565   alloc_HpLim = NULL;
 566   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 567
 568   /* Two-space collector:
 569    * Free the old to-space, and estimate the amount of live data.
 570    */
 571   if (RtsFlags.GcFlags.generations == 1) {
 572     nat blocks;
 573
 574     if (old_to_space != NULL) {
 575       freeChain(old_to_space);
 576     }
 577     for (bd = g0s0->to_space; bd != NULL; bd = bd->link) {
 578       bd->evacuated = 0;        /* now from-space */
 579     }
 580
 581     /* For a two-space collector, we need to resize the nursery. */
 582
 583     /* set up a new nursery.  Allocate a nursery size based on a
 584      * function of the amount of live data (currently a factor of 2,
 585      * should be configurable (ToDo)).  Use the blocks from the old
 586      * nursery if possible, freeing up any left over blocks.
 587      *
 588      * If we get near the maximum heap size, then adjust our nursery
 589      * size accordingly.  If the nursery is the same size as the live
 590      * data (L), then we need 3L bytes.  We can reduce the size of the
 591      * nursery to bring the required memory down near 2L bytes.
 592      *
 593      * A normal 2-space collector would need 4L bytes to give the same
 594      * performance we get from 3L bytes, reducing to the same
 595      * performance at 2L bytes.
 596      */
 597     blocks = g0s0->to_blocks;
 598
 599     if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
 600          RtsFlags.GcFlags.maxHeapSize ) {
 601       int adjusted_blocks;  /* signed on purpose */
 602       int pc_free;
 603
 604       adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
 605       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));
 606       pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
 607       if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
 608         heapOverflow();
 609       }
 610       blocks = adjusted_blocks;
 611
 612     } else {
 613       blocks *= RtsFlags.GcFlags.oldGenFactor;
 614       if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
 615         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 616       }
 617     }
 618     resizeNursery(blocks);
 619
 620   } else {
 621     /* Generational collector:
 622      * If the user has given us a suggested heap size, adjust our
 623      * allocation area to make best use of the memory available.
 624      */
 625
 626     if (RtsFlags.GcFlags.heapSizeSuggestion) {
 627       int blocks;
 628       nat needed = calcNeeded();        /* approx blocks needed at next GC */
 629
 630       /* Guess how much will be live in generation 0 step 0 next time.
 631        * A good approximation is the obtained by finding the
 632        * percentage of g0s0 that was live at the last minor GC.
 633        */
 634       if (N == 0) {
 635         g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
 636       }
 637
 638       /* Estimate a size for the allocation area based on the
 639        * information available.  We might end up going slightly under
 640        * or over the suggested heap size, but we should be pretty
 641        * close on average.
 642        *
 643        * Formula:            suggested - needed
 644        *                ----------------------------
 645        *                    1 + g0s0_pcnt_kept/100
 646        *
 647        * where 'needed' is the amount of memory needed at the next
 648        * collection for collecting all steps except g0s0.
 649        */
 650       blocks =
 651         (((int)RtsFlags.GcFlags.heapSizeSuggestion - (int)needed) * 100) /
 652         (100 + (int)g0s0_pcnt_kept);
 653
 654       if (blocks < (int)RtsFlags.GcFlags.minAllocAreaSize) {
 655         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 656       }
 657
 658       resizeNursery((nat)blocks);
 659     }
 660   }
 661
 662   /* revert dead CAFs and update enteredCAFs list */
 663   revertDeadCAFs();
 664
 665   /* mark the garbage collected CAFs as dead */
 666 #ifdef DEBUG
 667   if (major_gc) { gcCAFs(); }
 668 #endif
 669
 670   /* zero the scavenged static object list */
 671   if (major_gc) {
 672     zeroStaticObjectList(scavenged_static_objects);
 673   }
 674
 675   /* Reset the nursery
 676    */
 677   for (bd = g0s0->blocks; bd; bd = bd->link) {
 678     bd->free = bd->start;
 679     ASSERT(bd->gen == g0);
 680     ASSERT(bd->step == g0s0);
 681     IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
 682   }
 683   current_nursery = g0s0->blocks;
 684
 685   /* start any pending finalizers */
 686   scheduleFinalizers(old_weak_ptr_list);
 687
 688   /* check sanity after GC */
 689   IF_DEBUG(sanity, checkSanity(N));
 690
 691   /* extra GC trace info */
 692   IF_DEBUG(gc, stat_describe_gens());
 693
 694 #ifdef DEBUG
 695   /* symbol-table based profiling */
 696   /*  heapCensus(to_space); */ /* ToDo */
 697 #endif
 698
 699   /* restore enclosing cost centre */
 700 #ifdef PROFILING
 701   CCCS = prev_CCS;
 702 #endif
 703
 704   /* check for memory leaks if sanity checking is on */
 705   IF_DEBUG(sanity, memInventory());
 706
 707   /* ok, GC over: tell the stats department what happened. */
 708   stat_endGC(allocated, collected, live, copied, N);
 709 }
 710
 711 /* -----------------------------------------------------------------------------
 712    Weak Pointers
 713
 714    traverse_weak_ptr_list is called possibly many times during garbage
 715    collection.  It returns a flag indicating whether it did any work
 716    (i.e. called evacuate on any live pointers).
 717
 718    Invariant: traverse_weak_ptr_list is called when the heap is in an
 719    idempotent state.  That means that there are no pending
 720    evacuate/scavenge operations.  This invariant helps the weak
 721    pointer code decide which weak pointers are dead - if there are no
 722    new live weak pointers, then all the currently unreachable ones are
 723    dead.
 724
 725    For generational GC: we just don't try to finalize weak pointers in
 726    older generations than the one we're collecting.  This could
 727    probably be optimised by keeping per-generation lists of weak
 728    pointers, but for a few weak pointers this scheme will work.
 729    -------------------------------------------------------------------------- */
 730
 731 static rtsBool
 732 traverse_weak_ptr_list(void)
 733 {
 734   StgWeak *w, **last_w, *next_w;
 735   StgClosure *new;
 736   rtsBool flag = rtsFalse;
 737
 738   if (weak_done) { return rtsFalse; }
 739
 740   /* doesn't matter where we evacuate values/finalizers to, since
 741    * these pointers are treated as roots (iff the keys are alive).
 742    */
 743   evac_gen = 0;
 744
 745   last_w = &old_weak_ptr_list;
 746   for (w = old_weak_ptr_list; w; w = next_w) {
 747
 748     if ((new = isAlive(w->key))) {
 749       w->key = new;
 750       /* evacuate the value and finalizer */
 751       w->value = evacuate(w->value);
 752       w->finalizer = evacuate(w->finalizer);
 753       /* remove this weak ptr from the old_weak_ptr list */
 754       *last_w = w->link;
 755       /* and put it on the new weak ptr list */
 756       next_w  = w->link;
 757       w->link = weak_ptr_list;
 758       weak_ptr_list = w;
 759       flag = rtsTrue;
 760       IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
 761       continue;
 762     }
 763     else {
 764       last_w = &(w->link);
 765       next_w = w->link;
 766       continue;
 767     }
 768   }
 769
 770   /* If we didn't make any changes, then we can go round and kill all
 771    * the dead weak pointers.  The old_weak_ptr list is used as a list
 772    * of pending finalizers later on.
 773    */
 774   if (flag == rtsFalse) {
 775     for (w = old_weak_ptr_list; w; w = w->link) {
 776       w->value = evacuate(w->value);
 777       w->finalizer = evacuate(w->finalizer);
 778     }
 779     weak_done = rtsTrue;
 780   }
 781
 782   return rtsTrue;
 783 }
 784
 785 /* -----------------------------------------------------------------------------
 786    isAlive determines whether the given closure is still alive (after
 787    a garbage collection) or not.  It returns the new address of the
 788    closure if it is alive, or NULL otherwise.
 789    -------------------------------------------------------------------------- */
 790
 791 StgClosure *
 792 isAlive(StgClosure *p)
 793 {
 794   StgInfoTable *info;
 795
 796   while (1) {
 797
 798     info = get_itbl(p);
 799
 800     /* ToDo: for static closures, check the static link field.
 801      * Problem here is that we sometimes don't set the link field, eg.
 802      * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
 803      */
 804
 805     /* ignore closures in generations that we're not collecting. */
 806     if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
 807       return p;
 808     }
 809
 810     switch (info->type) {
 811
 812     case IND:
 813     case IND_STATIC:
 814     case IND_PERM:
 815     case IND_OLDGEN:            /* rely on compatible layout with StgInd */
 816     case IND_OLDGEN_PERM:
 817       /* follow indirections */
 818       p = ((StgInd *)p)->indirectee;
 819       continue;
 820
 821     case EVACUATED:
 822       /* alive! */
 823       return ((StgEvacuated *)p)->evacuee;
 824
 825     default:
 826       /* dead. */
 827       return NULL;
 828     }
 829   }
 830 }
 831
 832 StgClosure *
 833 MarkRoot(StgClosure *root)
 834 {
 835   return evacuate(root);
 836 }
 837
 838 static void addBlock(step *step)
 839 {
 840   bdescr *bd = allocBlock();
 841   bd->gen = step->gen;
 842   bd->step = step;
 843
 844   if (step->gen->no <= N) {
 845     bd->evacuated = 1;
 846   } else {
 847     bd->evacuated = 0;
 848   }
 849
 850   step->hp_bd->free = step->hp;
 851   step->hp_bd->link = bd;
 852   step->hp = bd->start;
 853   step->hpLim = step->hp + BLOCK_SIZE_W;
 854   step->hp_bd = bd;
 855   step->to_blocks++;
 856   new_blocks++;
 857 }
 858
 859 static __inline__ void
 860 upd_evacuee(StgClosure *p, StgClosure *dest)
 861 {
 862   p->header.info = &EVACUATED_info;
 863   ((StgEvacuated *)p)->evacuee = dest;
 864 }
 865
 866 static __inline__ StgClosure *
 867 copy(StgClosure *src, nat size, step *step)
 868 {
 869   P_ to, from, dest;
 870
 871   TICK_GC_WORDS_COPIED(size);
 872   /* Find out where we're going, using the handy "to" pointer in
 873    * the step of the source object.  If it turns out we need to
 874    * evacuate to an older generation, adjust it here (see comment
 875    * by evacuate()).
 876    */
 877   if (step->gen->no < evac_gen) {
 878 #ifdef NO_EAGER_PROMOTION
 879     failed_to_evac = rtsTrue;
 880 #else
 881     step = &generations[evac_gen].steps[0];
 882 #endif
 883   }
 884
 885   /* chain a new block onto the to-space for the destination step if
 886    * necessary.
 887    */
 888   if (step->hp + size >= step->hpLim) {
 889     addBlock(step);
 890   }
 891
 892   for(to = step->hp, from = (P_)src; size>0; --size) {
 893     *to++ = *from++;
 894   }
 895
 896   dest = step->hp;
 897   step->hp = to;
 898   upd_evacuee(src,(StgClosure *)dest);
 899   return (StgClosure *)dest;
 900 }
 901
 902 /* Special version of copy() for when we only want to copy the info
 903  * pointer of an object, but reserve some padding after it.  This is
 904  * used to optimise evacuation of BLACKHOLEs.
 905  */
 906
 907 static __inline__ StgClosure *
 908 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
 909 {
 910   P_ dest, to, from;
 911
 912   TICK_GC_WORDS_COPIED(size_to_copy);
 913   if (step->gen->no < evac_gen) {
 914 #ifdef NO_EAGER_PROMOTION
 915     failed_to_evac = rtsTrue;
 916 #else
 917     step = &generations[evac_gen].steps[0];
 918 #endif
 919   }
 920
 921   if (step->hp + size_to_reserve >= step->hpLim) {
 922     addBlock(step);
 923   }
 924
 925   for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
 926     *to++ = *from++;
 927   }
 928
 929   dest = step->hp;
 930   step->hp += size_to_reserve;
 931   upd_evacuee(src,(StgClosure *)dest);
 932   return (StgClosure *)dest;
 933 }
 934
 935 /* -----------------------------------------------------------------------------
 936    Evacuate a large object
 937
 938    This just consists of removing the object from the (doubly-linked)
 939    large_alloc_list, and linking it on to the (singly-linked)
 940    new_large_objects list, from where it will be scavenged later.
 941
 942    Convention: bd->evacuated is /= 0 for a large object that has been
 943    evacuated, or 0 otherwise.
 944    -------------------------------------------------------------------------- */
 945
 946 static inline void
 947 evacuate_large(StgPtr p, rtsBool mutable)
 948 {
 949   bdescr *bd = Bdescr(p);
 950   step *step;
 951
 952   /* should point to the beginning of the block */
 953   ASSERT(((W_)p & BLOCK_MASK) == 0);
 954
 955   /* already evacuated? */
 956   if (bd->evacuated) {
 957     /* Don't forget to set the failed_to_evac flag if we didn't get
 958      * the desired destination (see comments in evacuate()).
 959      */
 960     if (bd->gen->no < evac_gen) {
 961       failed_to_evac = rtsTrue;
 962       TICK_GC_FAILED_PROMOTION();
 963     }
 964     return;
 965   }
 966
 967   step = bd->step;
 968   /* remove from large_object list */
 969   if (bd->back) {
 970     bd->back->link = bd->link;
 971   } else { /* first object in the list */
 972     step->large_objects = bd->link;
 973   }
 974   if (bd->link) {
 975     bd->link->back = bd->back;
 976   }
 977
 978   /* link it on to the evacuated large object list of the destination step
 979    */
 980   step = bd->step->to;
 981   if (step->gen->no < evac_gen) {
 982 #ifdef NO_EAGER_PROMOTION
 983     failed_to_evac = rtsTrue;
 984 #else
 985     step = &generations[evac_gen].steps[0];
 986 #endif
 987   }
 988
 989   bd->step = step;
 990   bd->gen = step->gen;
 991   bd->link = step->new_large_objects;
 992   step->new_large_objects = bd;
 993   bd->evacuated = 1;
 994
 995   if (mutable) {
 996     recordMutable((StgMutClosure *)p);
 997   }
 998 }
 999
1000 /* -----------------------------------------------------------------------------
1001    Adding a MUT_CONS to an older generation.
1002
1003    This is necessary from time to time when we end up with an
1004    old-to-new generation pointer in a non-mutable object.  We defer
1005    the promotion until the next GC.
1006    -------------------------------------------------------------------------- */
1007
1008 static StgClosure *
1009 mkMutCons(StgClosure *ptr, generation *gen)
1010 {
1011   StgMutVar *q;
1012   step *step;
1013
1014   step = &gen->steps[0];
1015
1016   /* chain a new block onto the to-space for the destination step if
1017    * necessary.
1018    */
1019   if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
1020     addBlock(step);
1021   }
1022
1023   q = (StgMutVar *)step->hp;
1024   step->hp += sizeofW(StgMutVar);
1025
1026   SET_HDR(q,&MUT_CONS_info,CCS_GC);
1027   q->var = ptr;
1028   recordOldToNewPtrs((StgMutClosure *)q);
1029
1030   return (StgClosure *)q;
1031 }
1032
1033 /* -----------------------------------------------------------------------------
1034    Evacuate
1035
1036    This is called (eventually) for every live object in the system.
1037
1038    The caller to evacuate specifies a desired generation in the
1039    evac_gen global variable.  The following conditions apply to
1040    evacuating an object which resides in generation M when we're
1041    collecting up to generation N
1042
1043    if  M >= evac_gen
1044            if  M > N     do nothing
1045            else          evac to step->to
1046
1047    if  M < evac_gen      evac to evac_gen, step 0
1048
1049    if the object is already evacuated, then we check which generation
1050    it now resides in.
1051
1052    if  M >= evac_gen     do nothing
1053    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1054                          didn't manage to evacuate this object into evac_gen.
1055
1056    -------------------------------------------------------------------------- */
1057
1058
1059 static StgClosure *
1060 evacuate(StgClosure *q)
1061 {
1062   StgClosure *to;
1063   bdescr *bd = NULL;
1064   step *step;
1065   const StgInfoTable *info;
1066
1067 loop:
1068   if (!LOOKS_LIKE_STATIC(q)) {
1069     bd = Bdescr((P_)q);
1070     if (bd->gen->no > N) {
1071       /* Can't evacuate this object, because it's in a generation
1072        * older than the ones we're collecting.  Let's hope that it's
1073        * in evac_gen or older, or we will have to make an IND_OLDGEN object.
1074        */
1075       if (bd->gen->no < evac_gen) {
1076         /* nope */
1077         failed_to_evac = rtsTrue;
1078         TICK_GC_FAILED_PROMOTION();
1079       }
1080       return q;
1081     }
1082     step = bd->step->to;
1083   }
1084
1085   /* make sure the info pointer is into text space */
1086   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1087                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1088
1089   info = get_itbl(q);
1090   switch (info -> type) {
1091
1092   case BCO:
1093     return copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
1094
1095   case MUT_VAR:
1096     ASSERT(q->header.info != &MUT_CONS_info);
1097   case MVAR:
1098     to = copy(q,sizeW_fromITBL(info),step);
1099     recordMutable((StgMutClosure *)to);
1100     return to;
1101
1102   case STABLE_NAME:
1103     stable_ptr_table[((StgStableName *)q)->sn].keep = rtsTrue;
1104     return copy(q,sizeofW(StgStableName),step);
1105
1106   case FUN_1_0:
1107   case FUN_0_1:
1108   case CONSTR_1_0:
1109   case CONSTR_0_1:
1110     return copy(q,sizeofW(StgHeader)+1,step);
1111
1112   case THUNK_1_0:               /* here because of MIN_UPD_SIZE */
1113   case THUNK_0_1:
1114   case THUNK_1_1:
1115   case THUNK_0_2:
1116   case THUNK_2_0:
1117 #ifdef NO_PROMOTE_THUNKS
1118     if (bd->gen->no == 0 &&
1119         bd->step->no != 0 &&
1120         bd->step->no == bd->gen->n_steps-1) {
1121       step = bd->step;
1122     }
1123 #endif
1124     return copy(q,sizeofW(StgHeader)+2,step);
1125
1126   case FUN_1_1:
1127   case FUN_0_2:
1128   case FUN_2_0:
1129   case CONSTR_1_1:
1130   case CONSTR_0_2:
1131   case CONSTR_2_0:
1132     return copy(q,sizeofW(StgHeader)+2,step);
1133
1134   case FUN:
1135   case THUNK:
1136   case CONSTR:
1137   case IND_PERM:
1138   case IND_OLDGEN_PERM:
1139   case CAF_UNENTERED:
1140   case CAF_ENTERED:
1141   case WEAK:
1142   case FOREIGN:
1143     return copy(q,sizeW_fromITBL(info),step);
1144
1145   case CAF_BLACKHOLE:
1146   case BLACKHOLE:
1147     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1148
1149   case BLACKHOLE_BQ:
1150     to = copy(q,BLACKHOLE_sizeW(),step);
1151     recordMutable((StgMutClosure *)to);
1152     return to;
1153
1154   case THUNK_SELECTOR:
1155     {
1156       const StgInfoTable* selectee_info;
1157       StgClosure* selectee = ((StgSelector*)q)->selectee;
1158
1159     selector_loop:
1160       selectee_info = get_itbl(selectee);
1161       switch (selectee_info->type) {
1162       case CONSTR:
1163       case CONSTR_1_0:
1164       case CONSTR_0_1:
1165       case CONSTR_2_0:
1166       case CONSTR_1_1:
1167       case CONSTR_0_2:
1168       case CONSTR_STATIC:
1169         {
1170           StgNat32 offset = info->layout.selector_offset;
1171
1172           /* check that the size is in range */
1173           ASSERT(offset <
1174                  (StgNat32)(selectee_info->layout.payload.ptrs +
1175                             selectee_info->layout.payload.nptrs));
1176
1177           /* perform the selection! */
1178           q = selectee->payload[offset];
1179
1180           /* if we're already in to-space, there's no need to continue
1181            * with the evacuation, just update the source address with
1182            * a pointer to the (evacuated) constructor field.
1183            */
1184           if (IS_USER_PTR(q)) {
1185             bdescr *bd = Bdescr((P_)q);
1186             if (bd->evacuated) {
1187               if (bd->gen->no < evac_gen) {
1188                 failed_to_evac = rtsTrue;
1189                 TICK_GC_FAILED_PROMOTION();
1190               }
1191               return q;
1192             }
1193           }
1194
1195           /* otherwise, carry on and evacuate this constructor field,
1196            * (but not the constructor itself)
1197            */
1198           goto loop;
1199         }
1200
1201       case IND:
1202       case IND_STATIC:
1203       case IND_PERM:
1204       case IND_OLDGEN:
1205       case IND_OLDGEN_PERM:
1206         selectee = stgCast(StgInd *,selectee)->indirectee;
1207         goto selector_loop;
1208
1209       case CAF_ENTERED:
1210         selectee = stgCast(StgCAF *,selectee)->value;
1211         goto selector_loop;
1212
1213       case EVACUATED:
1214         selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1215         goto selector_loop;
1216
1217       case THUNK:
1218       case THUNK_1_0:
1219       case THUNK_0_1:
1220       case THUNK_2_0:
1221       case THUNK_1_1:
1222       case THUNK_0_2:
1223       case THUNK_STATIC:
1224       case THUNK_SELECTOR:
1225         /* aargh - do recursively???? */
1226       case CAF_UNENTERED:
1227       case CAF_BLACKHOLE:
1228       case BLACKHOLE:
1229       case BLACKHOLE_BQ:
1230         /* not evaluated yet */
1231         break;
1232
1233       default:
1234         barf("evacuate: THUNK_SELECTOR: strange selectee");
1235       }
1236     }
1237     return copy(q,THUNK_SELECTOR_sizeW(),step);
1238
1239   case IND:
1240   case IND_OLDGEN:
1241     /* follow chains of indirections, don't evacuate them */
1242     q = ((StgInd*)q)->indirectee;
1243     goto loop;
1244
1245     /* ToDo: optimise STATIC_LINK for known cases.
1246        - FUN_STATIC       : payload[0]
1247        - THUNK_STATIC     : payload[1]
1248        - IND_STATIC       : payload[1]
1249     */
1250   case THUNK_STATIC:
1251   case FUN_STATIC:
1252     if (info->srt_len == 0) {   /* small optimisation */
1253       return q;
1254     }
1255     /* fall through */
1256   case CONSTR_STATIC:
1257   case IND_STATIC:
1258     /* don't want to evacuate these, but we do want to follow pointers
1259      * from SRTs  - see scavenge_static.
1260      */
1261
1262     /* put the object on the static list, if necessary.
1263      */
1264     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1265       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1266       static_objects = (StgClosure *)q;
1267     }
1268     /* fall through */
1269
1270   case CONSTR_INTLIKE:
1271   case CONSTR_CHARLIKE:
1272   case CONSTR_NOCAF_STATIC:
1273     /* no need to put these on the static linked list, they don't need
1274      * to be scavenged.
1275      */
1276     return q;
1277
1278   case RET_BCO:
1279   case RET_SMALL:
1280   case RET_VEC_SMALL:
1281   case RET_BIG:
1282   case RET_VEC_BIG:
1283   case RET_DYN:
1284   case UPDATE_FRAME:
1285   case STOP_FRAME:
1286   case CATCH_FRAME:
1287   case SEQ_FRAME:
1288     /* shouldn't see these */
1289     barf("evacuate: stack frame\n");
1290
1291   case AP_UPD:
1292   case PAP:
1293     /* these are special - the payload is a copy of a chunk of stack,
1294        tagging and all. */
1295     return copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1296
1297   case EVACUATED:
1298     /* Already evacuated, just return the forwarding address.
1299      * HOWEVER: if the requested destination generation (evac_gen) is
1300      * older than the actual generation (because the object was
1301      * already evacuated to a younger generation) then we have to
1302      * set the failed_to_evac flag to indicate that we couldn't
1303      * manage to promote the object to the desired generation.
1304      */
1305     if (evac_gen > 0) {         /* optimisation */
1306       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1307       if (Bdescr((P_)p)->gen->no < evac_gen) {
1308         /*      fprintf(stderr,"evac failed!\n");*/
1309         failed_to_evac = rtsTrue;
1310         TICK_GC_FAILED_PROMOTION();
1311       }
1312     }
1313     return ((StgEvacuated*)q)->evacuee;
1314
1315   case ARR_WORDS:
1316     {
1317       nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1318
1319       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1320         evacuate_large((P_)q, rtsFalse);
1321         return q;
1322       } else {
1323         /* just copy the block */
1324         return copy(q,size,step);
1325       }
1326     }
1327
1328   case MUT_ARR_PTRS:
1329   case MUT_ARR_PTRS_FROZEN:
1330     {
1331       nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1332
1333       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1334         evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1335         to = q;
1336       } else {
1337         /* just copy the block */
1338         to = copy(q,size,step);
1339         if (info->type == MUT_ARR_PTRS) {
1340           recordMutable((StgMutClosure *)to);
1341         }
1342       }
1343       return to;
1344     }
1345
1346   case TSO:
1347     {
1348       StgTSO *tso = stgCast(StgTSO *,q);
1349       nat size = tso_sizeW(tso);
1350       int diff;
1351
1352       /* Large TSOs don't get moved, so no relocation is required.
1353        */
1354       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1355         evacuate_large((P_)q, rtsTrue);
1356         return q;
1357
1358       /* To evacuate a small TSO, we need to relocate the update frame
1359        * list it contains.
1360        */
1361       } else {
1362         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1363
1364         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1365
1366         /* relocate the stack pointers... */
1367         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1368         new_tso->sp = (StgPtr)new_tso->sp + diff;
1369         new_tso->splim = (StgPtr)new_tso->splim + diff;
1370
1371         relocate_TSO(tso, new_tso);
1372
1373         recordMutable((StgMutClosure *)new_tso);
1374         return (StgClosure *)new_tso;
1375       }
1376     }
1377
1378   case BLOCKED_FETCH:
1379   case FETCH_ME:
1380     fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1381     return q;
1382
1383   default:
1384     barf("evacuate: strange closure type");
1385   }
1386
1387   barf("evacuate");
1388 }
1389
1390 /* -----------------------------------------------------------------------------
1391    relocate_TSO is called just after a TSO has been copied from src to
1392    dest.  It adjusts the update frame list for the new location.
1393    -------------------------------------------------------------------------- */
1394
1395 StgTSO *
1396 relocate_TSO(StgTSO *src, StgTSO *dest)
1397 {
1398   StgUpdateFrame *su;
1399   StgCatchFrame  *cf;
1400   StgSeqFrame    *sf;
1401   int diff;
1402
1403   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1404
1405   su = dest->su;
1406
1407   while ((P_)su < dest->stack + dest->stack_size) {
1408     switch (get_itbl(su)->type) {
1409
1410       /* GCC actually manages to common up these three cases! */
1411
1412     case UPDATE_FRAME:
1413       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1414       su = su->link;
1415       continue;
1416
1417     case CATCH_FRAME:
1418       cf = (StgCatchFrame *)su;
1419       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1420       su = cf->link;
1421       continue;
1422
1423     case SEQ_FRAME:
1424       sf = (StgSeqFrame *)su;
1425       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1426       su = sf->link;
1427       continue;
1428
1429     case STOP_FRAME:
1430       /* all done! */
1431       break;
1432
1433     default:
1434       barf("relocate_TSO");
1435     }
1436     break;
1437   }
1438
1439   return dest;
1440 }
1441
1442 static inline void
1443 scavenge_srt(const StgInfoTable *info)
1444 {
1445   StgClosure **srt, **srt_end;
1446
1447   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1448    * srt field in the info table.  That's ok, because we'll
1449    * never dereference it.
1450    */
1451   srt = stgCast(StgClosure **,info->srt);
1452   srt_end = srt + info->srt_len;
1453   for (; srt < srt_end; srt++) {
1454     evacuate(*srt);
1455   }
1456 }
1457
1458 /* -----------------------------------------------------------------------------
1459    Scavenge a given step until there are no more objects in this step
1460    to scavenge.
1461
1462    evac_gen is set by the caller to be either zero (for a step in a
1463    generation < N) or G where G is the generation of the step being
1464    scavenged.
1465
1466    We sometimes temporarily change evac_gen back to zero if we're
1467    scavenging a mutable object where early promotion isn't such a good
1468    idea.
1469    -------------------------------------------------------------------------- */
1470
1471
1472 static void
1473 scavenge(step *step)
1474 {
1475   StgPtr p, q;
1476   const StgInfoTable *info;
1477   bdescr *bd;
1478   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1479
1480   p = step->scan;
1481   bd = step->scan_bd;
1482
1483   failed_to_evac = rtsFalse;
1484
1485   /* scavenge phase - standard breadth-first scavenging of the
1486    * evacuated objects
1487    */
1488
1489   while (bd != step->hp_bd || p < step->hp) {
1490
1491     /* If we're at the end of this block, move on to the next block */
1492     if (bd != step->hp_bd && p == bd->free) {
1493       bd = bd->link;
1494       p = bd->start;
1495       continue;
1496     }
1497
1498     q = p;                      /* save ptr to object */
1499
1500     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1501                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1502
1503     info = get_itbl((StgClosure *)p);
1504     switch (info -> type) {
1505
1506     case BCO:
1507       {
1508         StgBCO* bco = stgCast(StgBCO*,p);
1509         nat i;
1510         for (i = 0; i < bco->n_ptrs; i++) {
1511           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1512         }
1513         p += bco_sizeW(bco);
1514         break;
1515       }
1516
1517     case MVAR:
1518       /* treat MVars specially, because we don't want to evacuate the
1519        * mut_link field in the middle of the closure.
1520        */
1521       {
1522         StgMVar *mvar = ((StgMVar *)p);
1523         evac_gen = 0;
1524         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1525         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1526         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1527         p += sizeofW(StgMVar);
1528         evac_gen = saved_evac_gen;
1529         break;
1530       }
1531
1532     case THUNK_2_0:
1533     case FUN_2_0:
1534       scavenge_srt(info);
1535     case CONSTR_2_0:
1536       ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1537       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1538       p += sizeofW(StgHeader) + 2;
1539       break;
1540
1541     case THUNK_1_0:
1542       scavenge_srt(info);
1543       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1544       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1545       break;
1546
1547     case FUN_1_0:
1548       scavenge_srt(info);
1549     case CONSTR_1_0:
1550       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1551       p += sizeofW(StgHeader) + 1;
1552       break;
1553
1554     case THUNK_0_1:
1555       scavenge_srt(info);
1556       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1557       break;
1558
1559     case FUN_0_1:
1560       scavenge_srt(info);
1561     case CONSTR_0_1:
1562       p += sizeofW(StgHeader) + 1;
1563       break;
1564
1565     case THUNK_0_2:
1566     case FUN_0_2:
1567       scavenge_srt(info);
1568     case CONSTR_0_2:
1569       p += sizeofW(StgHeader) + 2;
1570       break;
1571
1572     case THUNK_1_1:
1573     case FUN_1_1:
1574       scavenge_srt(info);
1575     case CONSTR_1_1:
1576       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1577       p += sizeofW(StgHeader) + 2;
1578       break;
1579
1580     case FUN:
1581     case THUNK:
1582       scavenge_srt(info);
1583       /* fall through */
1584
1585     case CONSTR:
1586     case WEAK:
1587     case FOREIGN:
1588     case STABLE_NAME:
1589     case IND_PERM:
1590     case IND_OLDGEN_PERM:
1591     case CAF_UNENTERED:
1592     case CAF_ENTERED:
1593       {
1594         StgPtr end;
1595
1596         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1597         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1598           (StgClosure *)*p = evacuate((StgClosure *)*p);
1599         }
1600         p += info->layout.payload.nptrs;
1601         break;
1602       }
1603
1604     case MUT_VAR:
1605       /* ignore MUT_CONSs */
1606       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1607         evac_gen = 0;
1608         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1609         evac_gen = saved_evac_gen;
1610       }
1611       p += sizeofW(StgMutVar);
1612       break;
1613
1614     case CAF_BLACKHOLE:
1615     case BLACKHOLE:
1616         p += BLACKHOLE_sizeW();
1617         break;
1618
1619     case BLACKHOLE_BQ:
1620       {
1621         StgBlockingQueue *bh = (StgBlockingQueue *)p;
1622         (StgClosure *)bh->blocking_queue =
1623           evacuate((StgClosure *)bh->blocking_queue);
1624         if (failed_to_evac) {
1625           failed_to_evac = rtsFalse;
1626           recordMutable((StgMutClosure *)bh);
1627         }
1628         p += BLACKHOLE_sizeW();
1629         break;
1630       }
1631
1632     case THUNK_SELECTOR:
1633       {
1634         StgSelector *s = (StgSelector *)p;
1635         s->selectee = evacuate(s->selectee);
1636         p += THUNK_SELECTOR_sizeW();
1637         break;
1638       }
1639
1640     case IND:
1641     case IND_OLDGEN:
1642       barf("scavenge:IND???\n");
1643
1644     case CONSTR_INTLIKE:
1645     case CONSTR_CHARLIKE:
1646     case CONSTR_STATIC:
1647     case CONSTR_NOCAF_STATIC:
1648     case THUNK_STATIC:
1649     case FUN_STATIC:
1650     case IND_STATIC:
1651       /* Shouldn't see a static object here. */
1652       barf("scavenge: STATIC object\n");
1653
1654     case RET_BCO:
1655     case RET_SMALL:
1656     case RET_VEC_SMALL:
1657     case RET_BIG:
1658     case RET_VEC_BIG:
1659     case RET_DYN:
1660     case UPDATE_FRAME:
1661     case STOP_FRAME:
1662     case CATCH_FRAME:
1663     case SEQ_FRAME:
1664       /* Shouldn't see stack frames here. */
1665       barf("scavenge: stack frame\n");
1666
1667     case AP_UPD: /* same as PAPs */
1668     case PAP:
1669       /* Treat a PAP just like a section of stack, not forgetting to
1670        * evacuate the function pointer too...
1671        */
1672       {
1673         StgPAP* pap = stgCast(StgPAP*,p);
1674
1675         pap->fun = evacuate(pap->fun);
1676         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1677         p += pap_sizeW(pap);
1678         break;
1679       }
1680
1681     case ARR_WORDS:
1682       /* nothing to follow */
1683       p += arr_words_sizeW(stgCast(StgArrWords*,p));
1684       break;
1685
1686     case MUT_ARR_PTRS:
1687       /* follow everything */
1688       {
1689         StgPtr next;
1690
1691         evac_gen = 0;           /* repeatedly mutable */
1692         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1693         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1694           (StgClosure *)*p = evacuate((StgClosure *)*p);
1695         }
1696         evac_gen = saved_evac_gen;
1697         break;
1698       }
1699
1700     case MUT_ARR_PTRS_FROZEN:
1701       /* follow everything */
1702       {
1703         StgPtr start = p, next;
1704
1705         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1706         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1707           (StgClosure *)*p = evacuate((StgClosure *)*p);
1708         }
1709         if (failed_to_evac) {
1710           /* we can do this easier... */
1711           recordMutable((StgMutClosure *)start);
1712           failed_to_evac = rtsFalse;
1713         }
1714         break;
1715       }
1716
1717     case TSO:
1718       {
1719         StgTSO *tso;
1720
1721         tso = (StgTSO *)p;
1722         evac_gen = 0;
1723         /* chase the link field for any TSOs on the same queue */
1724         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1725         /* scavenge this thread's stack */
1726         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1727         evac_gen = saved_evac_gen;
1728         p += tso_sizeW(tso);
1729         break;
1730       }
1731
1732     case BLOCKED_FETCH:
1733     case FETCH_ME:
1734     case EVACUATED:
1735       barf("scavenge: unimplemented/strange closure type\n");
1736
1737     default:
1738       barf("scavenge");
1739     }
1740
1741     /* If we didn't manage to promote all the objects pointed to by
1742      * the current object, then we have to designate this object as
1743      * mutable (because it contains old-to-new generation pointers).
1744      */
1745     if (failed_to_evac) {
1746       mkMutCons((StgClosure *)q, &generations[evac_gen]);
1747       failed_to_evac = rtsFalse;
1748     }
1749   }
1750
1751   step->scan_bd = bd;
1752   step->scan = p;
1753 }
1754
1755 /* -----------------------------------------------------------------------------
1756    Scavenge one object.
1757
1758    This is used for objects that are temporarily marked as mutable
1759    because they contain old-to-new generation pointers.  Only certain
1760    objects can have this property.
1761    -------------------------------------------------------------------------- */
1762 static rtsBool
1763 scavenge_one(StgClosure *p)
1764 {
1765   StgInfoTable *info;
1766   rtsBool no_luck;
1767
1768   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1769                || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1770
1771   info = get_itbl(p);
1772
1773   switch (info -> type) {
1774
1775   case FUN:
1776   case FUN_1_0:                 /* hardly worth specialising these guys */
1777   case FUN_0_1:
1778   case FUN_1_1:
1779   case FUN_0_2:
1780   case FUN_2_0:
1781   case THUNK:
1782   case THUNK_1_0:
1783   case THUNK_0_1:
1784   case THUNK_1_1:
1785   case THUNK_0_2:
1786   case THUNK_2_0:
1787   case CONSTR:
1788   case CONSTR_1_0:
1789   case CONSTR_0_1:
1790   case CONSTR_1_1:
1791   case CONSTR_0_2:
1792   case CONSTR_2_0:
1793   case WEAK:
1794   case FOREIGN:
1795   case IND_PERM:
1796   case IND_OLDGEN_PERM:
1797   case CAF_UNENTERED:
1798   case CAF_ENTERED:
1799     {
1800       StgPtr q, end;
1801
1802       end = (P_)p->payload + info->layout.payload.ptrs;
1803       for (q = (P_)p->payload; q < end; q++) {
1804         (StgClosure *)*q = evacuate((StgClosure *)*q);
1805       }
1806       break;
1807     }
1808
1809   case CAF_BLACKHOLE:
1810   case BLACKHOLE:
1811       break;
1812
1813   case THUNK_SELECTOR:
1814     {
1815       StgSelector *s = (StgSelector *)p;
1816       s->selectee = evacuate(s->selectee);
1817       break;
1818     }
1819
1820   case AP_UPD: /* same as PAPs */
1821   case PAP:
1822     /* Treat a PAP just like a section of stack, not forgetting to
1823      * evacuate the function pointer too...
1824      */
1825     {
1826       StgPAP* pap = (StgPAP *)p;
1827
1828       pap->fun = evacuate(pap->fun);
1829       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1830       break;
1831     }
1832
1833   case IND_OLDGEN:
1834     /* This might happen if for instance a MUT_CONS was pointing to a
1835      * THUNK which has since been updated.  The IND_OLDGEN will
1836      * be on the mutable list anyway, so we don't need to do anything
1837      * here.
1838      */
1839     break;
1840
1841   default:
1842     barf("scavenge_one: strange object");
1843   }
1844
1845   no_luck = failed_to_evac;
1846   failed_to_evac = rtsFalse;
1847   return (no_luck);
1848 }
1849
1850
1851 /* -----------------------------------------------------------------------------
1852    Scavenging mutable lists.
1853
1854    We treat the mutable list of each generation > N (i.e. all the
1855    generations older than the one being collected) as roots.  We also
1856    remove non-mutable objects from the mutable list at this point.
1857    -------------------------------------------------------------------------- */
1858
1859 static void
1860 scavenge_mut_once_list(generation *gen)
1861 {
1862   StgInfoTable *info;
1863   StgMutClosure *p, *next, *new_list;
1864
1865   p = gen->mut_once_list;
1866   new_list = END_MUT_LIST;
1867   next = p->mut_link;
1868
1869   evac_gen = gen->no;
1870   failed_to_evac = rtsFalse;
1871
1872   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1873
1874     /* make sure the info pointer is into text space */
1875     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1876                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1877
1878     info = get_itbl(p);
1879     switch(info->type) {
1880
1881     case IND_OLDGEN:
1882     case IND_OLDGEN_PERM:
1883     case IND_STATIC:
1884       /* Try to pull the indirectee into this generation, so we can
1885        * remove the indirection from the mutable list.
1886        */
1887       ((StgIndOldGen *)p)->indirectee =
1888         evacuate(((StgIndOldGen *)p)->indirectee);
1889
1890 #if 0
1891       /* Debugging code to print out the size of the thing we just
1892        * promoted
1893        */
1894       {
1895         StgPtr start = gen->steps[0].scan;
1896         bdescr *start_bd = gen->steps[0].scan_bd;
1897         nat size = 0;
1898         scavenge(&gen->steps[0]);
1899         if (start_bd != gen->steps[0].scan_bd) {
1900           size += (P_)BLOCK_ROUND_UP(start) - start;
1901           start_bd = start_bd->link;
1902           while (start_bd != gen->steps[0].scan_bd) {
1903             size += BLOCK_SIZE_W;
1904             start_bd = start_bd->link;
1905           }
1906           size += gen->steps[0].scan -
1907             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
1908         } else {
1909           size = gen->steps[0].scan - start;
1910         }
1911         fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
1912       }
1913 #endif
1914
1915       /* failed_to_evac might happen if we've got more than two
1916        * generations, we're collecting only generation 0, the
1917        * indirection resides in generation 2 and the indirectee is
1918        * in generation 1.
1919        */
1920       if (failed_to_evac) {
1921         failed_to_evac = rtsFalse;
1922         p->mut_link = new_list;
1923         new_list = p;
1924       } else {
1925         /* the mut_link field of an IND_STATIC is overloaded as the
1926          * static link field too (it just so happens that we don't need
1927          * both at the same time), so we need to NULL it out when
1928          * removing this object from the mutable list because the static
1929          * link fields are all assumed to be NULL before doing a major
1930          * collection.
1931          */
1932         p->mut_link = NULL;
1933       }
1934       continue;
1935
1936     case MUT_VAR:
1937       /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
1938        * it from the mutable list if possible by promoting whatever it
1939        * points to.
1940        */
1941       ASSERT(p->header.info == &MUT_CONS_info);
1942       if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
1943         /* didn't manage to promote everything, so put the
1944          * MUT_CONS back on the list.
1945          */
1946         p->mut_link = new_list;
1947         new_list = p;
1948       }
1949       continue;
1950
1951     default:
1952       /* shouldn't have anything else on the mutables list */
1953       barf("scavenge_mut_once_list: strange object?");
1954     }
1955   }
1956
1957   gen->mut_once_list = new_list;
1958 }
1959
1960
1961 static void
1962 scavenge_mutable_list(generation *gen)
1963 {
1964   StgInfoTable *info;
1965   StgMutClosure *p, *next;
1966
1967   p = gen->saved_mut_list;
1968   next = p->mut_link;
1969
1970   evac_gen = 0;
1971   failed_to_evac = rtsFalse;
1972
1973   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1974
1975     /* make sure the info pointer is into text space */
1976     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1977                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1978
1979     info = get_itbl(p);
1980     switch(info->type) {
1981
1982     case MUT_ARR_PTRS_FROZEN:
1983       /* remove this guy from the mutable list, but follow the ptrs
1984        * anyway (and make sure they get promoted to this gen).
1985        */
1986       {
1987         StgPtr end, q;
1988
1989         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1990         evac_gen = gen->no;
1991         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1992           (StgClosure *)*q = evacuate((StgClosure *)*q);
1993         }
1994         evac_gen = 0;
1995
1996         if (failed_to_evac) {
1997           failed_to_evac = rtsFalse;
1998           p->mut_link = gen->mut_list;
1999           gen->mut_list = p;
2000         }
2001         continue;
2002       }
2003
2004     case MUT_ARR_PTRS:
2005       /* follow everything */
2006       p->mut_link = gen->mut_list;
2007       gen->mut_list = p;
2008       {
2009         StgPtr end, q;
2010
2011         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2012         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2013           (StgClosure *)*q = evacuate((StgClosure *)*q);
2014         }
2015         continue;
2016       }
2017
2018     case MUT_VAR:
2019       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2020        * it from the mutable list if possible by promoting whatever it
2021        * points to.
2022        */
2023       ASSERT(p->header.info != &MUT_CONS_info);
2024       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2025       p->mut_link = gen->mut_list;
2026       gen->mut_list = p;
2027       continue;
2028
2029     case MVAR:
2030       {
2031         StgMVar *mvar = (StgMVar *)p;
2032         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2033         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2034         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2035         p->mut_link = gen->mut_list;
2036         gen->mut_list = p;
2037         continue;
2038       }
2039
2040     case TSO:
2041       /* follow ptrs and remove this from the mutable list */
2042       {
2043         StgTSO *tso = (StgTSO *)p;
2044
2045         /* Don't bother scavenging if this thread is dead
2046          */
2047         if (!(tso->whatNext == ThreadComplete ||
2048               tso->whatNext == ThreadKilled)) {
2049           /* Don't need to chase the link field for any TSOs on the
2050            * same queue. Just scavenge this thread's stack
2051            */
2052           scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2053         }
2054
2055         /* Don't take this TSO off the mutable list - it might still
2056          * point to some younger objects (because we set evac_gen to 0
2057          * above).
2058          */
2059         tso->mut_link = gen->mut_list;
2060         gen->mut_list = (StgMutClosure *)tso;
2061         continue;
2062       }
2063
2064     case BLACKHOLE_BQ:
2065       {
2066         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2067         (StgClosure *)bh->blocking_queue =
2068           evacuate((StgClosure *)bh->blocking_queue);
2069         p->mut_link = gen->mut_list;
2070         gen->mut_list = p;
2071         continue;
2072       }
2073
2074     default:
2075       /* shouldn't have anything else on the mutables list */
2076       barf("scavenge_mut_list: strange object?");
2077     }
2078   }
2079 }
2080
2081 static void
2082 scavenge_static(void)
2083 {
2084   StgClosure* p = static_objects;
2085   const StgInfoTable *info;
2086
2087   /* Always evacuate straight to the oldest generation for static
2088    * objects */
2089   evac_gen = oldest_gen->no;
2090
2091   /* keep going until we've scavenged all the objects on the linked
2092      list... */
2093   while (p != END_OF_STATIC_LIST) {
2094
2095     info = get_itbl(p);
2096
2097     /* make sure the info pointer is into text space */
2098     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2099                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2100
2101     /* Take this object *off* the static_objects list,
2102      * and put it on the scavenged_static_objects list.
2103      */
2104     static_objects = STATIC_LINK(info,p);
2105     STATIC_LINK(info,p) = scavenged_static_objects;
2106     scavenged_static_objects = p;
2107
2108     switch (info -> type) {
2109
2110     case IND_STATIC:
2111       {
2112         StgInd *ind = (StgInd *)p;
2113         ind->indirectee = evacuate(ind->indirectee);
2114
2115         /* might fail to evacuate it, in which case we have to pop it
2116          * back on the mutable list (and take it off the
2117          * scavenged_static list because the static link and mut link
2118          * pointers are one and the same).
2119          */
2120         if (failed_to_evac) {
2121           failed_to_evac = rtsFalse;
2122           scavenged_static_objects = STATIC_LINK(info,p);
2123           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2124           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2125         }
2126         break;
2127       }
2128
2129     case THUNK_STATIC:
2130     case FUN_STATIC:
2131       scavenge_srt(info);
2132       /* fall through */
2133
2134     case CONSTR_STATIC:
2135       {
2136         StgPtr q, next;
2137
2138         next = (P_)p->payload + info->layout.payload.ptrs;
2139         /* evacuate the pointers */
2140         for (q = (P_)p->payload; q < next; q++) {
2141           (StgClosure *)*q = evacuate((StgClosure *)*q);
2142         }
2143         break;
2144       }
2145
2146     default:
2147       barf("scavenge_static");
2148     }
2149
2150     ASSERT(failed_to_evac == rtsFalse);
2151
2152     /* get the next static object from the list.  Remeber, there might
2153      * be more stuff on this list now that we've done some evacuating!
2154      * (static_objects is a global)
2155      */
2156     p = static_objects;
2157   }
2158 }
2159
2160 /* -----------------------------------------------------------------------------
2161    scavenge_stack walks over a section of stack and evacuates all the
2162    objects pointed to by it.  We can use the same code for walking
2163    PAPs, since these are just sections of copied stack.
2164    -------------------------------------------------------------------------- */
2165
2166 static void
2167 scavenge_stack(StgPtr p, StgPtr stack_end)
2168 {
2169   StgPtr q;
2170   const StgInfoTable* info;
2171   StgNat32 bitmap;
2172
2173   /*
2174    * Each time around this loop, we are looking at a chunk of stack
2175    * that starts with either a pending argument section or an
2176    * activation record.
2177    */
2178
2179   while (p < stack_end) {
2180     q = *stgCast(StgPtr*,p);
2181
2182     /* If we've got a tag, skip over that many words on the stack */
2183     if (IS_ARG_TAG(stgCast(StgWord,q))) {
2184       p += ARG_SIZE(q);
2185       p++; continue;
2186     }
2187
2188     /* Is q a pointer to a closure?
2189      */
2190     if (! LOOKS_LIKE_GHC_INFO(q)) {
2191
2192 #ifdef DEBUG
2193       if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
2194         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2195       }
2196       /* otherwise, must be a pointer into the allocation space.
2197        */
2198 #endif
2199
2200       (StgClosure *)*p = evacuate((StgClosure *)q);
2201       p++;
2202       continue;
2203     }
2204
2205     /*
2206      * Otherwise, q must be the info pointer of an activation
2207      * record.  All activation records have 'bitmap' style layout
2208      * info.
2209      */
2210     info  = get_itbl(stgCast(StgClosure*,p));
2211
2212     switch (info->type) {
2213
2214       /* Dynamic bitmap: the mask is stored on the stack */
2215     case RET_DYN:
2216       bitmap = stgCast(StgRetDyn*,p)->liveness;
2217       p      = &payloadWord(stgCast(StgRetDyn*,p),0);
2218       goto small_bitmap;
2219
2220       /* probably a slow-entry point return address: */
2221     case FUN:
2222     case FUN_STATIC:
2223       p++;
2224       goto follow_srt;
2225
2226       /* Specialised code for update frames, since they're so common.
2227        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2228        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2229        */
2230     case UPDATE_FRAME:
2231       {
2232         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2233         StgClosure *to;
2234         StgClosureType type = get_itbl(frame->updatee)->type;
2235
2236         p += sizeofW(StgUpdateFrame);
2237         if (type == EVACUATED) {
2238           frame->updatee = evacuate(frame->updatee);
2239           continue;
2240         } else {
2241           bdescr *bd = Bdescr((P_)frame->updatee);
2242           step *step;
2243           if (bd->gen->no > N) {
2244             if (bd->gen->no < evac_gen) {
2245               failed_to_evac = rtsTrue;
2246             }
2247             continue;
2248           }
2249
2250           /* Don't promote blackholes */
2251           step = bd->step;
2252           if (!(step->gen->no == 0 &&
2253                 step->no != 0 &&
2254                 step->no == step->gen->n_steps-1)) {
2255             step = step->to;
2256           }
2257
2258           switch (type) {
2259           case BLACKHOLE:
2260           case CAF_BLACKHOLE:
2261             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2262                           sizeofW(StgHeader), step);
2263             frame->updatee = to;
2264             continue;
2265           case BLACKHOLE_BQ:
2266             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2267             frame->updatee = to;
2268             recordMutable((StgMutClosure *)to);
2269             continue;
2270           default:
2271             barf("scavenge_stack: UPDATE_FRAME updatee");
2272           }
2273         }
2274       }
2275
2276       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2277     case RET_BCO:
2278     case RET_SMALL:
2279     case RET_VEC_SMALL:
2280     case STOP_FRAME:
2281     case CATCH_FRAME:
2282     case SEQ_FRAME:
2283       bitmap = info->layout.bitmap;
2284       p++;
2285     small_bitmap:
2286       while (bitmap != 0) {
2287         if ((bitmap & 1) == 0) {
2288           (StgClosure *)*p = evacuate((StgClosure *)*p);
2289         }
2290         p++;
2291         bitmap = bitmap >> 1;
2292       }
2293
2294     follow_srt:
2295       scavenge_srt(info);
2296       continue;
2297
2298       /* large bitmap (> 32 entries) */
2299     case RET_BIG:
2300     case RET_VEC_BIG:
2301       {
2302         StgPtr q;
2303         StgLargeBitmap *large_bitmap;
2304         nat i;
2305
2306         large_bitmap = info->layout.large_bitmap;
2307         p++;
2308
2309         for (i=0; i<large_bitmap->size; i++) {
2310           bitmap = large_bitmap->bitmap[i];
2311           q = p + sizeof(W_) * 8;
2312           while (bitmap != 0) {
2313             if ((bitmap & 1) == 0) {
2314               (StgClosure *)*p = evacuate((StgClosure *)*p);
2315             }
2316             p++;
2317             bitmap = bitmap >> 1;
2318           }
2319           if (i+1 < large_bitmap->size) {
2320             while (p < q) {
2321               (StgClosure *)*p = evacuate((StgClosure *)*p);
2322               p++;
2323             }
2324           }
2325         }
2326
2327         /* and don't forget to follow the SRT */
2328         goto follow_srt;
2329       }
2330
2331     default:
2332       barf("scavenge_stack: weird activation record found on stack.\n");
2333     }
2334   }
2335 }
2336
2337 /*-----------------------------------------------------------------------------
2338   scavenge the large object list.
2339
2340   evac_gen set by caller; similar games played with evac_gen as with
2341   scavenge() - see comment at the top of scavenge().  Most large
2342   objects are (repeatedly) mutable, so most of the time evac_gen will
2343   be zero.
2344   --------------------------------------------------------------------------- */
2345
2346 static void
2347 scavenge_large(step *step)
2348 {
2349   bdescr *bd;
2350   StgPtr p;
2351   const StgInfoTable* info;
2352   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2353
2354   evac_gen = 0;                 /* most objects are mutable */
2355   bd = step->new_large_objects;
2356
2357   for (; bd != NULL; bd = step->new_large_objects) {
2358
2359     /* take this object *off* the large objects list and put it on
2360      * the scavenged large objects list.  This is so that we can
2361      * treat new_large_objects as a stack and push new objects on
2362      * the front when evacuating.
2363      */
2364     step->new_large_objects = bd->link;
2365     dbl_link_onto(bd, &step->scavenged_large_objects);
2366
2367     p = bd->start;
2368     info  = get_itbl(stgCast(StgClosure*,p));
2369
2370     switch (info->type) {
2371
2372     /* only certain objects can be "large"... */
2373
2374     case ARR_WORDS:
2375       /* nothing to follow */
2376       continue;
2377
2378     case MUT_ARR_PTRS:
2379       /* follow everything */
2380       {
2381         StgPtr next;
2382
2383         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2384         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2385           (StgClosure *)*p = evacuate((StgClosure *)*p);
2386         }
2387         continue;
2388       }
2389
2390     case MUT_ARR_PTRS_FROZEN:
2391       /* follow everything */
2392       {
2393         StgPtr start = p, next;
2394
2395         evac_gen = saved_evac_gen; /* not really mutable */
2396         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2397         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2398           (StgClosure *)*p = evacuate((StgClosure *)*p);
2399         }
2400         evac_gen = 0;
2401         if (failed_to_evac) {
2402           recordMutable((StgMutClosure *)start);
2403         }
2404         continue;
2405       }
2406
2407     case BCO:
2408       {
2409         StgBCO* bco = stgCast(StgBCO*,p);
2410         nat i;
2411         evac_gen = saved_evac_gen;
2412         for (i = 0; i < bco->n_ptrs; i++) {
2413           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2414         }
2415         evac_gen = 0;
2416         continue;
2417       }
2418
2419     case TSO:
2420       {
2421         StgTSO *tso;
2422
2423         tso = (StgTSO *)p;
2424         /* chase the link field for any TSOs on the same queue */
2425         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2426         /* scavenge this thread's stack */
2427         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2428         continue;
2429       }
2430
2431     default:
2432       barf("scavenge_large: unknown/strange object");
2433     }
2434   }
2435 }
2436
2437 static void
2438 zeroStaticObjectList(StgClosure* first_static)
2439 {
2440   StgClosure* p;
2441   StgClosure* link;
2442   const StgInfoTable *info;
2443
2444   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2445     info = get_itbl(p);
2446     link = STATIC_LINK(info, p);
2447     STATIC_LINK(info,p) = NULL;
2448   }
2449 }
2450
2451 /* This function is only needed because we share the mutable link
2452  * field with the static link field in an IND_STATIC, so we have to
2453  * zero the mut_link field before doing a major GC, which needs the
2454  * static link field.
2455  *
2456  * It doesn't do any harm to zero all the mutable link fields on the
2457  * mutable list.
2458  */
2459 static void
2460 zeroMutableList(StgMutClosure *first)
2461 {
2462   StgMutClosure *next, *c;
2463
2464   for (c = first; c != END_MUT_LIST; c = next) {
2465     next = c->mut_link;
2466     c->mut_link = NULL;
2467   }
2468 }
2469
2470 /* -----------------------------------------------------------------------------
2471    Reverting CAFs
2472    -------------------------------------------------------------------------- */
2473
2474 void RevertCAFs(void)
2475 {
2476   while (enteredCAFs != END_CAF_LIST) {
2477     StgCAF* caf = enteredCAFs;
2478
2479     enteredCAFs = caf->link;
2480     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2481     SET_INFO(caf,&CAF_UNENTERED_info);
2482     caf->value = stgCast(StgClosure*,0xdeadbeef);
2483     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2484   }
2485 }
2486
2487 void revertDeadCAFs(void)
2488 {
2489     StgCAF* caf = enteredCAFs;
2490     enteredCAFs = END_CAF_LIST;
2491     while (caf != END_CAF_LIST) {
2492         StgCAF* next = caf->link;
2493
2494         switch(GET_INFO(caf)->type) {
2495         case EVACUATED:
2496             {
2497                 /* This object has been evacuated, it must be live. */
2498                 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2499                 new->link = enteredCAFs;
2500                 enteredCAFs = new;
2501                 break;
2502             }
2503         case CAF_ENTERED:
2504             {
2505                 SET_INFO(caf,&CAF_UNENTERED_info);
2506                 caf->value = stgCast(StgClosure*,0xdeadbeef);
2507                 caf->link  = stgCast(StgCAF*,0xdeadbeef);
2508                 break;
2509             }
2510         default:
2511                 barf("revertDeadCAFs: enteredCAFs list corrupted");
2512         }
2513         caf = next;
2514     }
2515 }
2516
2517 /* -----------------------------------------------------------------------------
2518    Sanity code for CAF garbage collection.
2519
2520    With DEBUG turned on, we manage a CAF list in addition to the SRT
2521    mechanism.  After GC, we run down the CAF list and blackhole any
2522    CAFs which have been garbage collected.  This means we get an error
2523    whenever the program tries to enter a garbage collected CAF.
2524
2525    Any garbage collected CAFs are taken off the CAF list at the same
2526    time.
2527    -------------------------------------------------------------------------- */
2528
2529 #ifdef DEBUG
2530 static void
2531 gcCAFs(void)
2532 {
2533   StgClosure*  p;
2534   StgClosure** pp;
2535   const StgInfoTable *info;
2536   nat i;
2537
2538   i = 0;
2539   p = caf_list;
2540   pp = &caf_list;
2541
2542   while (p != NULL) {
2543
2544     info = get_itbl(p);
2545
2546     ASSERT(info->type == IND_STATIC);
2547
2548     if (STATIC_LINK(info,p) == NULL) {
2549       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2550       /* black hole it */
2551       SET_INFO(p,&BLACKHOLE_info);
2552       p = STATIC_LINK2(info,p);
2553       *pp = p;
2554     }
2555     else {
2556       pp = &STATIC_LINK2(info,p);
2557       p = *pp;
2558       i++;
2559     }
2560
2561   }
2562
2563   /*  fprintf(stderr, "%d CAFs live\n", i); */
2564 }
2565 #endif
2566
2567 /* -----------------------------------------------------------------------------
2568    Lazy black holing.
2569
2570    Whenever a thread returns to the scheduler after possibly doing
2571    some work, we have to run down the stack and black-hole all the
2572    closures referred to by update frames.
2573    -------------------------------------------------------------------------- */
2574
2575 static void
2576 threadLazyBlackHole(StgTSO *tso)
2577 {
2578   StgUpdateFrame *update_frame;
2579   StgBlockingQueue *bh;
2580   StgPtr stack_end;
2581
2582   stack_end = &tso->stack[tso->stack_size];
2583   update_frame = tso->su;
2584
2585   while (1) {
2586     switch (get_itbl(update_frame)->type) {
2587
2588     case CATCH_FRAME:
2589       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2590       break;
2591
2592     case UPDATE_FRAME:
2593       bh = (StgBlockingQueue *)update_frame->updatee;
2594
2595       /* if the thunk is already blackholed, it means we've also
2596        * already blackholed the rest of the thunks on this stack,
2597        * so we can stop early.
2598        *
2599        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2600        * don't interfere with this optimisation.
2601        */
2602       if (bh->header.info == &BLACKHOLE_info) {
2603         return;
2604       }
2605
2606       if (bh->header.info != &BLACKHOLE_BQ_info &&
2607           bh->header.info != &CAF_BLACKHOLE_info) {
2608         SET_INFO(bh,&BLACKHOLE_info);
2609       }
2610
2611       update_frame = update_frame->link;
2612       break;
2613
2614     case SEQ_FRAME:
2615       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2616       break;
2617
2618     case STOP_FRAME:
2619       return;
2620     default:
2621       barf("threadPaused");
2622     }
2623   }
2624 }
2625
2626 /* -----------------------------------------------------------------------------
2627  * Stack squeezing
2628  *
2629  * Code largely pinched from old RTS, then hacked to bits.  We also do
2630  * lazy black holing here.
2631  *
2632  * -------------------------------------------------------------------------- */
2633
2634 static void
2635 threadSqueezeStack(StgTSO *tso)
2636 {
2637   lnat displacement = 0;
2638   StgUpdateFrame *frame;
2639   StgUpdateFrame *next_frame;                   /* Temporally next */
2640   StgUpdateFrame *prev_frame;                   /* Temporally previous */
2641   StgPtr bottom;
2642   rtsBool prev_was_update_frame;
2643
2644   bottom = &(tso->stack[tso->stack_size]);
2645   frame  = tso->su;
2646
2647   /* There must be at least one frame, namely the STOP_FRAME.
2648    */
2649   ASSERT((P_)frame < bottom);
2650
2651   /* Walk down the stack, reversing the links between frames so that
2652    * we can walk back up as we squeeze from the bottom.  Note that
2653    * next_frame and prev_frame refer to next and previous as they were
2654    * added to the stack, rather than the way we see them in this
2655    * walk. (It makes the next loop less confusing.)
2656    *
2657    * Stop if we find an update frame pointing to a black hole
2658    * (see comment in threadLazyBlackHole()).
2659    */
2660
2661   next_frame = NULL;
2662   while ((P_)frame < bottom - 1) {  /* bottom - 1 is the STOP_FRAME */
2663     prev_frame = frame->link;
2664     frame->link = next_frame;
2665     next_frame = frame;
2666     frame = prev_frame;
2667     if (get_itbl(frame)->type == UPDATE_FRAME
2668         && frame->updatee->header.info == &BLACKHOLE_info) {
2669         break;
2670     }
2671   }
2672
2673   /* Now, we're at the bottom.  Frame points to the lowest update
2674    * frame on the stack, and its link actually points to the frame
2675    * above. We have to walk back up the stack, squeezing out empty
2676    * update frames and turning the pointers back around on the way
2677    * back up.
2678    *
2679    * The bottom-most frame (the STOP_FRAME) has not been altered, and
2680    * we never want to eliminate it anyway.  Just walk one step up
2681    * before starting to squeeze. When you get to the topmost frame,
2682    * remember that there are still some words above it that might have
2683    * to be moved.
2684    */
2685
2686   prev_frame = frame;
2687   frame = next_frame;
2688
2689   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2690
2691   /*
2692    * Loop through all of the frames (everything except the very
2693    * bottom).  Things are complicated by the fact that we have
2694    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2695    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2696    */
2697   while (frame != NULL) {
2698     StgPtr sp;
2699     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2700     rtsBool is_update_frame;
2701
2702     next_frame = frame->link;
2703     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2704
2705     /* Check to see if
2706      *   1. both the previous and current frame are update frames
2707      *   2. the current frame is empty
2708      */
2709     if (prev_was_update_frame && is_update_frame &&
2710         (P_)prev_frame == frame_bottom + displacement) {
2711
2712       /* Now squeeze out the current frame */
2713       StgClosure *updatee_keep   = prev_frame->updatee;
2714       StgClosure *updatee_bypass = frame->updatee;
2715
2716 #if 0 /* DEBUG */
2717       fprintf(stderr, "squeezing frame at %p\n", frame);
2718 #endif
2719
2720       /* Deal with blocking queues.  If both updatees have blocked
2721        * threads, then we should merge the queues into the update
2722        * frame that we're keeping.
2723        *
2724        * Alternatively, we could just wake them up: they'll just go
2725        * straight to sleep on the proper blackhole!  This is less code
2726        * and probably less bug prone, although it's probably much
2727        * slower --SDM
2728        */
2729 #if 0 /* do it properly... */
2730       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
2731         /* Sigh.  It has one.  Don't lose those threads! */
2732           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2733           /* Urgh.  Two queues.  Merge them. */
2734           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2735
2736           while (keep_tso->link != END_TSO_QUEUE) {
2737             keep_tso = keep_tso->link;
2738           }
2739           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2740
2741         } else {
2742           /* For simplicity, just swap the BQ for the BH */
2743           P_ temp = updatee_keep;
2744
2745           updatee_keep = updatee_bypass;
2746           updatee_bypass = temp;
2747
2748           /* Record the swap in the kept frame (below) */
2749           prev_frame->updatee = updatee_keep;
2750         }
2751       }
2752 #endif
2753
2754       TICK_UPD_SQUEEZED();
2755       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2756
2757       sp = (P_)frame - 1;       /* sp = stuff to slide */
2758       displacement += sizeofW(StgUpdateFrame);
2759
2760     } else {
2761       /* No squeeze for this frame */
2762       sp = frame_bottom - 1;    /* Keep the current frame */
2763
2764       /* Do lazy black-holing.
2765        */
2766       if (is_update_frame) {
2767         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2768         if (bh->header.info != &BLACKHOLE_BQ_info &&
2769             bh->header.info != &CAF_BLACKHOLE_info) {
2770           SET_INFO(bh,&BLACKHOLE_info);
2771         }
2772       }
2773
2774       /* Fix the link in the current frame (should point to the frame below) */
2775       frame->link = prev_frame;
2776       prev_was_update_frame = is_update_frame;
2777     }
2778
2779     /* Now slide all words from sp up to the next frame */
2780
2781     if (displacement > 0) {
2782       P_ next_frame_bottom;
2783
2784       if (next_frame != NULL)
2785         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2786       else
2787         next_frame_bottom = tso->sp - 1;
2788
2789 #if 0 /* DEBUG */
2790       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2791               displacement);
2792 #endif
2793
2794       while (sp >= next_frame_bottom) {
2795         sp[displacement] = *sp;
2796         sp -= 1;
2797       }
2798     }
2799     (P_)prev_frame = (P_)frame + displacement;
2800     frame = next_frame;
2801   }
2802
2803   tso->sp += displacement;
2804   tso->su = prev_frame;
2805 }
2806
2807 /* -----------------------------------------------------------------------------
2808  * Pausing a thread
2809  *
2810  * We have to prepare for GC - this means doing lazy black holing
2811  * here.  We also take the opportunity to do stack squeezing if it's
2812  * turned on.
2813  * -------------------------------------------------------------------------- */
2814
2815 void
2816 threadPaused(StgTSO *tso)
2817 {
2818   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2819     threadSqueezeStack(tso);    /* does black holing too */
2820   else
2821     threadLazyBlackHole(tso);
2822 }