ghc/rts/GC.c

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