ghc/rts/GC.c

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