ghc/rts/GC.c

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