ghc/rts/GC.c

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