ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.32 1999/02/15 14:28:19 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 finalizers */
 656   scheduleFinalizers(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 finalize 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/finalizers 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 finalizer */
 721       w->value = evacuate(w->value);
 722       w->finalizer = evacuate(w->finalizer);
 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 finalizers 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->finalizer = evacuate(w->finalizer);
 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;
1936
1937   p = gen->saved_mut_list;
1938   next = p->mut_link;
1939
1940   evac_gen = 0;
1941   failed_to_evac = rtsFalse;
1942
1943   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1944
1945     /* make sure the info pointer is into text space */
1946     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1947                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1948
1949     info = get_itbl(p);
1950     switch(info->type) {
1951
1952     case MUT_ARR_PTRS_FROZEN:
1953       /* remove this guy from the mutable list, but follow the ptrs
1954        * anyway (and make sure they get promoted to this gen).
1955        */
1956       {
1957         StgPtr end, q;
1958
1959         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1960         evac_gen = gen->no;
1961         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1962           (StgClosure *)*q = evacuate((StgClosure *)*q);
1963         }
1964         evac_gen = 0;
1965
1966         if (failed_to_evac) {
1967           failed_to_evac = rtsFalse;
1968           p->mut_link = gen->mut_list;
1969           gen->mut_list = p;
1970         }
1971         continue;
1972       }
1973
1974     case MUT_ARR_PTRS:
1975       /* follow everything */
1976       p->mut_link = gen->mut_list;
1977       gen->mut_list = p;
1978       {
1979         StgPtr end, q;
1980
1981         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1982         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1983           (StgClosure *)*q = evacuate((StgClosure *)*q);
1984         }
1985         continue;
1986       }
1987
1988     case MUT_VAR:
1989       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
1990        * it from the mutable list if possible by promoting whatever it
1991        * points to.
1992        */
1993       ASSERT(p->header.info != &MUT_CONS_info);
1994       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1995       p->mut_link = gen->mut_list;
1996       gen->mut_list = p;
1997       continue;
1998
1999     case MVAR:
2000       {
2001         StgMVar *mvar = (StgMVar *)p;
2002         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2003         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2004         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2005         p->mut_link = gen->mut_list;
2006         gen->mut_list = p;
2007         continue;
2008       }
2009
2010     case TSO:
2011       /* follow ptrs and remove this from the mutable list */
2012       {
2013         StgTSO *tso = (StgTSO *)p;
2014
2015         /* Don't bother scavenging if this thread is dead
2016          */
2017         if (!(tso->whatNext == ThreadComplete ||
2018               tso->whatNext == ThreadKilled)) {
2019           /* Don't need to chase the link field for any TSOs on the
2020            * same queue. Just scavenge this thread's stack
2021            */
2022           scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2023         }
2024
2025         /* Don't take this TSO off the mutable list - it might still
2026          * point to some younger objects (because we set evac_gen to 0
2027          * above).
2028          */
2029         tso->mut_link = gen->mut_list;
2030         gen->mut_list = (StgMutClosure *)tso;
2031         continue;
2032       }
2033
2034     case BLACKHOLE_BQ:
2035       {
2036         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2037         (StgClosure *)bh->blocking_queue =
2038           evacuate((StgClosure *)bh->blocking_queue);
2039         p->mut_link = gen->mut_list;
2040         gen->mut_list = p;
2041         continue;
2042       }
2043
2044     default:
2045       /* shouldn't have anything else on the mutables list */
2046       barf("scavenge_mut_list: strange object?");
2047     }
2048   }
2049 }
2050
2051 static void
2052 scavenge_static(void)
2053 {
2054   StgClosure* p = static_objects;
2055   const StgInfoTable *info;
2056
2057   /* Always evacuate straight to the oldest generation for static
2058    * objects */
2059   evac_gen = oldest_gen->no;
2060
2061   /* keep going until we've scavenged all the objects on the linked
2062      list... */
2063   while (p != END_OF_STATIC_LIST) {
2064
2065     info = get_itbl(p);
2066
2067     /* make sure the info pointer is into text space */
2068     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2069                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2070
2071     /* Take this object *off* the static_objects list,
2072      * and put it on the scavenged_static_objects list.
2073      */
2074     static_objects = STATIC_LINK(info,p);
2075     STATIC_LINK(info,p) = scavenged_static_objects;
2076     scavenged_static_objects = p;
2077
2078     switch (info -> type) {
2079
2080     case IND_STATIC:
2081       {
2082         StgInd *ind = (StgInd *)p;
2083         ind->indirectee = evacuate(ind->indirectee);
2084
2085         /* might fail to evacuate it, in which case we have to pop it
2086          * back on the mutable list (and take it off the
2087          * scavenged_static list because the static link and mut link
2088          * pointers are one and the same).
2089          */
2090         if (failed_to_evac) {
2091           failed_to_evac = rtsFalse;
2092           scavenged_static_objects = STATIC_LINK(info,p);
2093           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2094           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2095         }
2096         break;
2097       }
2098
2099     case THUNK_STATIC:
2100     case FUN_STATIC:
2101       scavenge_srt(info);
2102       /* fall through */
2103
2104     case CONSTR_STATIC:
2105       {
2106         StgPtr q, next;
2107
2108         next = (P_)p->payload + info->layout.payload.ptrs;
2109         /* evacuate the pointers */
2110         for (q = (P_)p->payload; q < next; q++) {
2111           (StgClosure *)*q = evacuate((StgClosure *)*q);
2112         }
2113         break;
2114       }
2115
2116     default:
2117       barf("scavenge_static");
2118     }
2119
2120     ASSERT(failed_to_evac == rtsFalse);
2121
2122     /* get the next static object from the list.  Remeber, there might
2123      * be more stuff on this list now that we've done some evacuating!
2124      * (static_objects is a global)
2125      */
2126     p = static_objects;
2127   }
2128 }
2129
2130 /* -----------------------------------------------------------------------------
2131    scavenge_stack walks over a section of stack and evacuates all the
2132    objects pointed to by it.  We can use the same code for walking
2133    PAPs, since these are just sections of copied stack.
2134    -------------------------------------------------------------------------- */
2135
2136 static void
2137 scavenge_stack(StgPtr p, StgPtr stack_end)
2138 {
2139   StgPtr q;
2140   const StgInfoTable* info;
2141   StgNat32 bitmap;
2142
2143   /*
2144    * Each time around this loop, we are looking at a chunk of stack
2145    * that starts with either a pending argument section or an
2146    * activation record.
2147    */
2148
2149   while (p < stack_end) {
2150     q = *stgCast(StgPtr*,p);
2151
2152     /* If we've got a tag, skip over that many words on the stack */
2153     if (IS_ARG_TAG(stgCast(StgWord,q))) {
2154       p += ARG_SIZE(q);
2155       p++; continue;
2156     }
2157
2158     /* Is q a pointer to a closure?
2159      */
2160     if (! LOOKS_LIKE_GHC_INFO(q)) {
2161
2162 #ifdef DEBUG
2163       if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
2164         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2165       }
2166       /* otherwise, must be a pointer into the allocation space.
2167        */
2168 #endif
2169
2170       (StgClosure *)*p = evacuate((StgClosure *)q);
2171       p++;
2172       continue;
2173     }
2174
2175     /*
2176      * Otherwise, q must be the info pointer of an activation
2177      * record.  All activation records have 'bitmap' style layout
2178      * info.
2179      */
2180     info  = get_itbl(stgCast(StgClosure*,p));
2181
2182     switch (info->type) {
2183
2184       /* Dynamic bitmap: the mask is stored on the stack */
2185     case RET_DYN:
2186       bitmap = stgCast(StgRetDyn*,p)->liveness;
2187       p      = &payloadWord(stgCast(StgRetDyn*,p),0);
2188       goto small_bitmap;
2189
2190       /* probably a slow-entry point return address: */
2191     case FUN:
2192     case FUN_STATIC:
2193       p++;
2194       goto follow_srt;
2195
2196       /* Specialised code for update frames, since they're so common.
2197        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2198        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2199        */
2200     case UPDATE_FRAME:
2201       {
2202         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2203         StgClosure *to;
2204         StgClosureType type = get_itbl(frame->updatee)->type;
2205
2206         p += sizeofW(StgUpdateFrame);
2207         if (type == EVACUATED) {
2208           frame->updatee = evacuate(frame->updatee);
2209           continue;
2210         } else {
2211           bdescr *bd = Bdescr((P_)frame->updatee);
2212           step *step;
2213           if (bd->gen->no > N) {
2214             if (bd->gen->no < evac_gen) {
2215               failed_to_evac = rtsTrue;
2216             }
2217             continue;
2218           }
2219           step = bd->step->to;
2220           switch (type) {
2221           case BLACKHOLE:
2222           case CAF_BLACKHOLE:
2223             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2224                           sizeofW(StgHeader), step);
2225             upd_evacuee(frame->updatee,to);
2226             frame->updatee = to;
2227             continue;
2228           case BLACKHOLE_BQ:
2229             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2230             upd_evacuee(frame->updatee,to);
2231             frame->updatee = to;
2232             recordMutable((StgMutClosure *)to);
2233             continue;
2234           default:
2235             barf("scavenge_stack: UPDATE_FRAME updatee");
2236           }
2237         }
2238       }
2239
2240       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2241     case RET_BCO:
2242     case RET_SMALL:
2243     case RET_VEC_SMALL:
2244     case STOP_FRAME:
2245     case CATCH_FRAME:
2246     case SEQ_FRAME:
2247       bitmap = info->layout.bitmap;
2248       p++;
2249     small_bitmap:
2250       while (bitmap != 0) {
2251         if ((bitmap & 1) == 0) {
2252           (StgClosure *)*p = evacuate((StgClosure *)*p);
2253         }
2254         p++;
2255         bitmap = bitmap >> 1;
2256       }
2257
2258     follow_srt:
2259       scavenge_srt(info);
2260       continue;
2261
2262       /* large bitmap (> 32 entries) */
2263     case RET_BIG:
2264     case RET_VEC_BIG:
2265       {
2266         StgPtr q;
2267         StgLargeBitmap *large_bitmap;
2268         nat i;
2269
2270         large_bitmap = info->layout.large_bitmap;
2271         p++;
2272
2273         for (i=0; i<large_bitmap->size; i++) {
2274           bitmap = large_bitmap->bitmap[i];
2275           q = p + sizeof(W_) * 8;
2276           while (bitmap != 0) {
2277             if ((bitmap & 1) == 0) {
2278               (StgClosure *)*p = evacuate((StgClosure *)*p);
2279             }
2280             p++;
2281             bitmap = bitmap >> 1;
2282           }
2283           if (i+1 < large_bitmap->size) {
2284             while (p < q) {
2285               (StgClosure *)*p = evacuate((StgClosure *)*p);
2286               p++;
2287             }
2288           }
2289         }
2290
2291         /* and don't forget to follow the SRT */
2292         goto follow_srt;
2293       }
2294
2295     default:
2296       barf("scavenge_stack: weird activation record found on stack.\n");
2297     }
2298   }
2299 }
2300
2301 /*-----------------------------------------------------------------------------
2302   scavenge the large object list.
2303
2304   evac_gen set by caller; similar games played with evac_gen as with
2305   scavenge() - see comment at the top of scavenge().  Most large
2306   objects are (repeatedly) mutable, so most of the time evac_gen will
2307   be zero.
2308   --------------------------------------------------------------------------- */
2309
2310 static void
2311 scavenge_large(step *step)
2312 {
2313   bdescr *bd;
2314   StgPtr p;
2315   const StgInfoTable* info;
2316   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2317
2318   evac_gen = 0;                 /* most objects are mutable */
2319   bd = step->new_large_objects;
2320
2321   for (; bd != NULL; bd = step->new_large_objects) {
2322
2323     /* take this object *off* the large objects list and put it on
2324      * the scavenged large objects list.  This is so that we can
2325      * treat new_large_objects as a stack and push new objects on
2326      * the front when evacuating.
2327      */
2328     step->new_large_objects = bd->link;
2329     dbl_link_onto(bd, &step->scavenged_large_objects);
2330
2331     p = bd->start;
2332     info  = get_itbl(stgCast(StgClosure*,p));
2333
2334     switch (info->type) {
2335
2336     /* only certain objects can be "large"... */
2337
2338     case ARR_WORDS:
2339       /* nothing to follow */
2340       continue;
2341
2342     case MUT_ARR_PTRS:
2343       /* follow everything */
2344       {
2345         StgPtr next;
2346
2347         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2348         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2349           (StgClosure *)*p = evacuate((StgClosure *)*p);
2350         }
2351         continue;
2352       }
2353
2354     case MUT_ARR_PTRS_FROZEN:
2355       /* follow everything */
2356       {
2357         StgPtr start = p, next;
2358
2359         evac_gen = saved_evac_gen; /* not really mutable */
2360         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2361         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2362           (StgClosure *)*p = evacuate((StgClosure *)*p);
2363         }
2364         evac_gen = 0;
2365         if (failed_to_evac) {
2366           recordMutable((StgMutClosure *)start);
2367         }
2368         continue;
2369       }
2370
2371     case BCO:
2372       {
2373         StgBCO* bco = stgCast(StgBCO*,p);
2374         nat i;
2375         evac_gen = saved_evac_gen;
2376         for (i = 0; i < bco->n_ptrs; i++) {
2377           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2378         }
2379         evac_gen = 0;
2380         continue;
2381       }
2382
2383     case TSO:
2384       {
2385         StgTSO *tso;
2386
2387         tso = (StgTSO *)p;
2388         /* chase the link field for any TSOs on the same queue */
2389         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2390         /* scavenge this thread's stack */
2391         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2392         continue;
2393       }
2394
2395     default:
2396       barf("scavenge_large: unknown/strange object");
2397     }
2398   }
2399 }
2400
2401 static void
2402 zeroStaticObjectList(StgClosure* first_static)
2403 {
2404   StgClosure* p;
2405   StgClosure* link;
2406   const StgInfoTable *info;
2407
2408   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2409     info = get_itbl(p);
2410     link = STATIC_LINK(info, p);
2411     STATIC_LINK(info,p) = NULL;
2412   }
2413 }
2414
2415 /* This function is only needed because we share the mutable link
2416  * field with the static link field in an IND_STATIC, so we have to
2417  * zero the mut_link field before doing a major GC, which needs the
2418  * static link field.
2419  *
2420  * It doesn't do any harm to zero all the mutable link fields on the
2421  * mutable list.
2422  */
2423 static void
2424 zeroMutableList(StgMutClosure *first)
2425 {
2426   StgMutClosure *next, *c;
2427
2428   for (c = first; c != END_MUT_LIST; c = next) {
2429     next = c->mut_link;
2430     c->mut_link = NULL;
2431   }
2432 }
2433
2434 /* -----------------------------------------------------------------------------
2435    Reverting CAFs
2436    -------------------------------------------------------------------------- */
2437
2438 void RevertCAFs(void)
2439 {
2440   while (enteredCAFs != END_CAF_LIST) {
2441     StgCAF* caf = enteredCAFs;
2442
2443     enteredCAFs = caf->link;
2444     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2445     SET_INFO(caf,&CAF_UNENTERED_info);
2446     caf->value = stgCast(StgClosure*,0xdeadbeef);
2447     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2448   }
2449 }
2450
2451 void revertDeadCAFs(void)
2452 {
2453     StgCAF* caf = enteredCAFs;
2454     enteredCAFs = END_CAF_LIST;
2455     while (caf != END_CAF_LIST) {
2456         StgCAF* next = caf->link;
2457
2458         switch(GET_INFO(caf)->type) {
2459         case EVACUATED:
2460             {
2461                 /* This object has been evacuated, it must be live. */
2462                 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2463                 new->link = enteredCAFs;
2464                 enteredCAFs = new;
2465                 break;
2466             }
2467         case CAF_ENTERED:
2468             {
2469                 SET_INFO(caf,&CAF_UNENTERED_info);
2470                 caf->value = stgCast(StgClosure*,0xdeadbeef);
2471                 caf->link  = stgCast(StgCAF*,0xdeadbeef);
2472                 break;
2473             }
2474         default:
2475                 barf("revertDeadCAFs: enteredCAFs list corrupted");
2476         }
2477         caf = next;
2478     }
2479 }
2480
2481 /* -----------------------------------------------------------------------------
2482    Sanity code for CAF garbage collection.
2483
2484    With DEBUG turned on, we manage a CAF list in addition to the SRT
2485    mechanism.  After GC, we run down the CAF list and blackhole any
2486    CAFs which have been garbage collected.  This means we get an error
2487    whenever the program tries to enter a garbage collected CAF.
2488
2489    Any garbage collected CAFs are taken off the CAF list at the same
2490    time.
2491    -------------------------------------------------------------------------- */
2492
2493 #ifdef DEBUG
2494 static void
2495 gcCAFs(void)
2496 {
2497   StgClosure*  p;
2498   StgClosure** pp;
2499   const StgInfoTable *info;
2500   nat i;
2501
2502   i = 0;
2503   p = caf_list;
2504   pp = &caf_list;
2505
2506   while (p != NULL) {
2507
2508     info = get_itbl(p);
2509
2510     ASSERT(info->type == IND_STATIC);
2511
2512     if (STATIC_LINK(info,p) == NULL) {
2513       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2514       /* black hole it */
2515       SET_INFO(p,&BLACKHOLE_info);
2516       p = STATIC_LINK2(info,p);
2517       *pp = p;
2518     }
2519     else {
2520       pp = &STATIC_LINK2(info,p);
2521       p = *pp;
2522       i++;
2523     }
2524
2525   }
2526
2527   /*  fprintf(stderr, "%d CAFs live\n", i); */
2528 }
2529 #endif
2530
2531 /* -----------------------------------------------------------------------------
2532    Lazy black holing.
2533
2534    Whenever a thread returns to the scheduler after possibly doing
2535    some work, we have to run down the stack and black-hole all the
2536    closures referred to by update frames.
2537    -------------------------------------------------------------------------- */
2538
2539 static void
2540 threadLazyBlackHole(StgTSO *tso)
2541 {
2542   StgUpdateFrame *update_frame;
2543   StgBlockingQueue *bh;
2544   StgPtr stack_end;
2545
2546   stack_end = &tso->stack[tso->stack_size];
2547   update_frame = tso->su;
2548
2549   while (1) {
2550     switch (get_itbl(update_frame)->type) {
2551
2552     case CATCH_FRAME:
2553       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2554       break;
2555
2556     case UPDATE_FRAME:
2557       bh = (StgBlockingQueue *)update_frame->updatee;
2558
2559       /* if the thunk is already blackholed, it means we've also
2560        * already blackholed the rest of the thunks on this stack,
2561        * so we can stop early.
2562        *
2563        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2564        * don't interfere with this optimisation.
2565        */
2566       if (bh->header.info == &BLACKHOLE_info) {
2567         return;
2568       }
2569
2570       if (bh->header.info != &BLACKHOLE_BQ_info &&
2571           bh->header.info != &CAF_BLACKHOLE_info) {
2572         SET_INFO(bh,&BLACKHOLE_info);
2573       }
2574
2575       update_frame = update_frame->link;
2576       break;
2577
2578     case SEQ_FRAME:
2579       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2580       break;
2581
2582     case STOP_FRAME:
2583       return;
2584     default:
2585       barf("threadPaused");
2586     }
2587   }
2588 }
2589
2590 /* -----------------------------------------------------------------------------
2591  * Stack squeezing
2592  *
2593  * Code largely pinched from old RTS, then hacked to bits.  We also do
2594  * lazy black holing here.
2595  *
2596  * -------------------------------------------------------------------------- */
2597
2598 static void
2599 threadSqueezeStack(StgTSO *tso)
2600 {
2601   lnat displacement = 0;
2602   StgUpdateFrame *frame;
2603   StgUpdateFrame *next_frame;                   /* Temporally next */
2604   StgUpdateFrame *prev_frame;                   /* Temporally previous */
2605   StgPtr bottom;
2606   rtsBool prev_was_update_frame;
2607
2608   bottom = &(tso->stack[tso->stack_size]);
2609   frame  = tso->su;
2610
2611   /* There must be at least one frame, namely the STOP_FRAME.
2612    */
2613   ASSERT((P_)frame < bottom);
2614
2615   /* Walk down the stack, reversing the links between frames so that
2616    * we can walk back up as we squeeze from the bottom.  Note that
2617    * next_frame and prev_frame refer to next and previous as they were
2618    * added to the stack, rather than the way we see them in this
2619    * walk. (It makes the next loop less confusing.)
2620    *
2621    * Stop if we find an update frame pointing to a black hole
2622    * (see comment in threadLazyBlackHole()).
2623    */
2624
2625   next_frame = NULL;
2626   while ((P_)frame < bottom - 1) {  /* bottom - 1 is the STOP_FRAME */
2627     prev_frame = frame->link;
2628     frame->link = next_frame;
2629     next_frame = frame;
2630     frame = prev_frame;
2631     if (get_itbl(frame)->type == UPDATE_FRAME
2632         && frame->updatee->header.info == &BLACKHOLE_info) {
2633         break;
2634     }
2635   }
2636
2637   /* Now, we're at the bottom.  Frame points to the lowest update
2638    * frame on the stack, and its link actually points to the frame
2639    * above. We have to walk back up the stack, squeezing out empty
2640    * update frames and turning the pointers back around on the way
2641    * back up.
2642    *
2643    * The bottom-most frame (the STOP_FRAME) has not been altered, and
2644    * we never want to eliminate it anyway.  Just walk one step up
2645    * before starting to squeeze. When you get to the topmost frame,
2646    * remember that there are still some words above it that might have
2647    * to be moved.
2648    */
2649
2650   prev_frame = frame;
2651   frame = next_frame;
2652
2653   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2654
2655   /*
2656    * Loop through all of the frames (everything except the very
2657    * bottom).  Things are complicated by the fact that we have
2658    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2659    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2660    */
2661   while (frame != NULL) {
2662     StgPtr sp;
2663     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2664     rtsBool is_update_frame;
2665
2666     next_frame = frame->link;
2667     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2668
2669     /* Check to see if
2670      *   1. both the previous and current frame are update frames
2671      *   2. the current frame is empty
2672      */
2673     if (prev_was_update_frame && is_update_frame &&
2674         (P_)prev_frame == frame_bottom + displacement) {
2675
2676       /* Now squeeze out the current frame */
2677       StgClosure *updatee_keep   = prev_frame->updatee;
2678       StgClosure *updatee_bypass = frame->updatee;
2679
2680 #if 0 /* DEBUG */
2681       fprintf(stderr, "squeezing frame at %p\n", frame);
2682 #endif
2683
2684       /* Deal with blocking queues.  If both updatees have blocked
2685        * threads, then we should merge the queues into the update
2686        * frame that we're keeping.
2687        *
2688        * Alternatively, we could just wake them up: they'll just go
2689        * straight to sleep on the proper blackhole!  This is less code
2690        * and probably less bug prone, although it's probably much
2691        * slower --SDM
2692        */
2693 #if 0 /* do it properly... */
2694       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
2695         /* Sigh.  It has one.  Don't lose those threads! */
2696           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2697           /* Urgh.  Two queues.  Merge them. */
2698           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2699
2700           while (keep_tso->link != END_TSO_QUEUE) {
2701             keep_tso = keep_tso->link;
2702           }
2703           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2704
2705         } else {
2706           /* For simplicity, just swap the BQ for the BH */
2707           P_ temp = updatee_keep;
2708
2709           updatee_keep = updatee_bypass;
2710           updatee_bypass = temp;
2711
2712           /* Record the swap in the kept frame (below) */
2713           prev_frame->updatee = updatee_keep;
2714         }
2715       }
2716 #endif
2717
2718       TICK_UPD_SQUEEZED();
2719       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2720
2721       sp = (P_)frame - 1;       /* sp = stuff to slide */
2722       displacement += sizeofW(StgUpdateFrame);
2723
2724     } else {
2725       /* No squeeze for this frame */
2726       sp = frame_bottom - 1;    /* Keep the current frame */
2727
2728       /* Do lazy black-holing.
2729        */
2730       if (is_update_frame) {
2731         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2732         if (bh->header.info != &BLACKHOLE_BQ_info &&
2733             bh->header.info != &CAF_BLACKHOLE_info) {
2734           SET_INFO(bh,&BLACKHOLE_info);
2735         }
2736       }
2737
2738       /* Fix the link in the current frame (should point to the frame below) */
2739       frame->link = prev_frame;
2740       prev_was_update_frame = is_update_frame;
2741     }
2742
2743     /* Now slide all words from sp up to the next frame */
2744
2745     if (displacement > 0) {
2746       P_ next_frame_bottom;
2747
2748       if (next_frame != NULL)
2749         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2750       else
2751         next_frame_bottom = tso->sp - 1;
2752
2753 #if 0 /* DEBUG */
2754       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2755               displacement);
2756 #endif
2757
2758       while (sp >= next_frame_bottom) {
2759         sp[displacement] = *sp;
2760         sp -= 1;
2761       }
2762     }
2763     (P_)prev_frame = (P_)frame + displacement;
2764     frame = next_frame;
2765   }
2766
2767   tso->sp += displacement;
2768   tso->su = prev_frame;
2769 }
2770
2771 /* -----------------------------------------------------------------------------
2772  * Pausing a thread
2773  *
2774  * We have to prepare for GC - this means doing lazy black holing
2775  * here.  We also take the opportunity to do stack squeezing if it's
2776  * turned on.
2777  * -------------------------------------------------------------------------- */
2778
2779 void
2780 threadPaused(StgTSO *tso)
2781 {
2782   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2783     threadSqueezeStack(tso);    /* does black holing too */
2784   else
2785     threadLazyBlackHole(tso);
2786 }