ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.41 1999/02/24 17:24:07 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__ StgClosure *
 860 copy(StgClosure *src, nat size, step *step)
 861 {
 862   P_ to, from, dest;
 863
 864   TICK_GC_WORDS_COPIED(size);
 865   /* Find out where we're going, using the handy "to" pointer in
 866    * the step of the source object.  If it turns out we need to
 867    * evacuate to an older generation, adjust it here (see comment
 868    * by evacuate()).
 869    */
 870   if (step->gen->no < evac_gen) {
 871 #ifdef NO_EAGER_PROMOTION
 872     failed_to_evac = rtsTrue;
 873 #else
 874     step = &generations[evac_gen].steps[0];
 875 #endif
 876   }
 877
 878   /* chain a new block onto the to-space for the destination step if
 879    * necessary.
 880    */
 881   if (step->hp + size >= step->hpLim) {
 882     addBlock(step);
 883   }
 884
 885   for(to = step->hp, from = (P_)src; size>0; --size) {
 886     *to++ = *from++;
 887   }
 888
 889   dest = step->hp;
 890   step->hp = to;
 891   return (StgClosure *)dest;
 892 }
 893
 894 /* Special version of copy() for when we only want to copy the info
 895  * pointer of an object, but reserve some padding after it.  This is
 896  * used to optimise evacuation of BLACKHOLEs.
 897  */
 898
 899 static __inline__ StgClosure *
 900 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
 901 {
 902   P_ dest, to, from;
 903
 904   TICK_GC_WORDS_COPIED(size_to_copy);
 905   if (step->gen->no < evac_gen) {
 906 #ifdef NO_EAGER_PROMOTION
 907     failed_to_evac = rtsTrue;
 908 #else
 909     step = &generations[evac_gen].steps[0];
 910 #endif
 911   }
 912
 913   if (step->hp + size_to_reserve >= step->hpLim) {
 914     addBlock(step);
 915   }
 916
 917   for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
 918     *to++ = *from++;
 919   }
 920
 921   dest = step->hp;
 922   step->hp += size_to_reserve;
 923   return (StgClosure *)dest;
 924 }
 925
 926 static __inline__ void
 927 upd_evacuee(StgClosure *p, StgClosure *dest)
 928 {
 929   StgEvacuated *q = (StgEvacuated *)p;
 930
 931   SET_INFO(q,&EVACUATED_info);
 932   q->evacuee = 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     to = copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
1094     upd_evacuee(q,to);
1095     return to;
1096
1097   case MUT_VAR:
1098     ASSERT(q->header.info != &MUT_CONS_info);
1099   case MVAR:
1100     to = copy(q,sizeW_fromITBL(info),step);
1101     upd_evacuee(q,to);
1102     recordMutable((StgMutClosure *)to);
1103     return to;
1104
1105   case STABLE_NAME:
1106     stable_ptr_table[((StgStableName *)q)->sn].keep = rtsTrue;
1107     to = copy(q,sizeofW(StgStableName),step);
1108     upd_evacuee(q,to);
1109     return to;
1110
1111   case FUN_1_0:
1112   case FUN_0_1:
1113   case CONSTR_1_0:
1114   case CONSTR_0_1:
1115     to = copy(q,sizeofW(StgHeader)+1,step);
1116     upd_evacuee(q,to);
1117     return to;
1118
1119   case THUNK_1_0:               /* here because of MIN_UPD_SIZE */
1120   case THUNK_0_1:
1121   case FUN_1_1:
1122   case FUN_0_2:
1123   case FUN_2_0:
1124   case THUNK_1_1:
1125   case THUNK_0_2:
1126   case THUNK_2_0:
1127   case CONSTR_1_1:
1128   case CONSTR_0_2:
1129   case CONSTR_2_0:
1130     to = copy(q,sizeofW(StgHeader)+2,step);
1131     upd_evacuee(q,to);
1132     return to;
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     to = copy(q,sizeW_fromITBL(info),step);
1144     upd_evacuee(q,to);
1145     return to;
1146
1147   case CAF_BLACKHOLE:
1148   case BLACKHOLE:
1149     to = copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1150     upd_evacuee(q,to);
1151     return to;
1152
1153   case BLACKHOLE_BQ:
1154     to = copy(q,BLACKHOLE_sizeW(),step);
1155     upd_evacuee(q,to);
1156     recordMutable((StgMutClosure *)to);
1157     return to;
1158
1159   case THUNK_SELECTOR:
1160     {
1161       const StgInfoTable* selectee_info;
1162       StgClosure* selectee = ((StgSelector*)q)->selectee;
1163
1164     selector_loop:
1165       selectee_info = get_itbl(selectee);
1166       switch (selectee_info->type) {
1167       case CONSTR:
1168       case CONSTR_1_0:
1169       case CONSTR_0_1:
1170       case CONSTR_2_0:
1171       case CONSTR_1_1:
1172       case CONSTR_0_2:
1173       case CONSTR_STATIC:
1174         {
1175           StgNat32 offset = info->layout.selector_offset;
1176
1177           /* check that the size is in range */
1178           ASSERT(offset <
1179                  (StgNat32)(selectee_info->layout.payload.ptrs +
1180                             selectee_info->layout.payload.nptrs));
1181
1182           /* perform the selection! */
1183           q = selectee->payload[offset];
1184
1185           /* if we're already in to-space, there's no need to continue
1186            * with the evacuation, just update the source address with
1187            * a pointer to the (evacuated) constructor field.
1188            */
1189           if (IS_USER_PTR(q)) {
1190             bdescr *bd = Bdescr((P_)q);
1191             if (bd->evacuated) {
1192               if (bd->gen->no < evac_gen) {
1193                 failed_to_evac = rtsTrue;
1194                 TICK_GC_FAILED_PROMOTION();
1195               }
1196               return q;
1197             }
1198           }
1199
1200           /* otherwise, carry on and evacuate this constructor field,
1201            * (but not the constructor itself)
1202            */
1203           goto loop;
1204         }
1205
1206       case IND:
1207       case IND_STATIC:
1208       case IND_PERM:
1209       case IND_OLDGEN:
1210       case IND_OLDGEN_PERM:
1211         selectee = stgCast(StgInd *,selectee)->indirectee;
1212         goto selector_loop;
1213
1214       case CAF_ENTERED:
1215         selectee = stgCast(StgCAF *,selectee)->value;
1216         goto selector_loop;
1217
1218       case EVACUATED:
1219         selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1220         goto selector_loop;
1221
1222       case THUNK:
1223       case THUNK_1_0:
1224       case THUNK_0_1:
1225       case THUNK_2_0:
1226       case THUNK_1_1:
1227       case THUNK_0_2:
1228       case THUNK_STATIC:
1229       case THUNK_SELECTOR:
1230         /* aargh - do recursively???? */
1231       case CAF_UNENTERED:
1232       case CAF_BLACKHOLE:
1233       case BLACKHOLE:
1234       case BLACKHOLE_BQ:
1235         /* not evaluated yet */
1236         break;
1237
1238       default:
1239         barf("evacuate: THUNK_SELECTOR: strange selectee");
1240       }
1241     }
1242     to = copy(q,THUNK_SELECTOR_sizeW(),step);
1243     upd_evacuee(q,to);
1244     return to;
1245
1246   case IND:
1247   case IND_OLDGEN:
1248     /* follow chains of indirections, don't evacuate them */
1249     q = ((StgInd*)q)->indirectee;
1250     goto loop;
1251
1252     /* ToDo: optimise STATIC_LINK for known cases.
1253        - FUN_STATIC       : payload[0]
1254        - THUNK_STATIC     : payload[1]
1255        - IND_STATIC       : payload[1]
1256     */
1257   case THUNK_STATIC:
1258   case FUN_STATIC:
1259     if (info->srt_len == 0) {   /* small optimisation */
1260       return q;
1261     }
1262     /* fall through */
1263   case CONSTR_STATIC:
1264   case IND_STATIC:
1265     /* don't want to evacuate these, but we do want to follow pointers
1266      * from SRTs  - see scavenge_static.
1267      */
1268
1269     /* put the object on the static list, if necessary.
1270      */
1271     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1272       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1273       static_objects = (StgClosure *)q;
1274     }
1275     /* fall through */
1276
1277   case CONSTR_INTLIKE:
1278   case CONSTR_CHARLIKE:
1279   case CONSTR_NOCAF_STATIC:
1280     /* no need to put these on the static linked list, they don't need
1281      * to be scavenged.
1282      */
1283     return q;
1284
1285   case RET_BCO:
1286   case RET_SMALL:
1287   case RET_VEC_SMALL:
1288   case RET_BIG:
1289   case RET_VEC_BIG:
1290   case RET_DYN:
1291   case UPDATE_FRAME:
1292   case STOP_FRAME:
1293   case CATCH_FRAME:
1294   case SEQ_FRAME:
1295     /* shouldn't see these */
1296     barf("evacuate: stack frame\n");
1297
1298   case AP_UPD:
1299   case PAP:
1300     /* these are special - the payload is a copy of a chunk of stack,
1301        tagging and all. */
1302     to = copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1303     upd_evacuee(q,to);
1304     return to;
1305
1306   case EVACUATED:
1307     /* Already evacuated, just return the forwarding address.
1308      * HOWEVER: if the requested destination generation (evac_gen) is
1309      * older than the actual generation (because the object was
1310      * already evacuated to a younger generation) then we have to
1311      * set the failed_to_evac flag to indicate that we couldn't
1312      * manage to promote the object to the desired generation.
1313      */
1314     if (evac_gen > 0) {         /* optimisation */
1315       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1316       if (Bdescr((P_)p)->gen->no < evac_gen) {
1317         /*      fprintf(stderr,"evac failed!\n");*/
1318         failed_to_evac = rtsTrue;
1319         TICK_GC_FAILED_PROMOTION();
1320       }
1321     }
1322     return ((StgEvacuated*)q)->evacuee;
1323
1324   case ARR_WORDS:
1325     {
1326       nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1327
1328       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1329         evacuate_large((P_)q, rtsFalse);
1330         return q;
1331       } else {
1332         /* just copy the block */
1333         to = copy(q,size,step);
1334         upd_evacuee(q,to);
1335         return to;
1336       }
1337     }
1338
1339   case MUT_ARR_PTRS:
1340   case MUT_ARR_PTRS_FROZEN:
1341     {
1342       nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1343
1344       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1345         evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1346         to = q;
1347       } else {
1348         /* just copy the block */
1349         to = copy(q,size,step);
1350         upd_evacuee(q,to);
1351         if (info->type == MUT_ARR_PTRS) {
1352           recordMutable((StgMutClosure *)to);
1353         }
1354       }
1355       return to;
1356     }
1357
1358   case TSO:
1359     {
1360       StgTSO *tso = stgCast(StgTSO *,q);
1361       nat size = tso_sizeW(tso);
1362       int diff;
1363
1364       /* Large TSOs don't get moved, so no relocation is required.
1365        */
1366       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1367         evacuate_large((P_)q, rtsTrue);
1368         return q;
1369
1370       /* To evacuate a small TSO, we need to relocate the update frame
1371        * list it contains.
1372        */
1373       } else {
1374         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1375
1376         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1377
1378         /* relocate the stack pointers... */
1379         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1380         new_tso->sp = (StgPtr)new_tso->sp + diff;
1381         new_tso->splim = (StgPtr)new_tso->splim + diff;
1382
1383         relocate_TSO(tso, new_tso);
1384         upd_evacuee(q,(StgClosure *)new_tso);
1385
1386         recordMutable((StgMutClosure *)new_tso);
1387         return (StgClosure *)new_tso;
1388       }
1389     }
1390
1391   case BLOCKED_FETCH:
1392   case FETCH_ME:
1393     fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1394     return q;
1395
1396   default:
1397     barf("evacuate: strange closure type");
1398   }
1399
1400   barf("evacuate");
1401 }
1402
1403 /* -----------------------------------------------------------------------------
1404    relocate_TSO is called just after a TSO has been copied from src to
1405    dest.  It adjusts the update frame list for the new location.
1406    -------------------------------------------------------------------------- */
1407
1408 StgTSO *
1409 relocate_TSO(StgTSO *src, StgTSO *dest)
1410 {
1411   StgUpdateFrame *su;
1412   StgCatchFrame  *cf;
1413   StgSeqFrame    *sf;
1414   int diff;
1415
1416   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1417
1418   su = dest->su;
1419
1420   while ((P_)su < dest->stack + dest->stack_size) {
1421     switch (get_itbl(su)->type) {
1422
1423       /* GCC actually manages to common up these three cases! */
1424
1425     case UPDATE_FRAME:
1426       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1427       su = su->link;
1428       continue;
1429
1430     case CATCH_FRAME:
1431       cf = (StgCatchFrame *)su;
1432       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1433       su = cf->link;
1434       continue;
1435
1436     case SEQ_FRAME:
1437       sf = (StgSeqFrame *)su;
1438       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1439       su = sf->link;
1440       continue;
1441
1442     case STOP_FRAME:
1443       /* all done! */
1444       break;
1445
1446     default:
1447       barf("relocate_TSO");
1448     }
1449     break;
1450   }
1451
1452   return dest;
1453 }
1454
1455 static inline void
1456 scavenge_srt(const StgInfoTable *info)
1457 {
1458   StgClosure **srt, **srt_end;
1459
1460   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1461    * srt field in the info table.  That's ok, because we'll
1462    * never dereference it.
1463    */
1464   srt = stgCast(StgClosure **,info->srt);
1465   srt_end = srt + info->srt_len;
1466   for (; srt < srt_end; srt++) {
1467     evacuate(*srt);
1468   }
1469 }
1470
1471 /* -----------------------------------------------------------------------------
1472    Scavenge a given step until there are no more objects in this step
1473    to scavenge.
1474
1475    evac_gen is set by the caller to be either zero (for a step in a
1476    generation < N) or G where G is the generation of the step being
1477    scavenged.
1478
1479    We sometimes temporarily change evac_gen back to zero if we're
1480    scavenging a mutable object where early promotion isn't such a good
1481    idea.
1482    -------------------------------------------------------------------------- */
1483
1484
1485 static void
1486 scavenge(step *step)
1487 {
1488   StgPtr p, q;
1489   const StgInfoTable *info;
1490   bdescr *bd;
1491   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1492
1493   p = step->scan;
1494   bd = step->scan_bd;
1495
1496   failed_to_evac = rtsFalse;
1497
1498   /* scavenge phase - standard breadth-first scavenging of the
1499    * evacuated objects
1500    */
1501
1502   while (bd != step->hp_bd || p < step->hp) {
1503
1504     /* If we're at the end of this block, move on to the next block */
1505     if (bd != step->hp_bd && p == bd->free) {
1506       bd = bd->link;
1507       p = bd->start;
1508       continue;
1509     }
1510
1511     q = p;                      /* save ptr to object */
1512
1513     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1514                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1515
1516     info = get_itbl((StgClosure *)p);
1517     switch (info -> type) {
1518
1519     case BCO:
1520       {
1521         StgBCO* bco = stgCast(StgBCO*,p);
1522         nat i;
1523         for (i = 0; i < bco->n_ptrs; i++) {
1524           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1525         }
1526         p += bco_sizeW(bco);
1527         break;
1528       }
1529
1530     case MVAR:
1531       /* treat MVars specially, because we don't want to evacuate the
1532        * mut_link field in the middle of the closure.
1533        */
1534       {
1535         StgMVar *mvar = ((StgMVar *)p);
1536         evac_gen = 0;
1537         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1538         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1539         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1540         p += sizeofW(StgMVar);
1541         evac_gen = saved_evac_gen;
1542         break;
1543       }
1544
1545     case THUNK_2_0:
1546     case FUN_2_0:
1547       scavenge_srt(info);
1548     case CONSTR_2_0:
1549       ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1550       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1551       p += sizeofW(StgHeader) + 2;
1552       break;
1553
1554     case THUNK_1_0:
1555       scavenge_srt(info);
1556       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1557       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1558       break;
1559
1560     case FUN_1_0:
1561       scavenge_srt(info);
1562     case CONSTR_1_0:
1563       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1564       p += sizeofW(StgHeader) + 1;
1565       break;
1566
1567     case THUNK_0_1:
1568       scavenge_srt(info);
1569       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1570       break;
1571
1572     case FUN_0_1:
1573       scavenge_srt(info);
1574     case CONSTR_0_1:
1575       p += sizeofW(StgHeader) + 1;
1576       break;
1577
1578     case THUNK_0_2:
1579     case FUN_0_2:
1580       scavenge_srt(info);
1581     case CONSTR_0_2:
1582       p += sizeofW(StgHeader) + 2;
1583       break;
1584
1585     case THUNK_1_1:
1586     case FUN_1_1:
1587       scavenge_srt(info);
1588     case CONSTR_1_1:
1589       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1590       p += sizeofW(StgHeader) + 2;
1591       break;
1592
1593     case FUN:
1594     case THUNK:
1595       scavenge_srt(info);
1596       /* fall through */
1597
1598     case CONSTR:
1599     case WEAK:
1600     case FOREIGN:
1601     case STABLE_NAME:
1602     case IND_PERM:
1603     case IND_OLDGEN_PERM:
1604     case CAF_UNENTERED:
1605     case CAF_ENTERED:
1606       {
1607         StgPtr end;
1608
1609         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1610         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1611           (StgClosure *)*p = evacuate((StgClosure *)*p);
1612         }
1613         p += info->layout.payload.nptrs;
1614         break;
1615       }
1616
1617     case MUT_VAR:
1618       /* ignore MUT_CONSs */
1619       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1620         evac_gen = 0;
1621         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1622         evac_gen = saved_evac_gen;
1623       }
1624       p += sizeofW(StgMutVar);
1625       break;
1626
1627     case CAF_BLACKHOLE:
1628     case BLACKHOLE:
1629         p += BLACKHOLE_sizeW();
1630         break;
1631
1632     case BLACKHOLE_BQ:
1633       {
1634         StgBlockingQueue *bh = (StgBlockingQueue *)p;
1635         (StgClosure *)bh->blocking_queue =
1636           evacuate((StgClosure *)bh->blocking_queue);
1637         if (failed_to_evac) {
1638           failed_to_evac = rtsFalse;
1639           recordMutable((StgMutClosure *)bh);
1640         }
1641         p += BLACKHOLE_sizeW();
1642         break;
1643       }
1644
1645     case THUNK_SELECTOR:
1646       {
1647         StgSelector *s = (StgSelector *)p;
1648         s->selectee = evacuate(s->selectee);
1649         p += THUNK_SELECTOR_sizeW();
1650         break;
1651       }
1652
1653     case IND:
1654     case IND_OLDGEN:
1655       barf("scavenge:IND???\n");
1656
1657     case CONSTR_INTLIKE:
1658     case CONSTR_CHARLIKE:
1659     case CONSTR_STATIC:
1660     case CONSTR_NOCAF_STATIC:
1661     case THUNK_STATIC:
1662     case FUN_STATIC:
1663     case IND_STATIC:
1664       /* Shouldn't see a static object here. */
1665       barf("scavenge: STATIC object\n");
1666
1667     case RET_BCO:
1668     case RET_SMALL:
1669     case RET_VEC_SMALL:
1670     case RET_BIG:
1671     case RET_VEC_BIG:
1672     case RET_DYN:
1673     case UPDATE_FRAME:
1674     case STOP_FRAME:
1675     case CATCH_FRAME:
1676     case SEQ_FRAME:
1677       /* Shouldn't see stack frames here. */
1678       barf("scavenge: stack frame\n");
1679
1680     case AP_UPD: /* same as PAPs */
1681     case PAP:
1682       /* Treat a PAP just like a section of stack, not forgetting to
1683        * evacuate the function pointer too...
1684        */
1685       {
1686         StgPAP* pap = stgCast(StgPAP*,p);
1687
1688         pap->fun = evacuate(pap->fun);
1689         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1690         p += pap_sizeW(pap);
1691         break;
1692       }
1693
1694     case ARR_WORDS:
1695       /* nothing to follow */
1696       p += arr_words_sizeW(stgCast(StgArrWords*,p));
1697       break;
1698
1699     case MUT_ARR_PTRS:
1700       /* follow everything */
1701       {
1702         StgPtr next;
1703
1704         evac_gen = 0;           /* repeatedly mutable */
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         evac_gen = saved_evac_gen;
1710         break;
1711       }
1712
1713     case MUT_ARR_PTRS_FROZEN:
1714       /* follow everything */
1715       {
1716         StgPtr start = p, next;
1717
1718         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1719         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1720           (StgClosure *)*p = evacuate((StgClosure *)*p);
1721         }
1722         if (failed_to_evac) {
1723           /* we can do this easier... */
1724           recordMutable((StgMutClosure *)start);
1725           failed_to_evac = rtsFalse;
1726         }
1727         break;
1728       }
1729
1730     case TSO:
1731       {
1732         StgTSO *tso;
1733
1734         tso = (StgTSO *)p;
1735         evac_gen = 0;
1736         /* chase the link field for any TSOs on the same queue */
1737         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1738         /* scavenge this thread's stack */
1739         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1740         evac_gen = saved_evac_gen;
1741         p += tso_sizeW(tso);
1742         break;
1743       }
1744
1745     case BLOCKED_FETCH:
1746     case FETCH_ME:
1747     case EVACUATED:
1748       barf("scavenge: unimplemented/strange closure type\n");
1749
1750     default:
1751       barf("scavenge");
1752     }
1753
1754     /* If we didn't manage to promote all the objects pointed to by
1755      * the current object, then we have to designate this object as
1756      * mutable (because it contains old-to-new generation pointers).
1757      */
1758     if (failed_to_evac) {
1759       mkMutCons((StgClosure *)q, &generations[evac_gen]);
1760       failed_to_evac = rtsFalse;
1761     }
1762   }
1763
1764   step->scan_bd = bd;
1765   step->scan = p;
1766 }
1767
1768 /* -----------------------------------------------------------------------------
1769    Scavenge one object.
1770
1771    This is used for objects that are temporarily marked as mutable
1772    because they contain old-to-new generation pointers.  Only certain
1773    objects can have this property.
1774    -------------------------------------------------------------------------- */
1775 static rtsBool
1776 scavenge_one(StgClosure *p)
1777 {
1778   StgInfoTable *info;
1779   rtsBool no_luck;
1780
1781   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1782                || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1783
1784   info = get_itbl(p);
1785
1786   switch (info -> type) {
1787
1788   case FUN:
1789   case FUN_1_0:                 /* hardly worth specialising these guys */
1790   case FUN_0_1:
1791   case FUN_1_1:
1792   case FUN_0_2:
1793   case FUN_2_0:
1794   case THUNK:
1795   case THUNK_1_0:
1796   case THUNK_0_1:
1797   case THUNK_1_1:
1798   case THUNK_0_2:
1799   case THUNK_2_0:
1800   case CONSTR:
1801   case CONSTR_1_0:
1802   case CONSTR_0_1:
1803   case CONSTR_1_1:
1804   case CONSTR_0_2:
1805   case CONSTR_2_0:
1806   case WEAK:
1807   case FOREIGN:
1808   case IND_PERM:
1809   case IND_OLDGEN_PERM:
1810   case CAF_UNENTERED:
1811   case CAF_ENTERED:
1812     {
1813       StgPtr q, end;
1814
1815       end = (P_)p->payload + info->layout.payload.ptrs;
1816       for (q = (P_)p->payload; q < end; q++) {
1817         (StgClosure *)*q = evacuate((StgClosure *)*q);
1818       }
1819       break;
1820     }
1821
1822   case CAF_BLACKHOLE:
1823   case BLACKHOLE:
1824       break;
1825
1826   case THUNK_SELECTOR:
1827     {
1828       StgSelector *s = (StgSelector *)p;
1829       s->selectee = evacuate(s->selectee);
1830       break;
1831     }
1832
1833   case AP_UPD: /* same as PAPs */
1834   case PAP:
1835     /* Treat a PAP just like a section of stack, not forgetting to
1836      * evacuate the function pointer too...
1837      */
1838     {
1839       StgPAP* pap = (StgPAP *)p;
1840
1841       pap->fun = evacuate(pap->fun);
1842       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1843       break;
1844     }
1845
1846   case IND_OLDGEN:
1847     /* This might happen if for instance a MUT_CONS was pointing to a
1848      * THUNK which has since been updated.  The IND_OLDGEN will
1849      * be on the mutable list anyway, so we don't need to do anything
1850      * here.
1851      */
1852     break;
1853
1854   default:
1855     barf("scavenge_one: strange object");
1856   }
1857
1858   no_luck = failed_to_evac;
1859   failed_to_evac = rtsFalse;
1860   return (no_luck);
1861 }
1862
1863
1864 /* -----------------------------------------------------------------------------
1865    Scavenging mutable lists.
1866
1867    We treat the mutable list of each generation > N (i.e. all the
1868    generations older than the one being collected) as roots.  We also
1869    remove non-mutable objects from the mutable list at this point.
1870    -------------------------------------------------------------------------- */
1871
1872 static void
1873 scavenge_mut_once_list(generation *gen)
1874 {
1875   StgInfoTable *info;
1876   StgMutClosure *p, *next, *new_list;
1877
1878   p = gen->mut_once_list;
1879   new_list = END_MUT_LIST;
1880   next = p->mut_link;
1881
1882   evac_gen = gen->no;
1883   failed_to_evac = rtsFalse;
1884
1885   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1886
1887     /* make sure the info pointer is into text space */
1888     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1889                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1890
1891     info = get_itbl(p);
1892     switch(info->type) {
1893
1894     case IND_OLDGEN:
1895     case IND_OLDGEN_PERM:
1896     case IND_STATIC:
1897       /* Try to pull the indirectee into this generation, so we can
1898        * remove the indirection from the mutable list.
1899        */
1900       ((StgIndOldGen *)p)->indirectee =
1901         evacuate(((StgIndOldGen *)p)->indirectee);
1902
1903 #if 0
1904       /* Debugging code to print out the size of the thing we just
1905        * promoted
1906        */
1907       {
1908         StgPtr start = gen->steps[0].scan;
1909         bdescr *start_bd = gen->steps[0].scan_bd;
1910         nat size = 0;
1911         scavenge(&gen->steps[0]);
1912         if (start_bd != gen->steps[0].scan_bd) {
1913           size += (P_)BLOCK_ROUND_UP(start) - start;
1914           start_bd = start_bd->link;
1915           while (start_bd != gen->steps[0].scan_bd) {
1916             size += BLOCK_SIZE_W;
1917             start_bd = start_bd->link;
1918           }
1919           size += gen->steps[0].scan -
1920             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
1921         } else {
1922           size = gen->steps[0].scan - start;
1923         }
1924         fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
1925       }
1926 #endif
1927
1928       /* failed_to_evac might happen if we've got more than two
1929        * generations, we're collecting only generation 0, the
1930        * indirection resides in generation 2 and the indirectee is
1931        * in generation 1.
1932        */
1933       if (failed_to_evac) {
1934         failed_to_evac = rtsFalse;
1935         p->mut_link = new_list;
1936         new_list = p;
1937       } else {
1938         /* the mut_link field of an IND_STATIC is overloaded as the
1939          * static link field too (it just so happens that we don't need
1940          * both at the same time), so we need to NULL it out when
1941          * removing this object from the mutable list because the static
1942          * link fields are all assumed to be NULL before doing a major
1943          * collection.
1944          */
1945         p->mut_link = NULL;
1946       }
1947       continue;
1948
1949     case MUT_VAR:
1950       /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
1951        * it from the mutable list if possible by promoting whatever it
1952        * points to.
1953        */
1954       ASSERT(p->header.info == &MUT_CONS_info);
1955       if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
1956         /* didn't manage to promote everything, so put the
1957          * MUT_CONS back on the list.
1958          */
1959         p->mut_link = new_list;
1960         new_list = p;
1961       }
1962       continue;
1963
1964     default:
1965       /* shouldn't have anything else on the mutables list */
1966       barf("scavenge_mut_once_list: strange object?");
1967     }
1968   }
1969
1970   gen->mut_once_list = new_list;
1971 }
1972
1973
1974 static void
1975 scavenge_mutable_list(generation *gen)
1976 {
1977   StgInfoTable *info;
1978   StgMutClosure *p, *next;
1979
1980   p = gen->saved_mut_list;
1981   next = p->mut_link;
1982
1983   evac_gen = 0;
1984   failed_to_evac = rtsFalse;
1985
1986   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1987
1988     /* make sure the info pointer is into text space */
1989     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1990                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1991
1992     info = get_itbl(p);
1993     switch(info->type) {
1994
1995     case MUT_ARR_PTRS_FROZEN:
1996       /* remove this guy from the mutable list, but follow the ptrs
1997        * anyway (and make sure they get promoted to this gen).
1998        */
1999       {
2000         StgPtr end, q;
2001
2002         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2003         evac_gen = gen->no;
2004         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2005           (StgClosure *)*q = evacuate((StgClosure *)*q);
2006         }
2007         evac_gen = 0;
2008
2009         if (failed_to_evac) {
2010           failed_to_evac = rtsFalse;
2011           p->mut_link = gen->mut_list;
2012           gen->mut_list = p;
2013         }
2014         continue;
2015       }
2016
2017     case MUT_ARR_PTRS:
2018       /* follow everything */
2019       p->mut_link = gen->mut_list;
2020       gen->mut_list = p;
2021       {
2022         StgPtr end, q;
2023
2024         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2025         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2026           (StgClosure *)*q = evacuate((StgClosure *)*q);
2027         }
2028         continue;
2029       }
2030
2031     case MUT_VAR:
2032       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2033        * it from the mutable list if possible by promoting whatever it
2034        * points to.
2035        */
2036       ASSERT(p->header.info != &MUT_CONS_info);
2037       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2038       p->mut_link = gen->mut_list;
2039       gen->mut_list = p;
2040       continue;
2041
2042     case MVAR:
2043       {
2044         StgMVar *mvar = (StgMVar *)p;
2045         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2046         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2047         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2048         p->mut_link = gen->mut_list;
2049         gen->mut_list = p;
2050         continue;
2051       }
2052
2053     case TSO:
2054       /* follow ptrs and remove this from the mutable list */
2055       {
2056         StgTSO *tso = (StgTSO *)p;
2057
2058         /* Don't bother scavenging if this thread is dead
2059          */
2060         if (!(tso->whatNext == ThreadComplete ||
2061               tso->whatNext == ThreadKilled)) {
2062           /* Don't need to chase the link field for any TSOs on the
2063            * same queue. Just scavenge this thread's stack
2064            */
2065           scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2066         }
2067
2068         /* Don't take this TSO off the mutable list - it might still
2069          * point to some younger objects (because we set evac_gen to 0
2070          * above).
2071          */
2072         tso->mut_link = gen->mut_list;
2073         gen->mut_list = (StgMutClosure *)tso;
2074         continue;
2075       }
2076
2077     case BLACKHOLE_BQ:
2078       {
2079         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2080         (StgClosure *)bh->blocking_queue =
2081           evacuate((StgClosure *)bh->blocking_queue);
2082         p->mut_link = gen->mut_list;
2083         gen->mut_list = p;
2084         continue;
2085       }
2086
2087     default:
2088       /* shouldn't have anything else on the mutables list */
2089       barf("scavenge_mut_list: strange object?");
2090     }
2091   }
2092 }
2093
2094 static void
2095 scavenge_static(void)
2096 {
2097   StgClosure* p = static_objects;
2098   const StgInfoTable *info;
2099
2100   /* Always evacuate straight to the oldest generation for static
2101    * objects */
2102   evac_gen = oldest_gen->no;
2103
2104   /* keep going until we've scavenged all the objects on the linked
2105      list... */
2106   while (p != END_OF_STATIC_LIST) {
2107
2108     info = get_itbl(p);
2109
2110     /* make sure the info pointer is into text space */
2111     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2112                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2113
2114     /* Take this object *off* the static_objects list,
2115      * and put it on the scavenged_static_objects list.
2116      */
2117     static_objects = STATIC_LINK(info,p);
2118     STATIC_LINK(info,p) = scavenged_static_objects;
2119     scavenged_static_objects = p;
2120
2121     switch (info -> type) {
2122
2123     case IND_STATIC:
2124       {
2125         StgInd *ind = (StgInd *)p;
2126         ind->indirectee = evacuate(ind->indirectee);
2127
2128         /* might fail to evacuate it, in which case we have to pop it
2129          * back on the mutable list (and take it off the
2130          * scavenged_static list because the static link and mut link
2131          * pointers are one and the same).
2132          */
2133         if (failed_to_evac) {
2134           failed_to_evac = rtsFalse;
2135           scavenged_static_objects = STATIC_LINK(info,p);
2136           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2137           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2138         }
2139         break;
2140       }
2141
2142     case THUNK_STATIC:
2143     case FUN_STATIC:
2144       scavenge_srt(info);
2145       /* fall through */
2146
2147     case CONSTR_STATIC:
2148       {
2149         StgPtr q, next;
2150
2151         next = (P_)p->payload + info->layout.payload.ptrs;
2152         /* evacuate the pointers */
2153         for (q = (P_)p->payload; q < next; q++) {
2154           (StgClosure *)*q = evacuate((StgClosure *)*q);
2155         }
2156         break;
2157       }
2158
2159     default:
2160       barf("scavenge_static");
2161     }
2162
2163     ASSERT(failed_to_evac == rtsFalse);
2164
2165     /* get the next static object from the list.  Remeber, there might
2166      * be more stuff on this list now that we've done some evacuating!
2167      * (static_objects is a global)
2168      */
2169     p = static_objects;
2170   }
2171 }
2172
2173 /* -----------------------------------------------------------------------------
2174    scavenge_stack walks over a section of stack and evacuates all the
2175    objects pointed to by it.  We can use the same code for walking
2176    PAPs, since these are just sections of copied stack.
2177    -------------------------------------------------------------------------- */
2178
2179 static void
2180 scavenge_stack(StgPtr p, StgPtr stack_end)
2181 {
2182   StgPtr q;
2183   const StgInfoTable* info;
2184   StgNat32 bitmap;
2185
2186   /*
2187    * Each time around this loop, we are looking at a chunk of stack
2188    * that starts with either a pending argument section or an
2189    * activation record.
2190    */
2191
2192   while (p < stack_end) {
2193     q = *stgCast(StgPtr*,p);
2194
2195     /* If we've got a tag, skip over that many words on the stack */
2196     if (IS_ARG_TAG(stgCast(StgWord,q))) {
2197       p += ARG_SIZE(q);
2198       p++; continue;
2199     }
2200
2201     /* Is q a pointer to a closure?
2202      */
2203     if (! LOOKS_LIKE_GHC_INFO(q)) {
2204
2205 #ifdef DEBUG
2206       if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
2207         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2208       }
2209       /* otherwise, must be a pointer into the allocation space.
2210        */
2211 #endif
2212
2213       (StgClosure *)*p = evacuate((StgClosure *)q);
2214       p++;
2215       continue;
2216     }
2217
2218     /*
2219      * Otherwise, q must be the info pointer of an activation
2220      * record.  All activation records have 'bitmap' style layout
2221      * info.
2222      */
2223     info  = get_itbl(stgCast(StgClosure*,p));
2224
2225     switch (info->type) {
2226
2227       /* Dynamic bitmap: the mask is stored on the stack */
2228     case RET_DYN:
2229       bitmap = stgCast(StgRetDyn*,p)->liveness;
2230       p      = &payloadWord(stgCast(StgRetDyn*,p),0);
2231       goto small_bitmap;
2232
2233       /* probably a slow-entry point return address: */
2234     case FUN:
2235     case FUN_STATIC:
2236       p++;
2237       goto follow_srt;
2238
2239       /* Specialised code for update frames, since they're so common.
2240        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2241        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2242        */
2243     case UPDATE_FRAME:
2244       {
2245         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2246         StgClosure *to;
2247         StgClosureType type = get_itbl(frame->updatee)->type;
2248
2249         p += sizeofW(StgUpdateFrame);
2250         if (type == EVACUATED) {
2251           frame->updatee = evacuate(frame->updatee);
2252           continue;
2253         } else {
2254           bdescr *bd = Bdescr((P_)frame->updatee);
2255           step *step;
2256           if (bd->gen->no > N) {
2257             if (bd->gen->no < evac_gen) {
2258               failed_to_evac = rtsTrue;
2259             }
2260             continue;
2261           }
2262
2263           /* Don't promote blackholes */
2264           step = bd->step;
2265           if (!(step->gen->no == 0 &&
2266                 step->no != 0 &&
2267                 step->no == step->gen->n_steps-1)) {
2268             step = step->to;
2269           }
2270
2271           switch (type) {
2272           case BLACKHOLE:
2273           case CAF_BLACKHOLE:
2274             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2275                           sizeofW(StgHeader), step);
2276             upd_evacuee(frame->updatee,to);
2277             frame->updatee = to;
2278             continue;
2279           case BLACKHOLE_BQ:
2280             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2281             upd_evacuee(frame->updatee,to);
2282             frame->updatee = to;
2283             recordMutable((StgMutClosure *)to);
2284             continue;
2285           default:
2286             barf("scavenge_stack: UPDATE_FRAME updatee");
2287           }
2288         }
2289       }
2290
2291       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2292     case RET_BCO:
2293     case RET_SMALL:
2294     case RET_VEC_SMALL:
2295     case STOP_FRAME:
2296     case CATCH_FRAME:
2297     case SEQ_FRAME:
2298       bitmap = info->layout.bitmap;
2299       p++;
2300     small_bitmap:
2301       while (bitmap != 0) {
2302         if ((bitmap & 1) == 0) {
2303           (StgClosure *)*p = evacuate((StgClosure *)*p);
2304         }
2305         p++;
2306         bitmap = bitmap >> 1;
2307       }
2308
2309     follow_srt:
2310       scavenge_srt(info);
2311       continue;
2312
2313       /* large bitmap (> 32 entries) */
2314     case RET_BIG:
2315     case RET_VEC_BIG:
2316       {
2317         StgPtr q;
2318         StgLargeBitmap *large_bitmap;
2319         nat i;
2320
2321         large_bitmap = info->layout.large_bitmap;
2322         p++;
2323
2324         for (i=0; i<large_bitmap->size; i++) {
2325           bitmap = large_bitmap->bitmap[i];
2326           q = p + sizeof(W_) * 8;
2327           while (bitmap != 0) {
2328             if ((bitmap & 1) == 0) {
2329               (StgClosure *)*p = evacuate((StgClosure *)*p);
2330             }
2331             p++;
2332             bitmap = bitmap >> 1;
2333           }
2334           if (i+1 < large_bitmap->size) {
2335             while (p < q) {
2336               (StgClosure *)*p = evacuate((StgClosure *)*p);
2337               p++;
2338             }
2339           }
2340         }
2341
2342         /* and don't forget to follow the SRT */
2343         goto follow_srt;
2344       }
2345
2346     default:
2347       barf("scavenge_stack: weird activation record found on stack.\n");
2348     }
2349   }
2350 }
2351
2352 /*-----------------------------------------------------------------------------
2353   scavenge the large object list.
2354
2355   evac_gen set by caller; similar games played with evac_gen as with
2356   scavenge() - see comment at the top of scavenge().  Most large
2357   objects are (repeatedly) mutable, so most of the time evac_gen will
2358   be zero.
2359   --------------------------------------------------------------------------- */
2360
2361 static void
2362 scavenge_large(step *step)
2363 {
2364   bdescr *bd;
2365   StgPtr p;
2366   const StgInfoTable* info;
2367   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2368
2369   evac_gen = 0;                 /* most objects are mutable */
2370   bd = step->new_large_objects;
2371
2372   for (; bd != NULL; bd = step->new_large_objects) {
2373
2374     /* take this object *off* the large objects list and put it on
2375      * the scavenged large objects list.  This is so that we can
2376      * treat new_large_objects as a stack and push new objects on
2377      * the front when evacuating.
2378      */
2379     step->new_large_objects = bd->link;
2380     dbl_link_onto(bd, &step->scavenged_large_objects);
2381
2382     p = bd->start;
2383     info  = get_itbl(stgCast(StgClosure*,p));
2384
2385     switch (info->type) {
2386
2387     /* only certain objects can be "large"... */
2388
2389     case ARR_WORDS:
2390       /* nothing to follow */
2391       continue;
2392
2393     case MUT_ARR_PTRS:
2394       /* follow everything */
2395       {
2396         StgPtr next;
2397
2398         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2399         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2400           (StgClosure *)*p = evacuate((StgClosure *)*p);
2401         }
2402         continue;
2403       }
2404
2405     case MUT_ARR_PTRS_FROZEN:
2406       /* follow everything */
2407       {
2408         StgPtr start = p, next;
2409
2410         evac_gen = saved_evac_gen; /* not really mutable */
2411         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2412         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2413           (StgClosure *)*p = evacuate((StgClosure *)*p);
2414         }
2415         evac_gen = 0;
2416         if (failed_to_evac) {
2417           recordMutable((StgMutClosure *)start);
2418         }
2419         continue;
2420       }
2421
2422     case BCO:
2423       {
2424         StgBCO* bco = stgCast(StgBCO*,p);
2425         nat i;
2426         evac_gen = saved_evac_gen;
2427         for (i = 0; i < bco->n_ptrs; i++) {
2428           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2429         }
2430         evac_gen = 0;
2431         continue;
2432       }
2433
2434     case TSO:
2435       {
2436         StgTSO *tso;
2437
2438         tso = (StgTSO *)p;
2439         /* chase the link field for any TSOs on the same queue */
2440         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2441         /* scavenge this thread's stack */
2442         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2443         continue;
2444       }
2445
2446     default:
2447       barf("scavenge_large: unknown/strange object");
2448     }
2449   }
2450 }
2451
2452 static void
2453 zeroStaticObjectList(StgClosure* first_static)
2454 {
2455   StgClosure* p;
2456   StgClosure* link;
2457   const StgInfoTable *info;
2458
2459   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2460     info = get_itbl(p);
2461     link = STATIC_LINK(info, p);
2462     STATIC_LINK(info,p) = NULL;
2463   }
2464 }
2465
2466 /* This function is only needed because we share the mutable link
2467  * field with the static link field in an IND_STATIC, so we have to
2468  * zero the mut_link field before doing a major GC, which needs the
2469  * static link field.
2470  *
2471  * It doesn't do any harm to zero all the mutable link fields on the
2472  * mutable list.
2473  */
2474 static void
2475 zeroMutableList(StgMutClosure *first)
2476 {
2477   StgMutClosure *next, *c;
2478
2479   for (c = first; c != END_MUT_LIST; c = next) {
2480     next = c->mut_link;
2481     c->mut_link = NULL;
2482   }
2483 }
2484
2485 /* -----------------------------------------------------------------------------
2486    Reverting CAFs
2487    -------------------------------------------------------------------------- */
2488
2489 void RevertCAFs(void)
2490 {
2491   while (enteredCAFs != END_CAF_LIST) {
2492     StgCAF* caf = enteredCAFs;
2493
2494     enteredCAFs = caf->link;
2495     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2496     SET_INFO(caf,&CAF_UNENTERED_info);
2497     caf->value = stgCast(StgClosure*,0xdeadbeef);
2498     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2499   }
2500 }
2501
2502 void revertDeadCAFs(void)
2503 {
2504     StgCAF* caf = enteredCAFs;
2505     enteredCAFs = END_CAF_LIST;
2506     while (caf != END_CAF_LIST) {
2507         StgCAF* next = caf->link;
2508
2509         switch(GET_INFO(caf)->type) {
2510         case EVACUATED:
2511             {
2512                 /* This object has been evacuated, it must be live. */
2513                 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2514                 new->link = enteredCAFs;
2515                 enteredCAFs = new;
2516                 break;
2517             }
2518         case CAF_ENTERED:
2519             {
2520                 SET_INFO(caf,&CAF_UNENTERED_info);
2521                 caf->value = stgCast(StgClosure*,0xdeadbeef);
2522                 caf->link  = stgCast(StgCAF*,0xdeadbeef);
2523                 break;
2524             }
2525         default:
2526                 barf("revertDeadCAFs: enteredCAFs list corrupted");
2527         }
2528         caf = next;
2529     }
2530 }
2531
2532 /* -----------------------------------------------------------------------------
2533    Sanity code for CAF garbage collection.
2534
2535    With DEBUG turned on, we manage a CAF list in addition to the SRT
2536    mechanism.  After GC, we run down the CAF list and blackhole any
2537    CAFs which have been garbage collected.  This means we get an error
2538    whenever the program tries to enter a garbage collected CAF.
2539
2540    Any garbage collected CAFs are taken off the CAF list at the same
2541    time.
2542    -------------------------------------------------------------------------- */
2543
2544 #ifdef DEBUG
2545 static void
2546 gcCAFs(void)
2547 {
2548   StgClosure*  p;
2549   StgClosure** pp;
2550   const StgInfoTable *info;
2551   nat i;
2552
2553   i = 0;
2554   p = caf_list;
2555   pp = &caf_list;
2556
2557   while (p != NULL) {
2558
2559     info = get_itbl(p);
2560
2561     ASSERT(info->type == IND_STATIC);
2562
2563     if (STATIC_LINK(info,p) == NULL) {
2564       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2565       /* black hole it */
2566       SET_INFO(p,&BLACKHOLE_info);
2567       p = STATIC_LINK2(info,p);
2568       *pp = p;
2569     }
2570     else {
2571       pp = &STATIC_LINK2(info,p);
2572       p = *pp;
2573       i++;
2574     }
2575
2576   }
2577
2578   /*  fprintf(stderr, "%d CAFs live\n", i); */
2579 }
2580 #endif
2581
2582 /* -----------------------------------------------------------------------------
2583    Lazy black holing.
2584
2585    Whenever a thread returns to the scheduler after possibly doing
2586    some work, we have to run down the stack and black-hole all the
2587    closures referred to by update frames.
2588    -------------------------------------------------------------------------- */
2589
2590 static void
2591 threadLazyBlackHole(StgTSO *tso)
2592 {
2593   StgUpdateFrame *update_frame;
2594   StgBlockingQueue *bh;
2595   StgPtr stack_end;
2596
2597   stack_end = &tso->stack[tso->stack_size];
2598   update_frame = tso->su;
2599
2600   while (1) {
2601     switch (get_itbl(update_frame)->type) {
2602
2603     case CATCH_FRAME:
2604       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2605       break;
2606
2607     case UPDATE_FRAME:
2608       bh = (StgBlockingQueue *)update_frame->updatee;
2609
2610       /* if the thunk is already blackholed, it means we've also
2611        * already blackholed the rest of the thunks on this stack,
2612        * so we can stop early.
2613        *
2614        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2615        * don't interfere with this optimisation.
2616        */
2617       if (bh->header.info == &BLACKHOLE_info) {
2618         return;
2619       }
2620
2621       if (bh->header.info != &BLACKHOLE_BQ_info &&
2622           bh->header.info != &CAF_BLACKHOLE_info) {
2623         SET_INFO(bh,&BLACKHOLE_info);
2624       }
2625
2626       update_frame = update_frame->link;
2627       break;
2628
2629     case SEQ_FRAME:
2630       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2631       break;
2632
2633     case STOP_FRAME:
2634       return;
2635     default:
2636       barf("threadPaused");
2637     }
2638   }
2639 }
2640
2641 /* -----------------------------------------------------------------------------
2642  * Stack squeezing
2643  *
2644  * Code largely pinched from old RTS, then hacked to bits.  We also do
2645  * lazy black holing here.
2646  *
2647  * -------------------------------------------------------------------------- */
2648
2649 static void
2650 threadSqueezeStack(StgTSO *tso)
2651 {
2652   lnat displacement = 0;
2653   StgUpdateFrame *frame;
2654   StgUpdateFrame *next_frame;                   /* Temporally next */
2655   StgUpdateFrame *prev_frame;                   /* Temporally previous */
2656   StgPtr bottom;
2657   rtsBool prev_was_update_frame;
2658
2659   bottom = &(tso->stack[tso->stack_size]);
2660   frame  = tso->su;
2661
2662   /* There must be at least one frame, namely the STOP_FRAME.
2663    */
2664   ASSERT((P_)frame < bottom);
2665
2666   /* Walk down the stack, reversing the links between frames so that
2667    * we can walk back up as we squeeze from the bottom.  Note that
2668    * next_frame and prev_frame refer to next and previous as they were
2669    * added to the stack, rather than the way we see them in this
2670    * walk. (It makes the next loop less confusing.)
2671    *
2672    * Stop if we find an update frame pointing to a black hole
2673    * (see comment in threadLazyBlackHole()).
2674    */
2675
2676   next_frame = NULL;
2677   while ((P_)frame < bottom - 1) {  /* bottom - 1 is the STOP_FRAME */
2678     prev_frame = frame->link;
2679     frame->link = next_frame;
2680     next_frame = frame;
2681     frame = prev_frame;
2682     if (get_itbl(frame)->type == UPDATE_FRAME
2683         && frame->updatee->header.info == &BLACKHOLE_info) {
2684         break;
2685     }
2686   }
2687
2688   /* Now, we're at the bottom.  Frame points to the lowest update
2689    * frame on the stack, and its link actually points to the frame
2690    * above. We have to walk back up the stack, squeezing out empty
2691    * update frames and turning the pointers back around on the way
2692    * back up.
2693    *
2694    * The bottom-most frame (the STOP_FRAME) has not been altered, and
2695    * we never want to eliminate it anyway.  Just walk one step up
2696    * before starting to squeeze. When you get to the topmost frame,
2697    * remember that there are still some words above it that might have
2698    * to be moved.
2699    */
2700
2701   prev_frame = frame;
2702   frame = next_frame;
2703
2704   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2705
2706   /*
2707    * Loop through all of the frames (everything except the very
2708    * bottom).  Things are complicated by the fact that we have
2709    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2710    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2711    */
2712   while (frame != NULL) {
2713     StgPtr sp;
2714     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2715     rtsBool is_update_frame;
2716
2717     next_frame = frame->link;
2718     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2719
2720     /* Check to see if
2721      *   1. both the previous and current frame are update frames
2722      *   2. the current frame is empty
2723      */
2724     if (prev_was_update_frame && is_update_frame &&
2725         (P_)prev_frame == frame_bottom + displacement) {
2726
2727       /* Now squeeze out the current frame */
2728       StgClosure *updatee_keep   = prev_frame->updatee;
2729       StgClosure *updatee_bypass = frame->updatee;
2730
2731 #if 0 /* DEBUG */
2732       fprintf(stderr, "squeezing frame at %p\n", frame);
2733 #endif
2734
2735       /* Deal with blocking queues.  If both updatees have blocked
2736        * threads, then we should merge the queues into the update
2737        * frame that we're keeping.
2738        *
2739        * Alternatively, we could just wake them up: they'll just go
2740        * straight to sleep on the proper blackhole!  This is less code
2741        * and probably less bug prone, although it's probably much
2742        * slower --SDM
2743        */
2744 #if 0 /* do it properly... */
2745       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
2746         /* Sigh.  It has one.  Don't lose those threads! */
2747           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2748           /* Urgh.  Two queues.  Merge them. */
2749           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2750
2751           while (keep_tso->link != END_TSO_QUEUE) {
2752             keep_tso = keep_tso->link;
2753           }
2754           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2755
2756         } else {
2757           /* For simplicity, just swap the BQ for the BH */
2758           P_ temp = updatee_keep;
2759
2760           updatee_keep = updatee_bypass;
2761           updatee_bypass = temp;
2762
2763           /* Record the swap in the kept frame (below) */
2764           prev_frame->updatee = updatee_keep;
2765         }
2766       }
2767 #endif
2768
2769       TICK_UPD_SQUEEZED();
2770       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2771
2772       sp = (P_)frame - 1;       /* sp = stuff to slide */
2773       displacement += sizeofW(StgUpdateFrame);
2774
2775     } else {
2776       /* No squeeze for this frame */
2777       sp = frame_bottom - 1;    /* Keep the current frame */
2778
2779       /* Do lazy black-holing.
2780        */
2781       if (is_update_frame) {
2782         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2783         if (bh->header.info != &BLACKHOLE_BQ_info &&
2784             bh->header.info != &CAF_BLACKHOLE_info) {
2785           SET_INFO(bh,&BLACKHOLE_info);
2786         }
2787       }
2788
2789       /* Fix the link in the current frame (should point to the frame below) */
2790       frame->link = prev_frame;
2791       prev_was_update_frame = is_update_frame;
2792     }
2793
2794     /* Now slide all words from sp up to the next frame */
2795
2796     if (displacement > 0) {
2797       P_ next_frame_bottom;
2798
2799       if (next_frame != NULL)
2800         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2801       else
2802         next_frame_bottom = tso->sp - 1;
2803
2804 #if 0 /* DEBUG */
2805       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2806               displacement);
2807 #endif
2808
2809       while (sp >= next_frame_bottom) {
2810         sp[displacement] = *sp;
2811         sp -= 1;
2812       }
2813     }
2814     (P_)prev_frame = (P_)frame + displacement;
2815     frame = next_frame;
2816   }
2817
2818   tso->sp += displacement;
2819   tso->su = prev_frame;
2820 }
2821
2822 /* -----------------------------------------------------------------------------
2823  * Pausing a thread
2824  *
2825  * We have to prepare for GC - this means doing lazy black holing
2826  * here.  We also take the opportunity to do stack squeezing if it's
2827  * turned on.
2828  * -------------------------------------------------------------------------- */
2829
2830 void
2831 threadPaused(StgTSO *tso)
2832 {
2833   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2834     threadSqueezeStack(tso);    /* does black holing too */
2835   else
2836     threadLazyBlackHole(tso);
2837 }