ghc/rts/GC.c

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