ghc/rts/GC.c

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