ghc/rts/GC.c

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