ghc/rts/GC.c

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