ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.26 1999/02/05 15:25:07 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 ARR_WORDS:
1280     {
1281       nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1282
1283       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1284         evacuate_large((P_)q, rtsFalse);
1285         return q;
1286       } else {
1287         /* just copy the block */
1288         to = copy(q,size,step);
1289         upd_evacuee(q,to);
1290         return to;
1291       }
1292     }
1293
1294   case MUT_ARR_PTRS:
1295   case MUT_ARR_PTRS_FROZEN:
1296     {
1297       nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1298
1299       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1300         evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1301         to = q;
1302       } else {
1303         /* just copy the block */
1304         to = copy(q,size,step);
1305         upd_evacuee(q,to);
1306         if (info->type == MUT_ARR_PTRS) {
1307           recordMutable((StgMutClosure *)to);
1308         }
1309       }
1310       return to;
1311     }
1312
1313   case TSO:
1314     {
1315       StgTSO *tso = stgCast(StgTSO *,q);
1316       nat size = tso_sizeW(tso);
1317       int diff;
1318
1319       /* Large TSOs don't get moved, so no relocation is required.
1320        */
1321       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1322         evacuate_large((P_)q, rtsTrue);
1323         return q;
1324
1325       /* To evacuate a small TSO, we need to relocate the update frame
1326        * list it contains.
1327        */
1328       } else {
1329         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1330
1331         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1332
1333         /* relocate the stack pointers... */
1334         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1335         new_tso->sp = (StgPtr)new_tso->sp + diff;
1336         new_tso->splim = (StgPtr)new_tso->splim + diff;
1337
1338         relocate_TSO(tso, new_tso);
1339         upd_evacuee(q,(StgClosure *)new_tso);
1340
1341         recordMutable((StgMutClosure *)new_tso);
1342         return (StgClosure *)new_tso;
1343       }
1344     }
1345
1346   case BLOCKED_FETCH:
1347   case FETCH_ME:
1348     fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1349     return q;
1350
1351   default:
1352     barf("evacuate: strange closure type");
1353   }
1354
1355   barf("evacuate");
1356 }
1357
1358 /* -----------------------------------------------------------------------------
1359    relocate_TSO is called just after a TSO has been copied from src to
1360    dest.  It adjusts the update frame list for the new location.
1361    -------------------------------------------------------------------------- */
1362
1363 StgTSO *
1364 relocate_TSO(StgTSO *src, StgTSO *dest)
1365 {
1366   StgUpdateFrame *su;
1367   StgCatchFrame  *cf;
1368   StgSeqFrame    *sf;
1369   int diff;
1370
1371   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1372
1373   su = dest->su;
1374
1375   while ((P_)su < dest->stack + dest->stack_size) {
1376     switch (get_itbl(su)->type) {
1377
1378       /* GCC actually manages to common up these three cases! */
1379
1380     case UPDATE_FRAME:
1381       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1382       su = su->link;
1383       continue;
1384
1385     case CATCH_FRAME:
1386       cf = (StgCatchFrame *)su;
1387       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1388       su = cf->link;
1389       continue;
1390
1391     case SEQ_FRAME:
1392       sf = (StgSeqFrame *)su;
1393       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1394       su = sf->link;
1395       continue;
1396
1397     case STOP_FRAME:
1398       /* all done! */
1399       break;
1400
1401     default:
1402       barf("relocate_TSO");
1403     }
1404     break;
1405   }
1406
1407   return dest;
1408 }
1409
1410 static inline void
1411 scavenge_srt(const StgInfoTable *info)
1412 {
1413   StgClosure **srt, **srt_end;
1414
1415   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1416    * srt field in the info table.  That's ok, because we'll
1417    * never dereference it.
1418    */
1419   srt = stgCast(StgClosure **,info->srt);
1420   srt_end = srt + info->srt_len;
1421   for (; srt < srt_end; srt++) {
1422     evacuate(*srt);
1423   }
1424 }
1425
1426 /* -----------------------------------------------------------------------------
1427    Scavenge a given step until there are no more objects in this step
1428    to scavenge.
1429
1430    evac_gen is set by the caller to be either zero (for a step in a
1431    generation < N) or G where G is the generation of the step being
1432    scavenged.
1433
1434    We sometimes temporarily change evac_gen back to zero if we're
1435    scavenging a mutable object where early promotion isn't such a good
1436    idea.
1437    -------------------------------------------------------------------------- */
1438
1439
1440 static void
1441 scavenge(step *step)
1442 {
1443   StgPtr p, q;
1444   const StgInfoTable *info;
1445   bdescr *bd;
1446   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1447
1448   p = step->scan;
1449   bd = step->scan_bd;
1450
1451   failed_to_evac = rtsFalse;
1452
1453   /* scavenge phase - standard breadth-first scavenging of the
1454    * evacuated objects
1455    */
1456
1457   while (bd != step->hp_bd || p < step->hp) {
1458
1459     /* If we're at the end of this block, move on to the next block */
1460     if (bd != step->hp_bd && p == bd->free) {
1461       bd = bd->link;
1462       p = bd->start;
1463       continue;
1464     }
1465
1466     q = p;                      /* save ptr to object */
1467
1468     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1469                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1470
1471     info = get_itbl((StgClosure *)p);
1472     switch (info -> type) {
1473
1474     case BCO:
1475       {
1476         StgBCO* bco = stgCast(StgBCO*,p);
1477         nat i;
1478         for (i = 0; i < bco->n_ptrs; i++) {
1479           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1480         }
1481         p += bco_sizeW(bco);
1482         break;
1483       }
1484
1485     case MVAR:
1486       /* treat MVars specially, because we don't want to evacuate the
1487        * mut_link field in the middle of the closure.
1488        */
1489       {
1490         StgMVar *mvar = ((StgMVar *)p);
1491         evac_gen = 0;
1492         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1493         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1494         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1495         p += sizeofW(StgMVar);
1496         evac_gen = saved_evac_gen;
1497         break;
1498       }
1499
1500     case THUNK_2_0:
1501     case FUN_2_0:
1502       scavenge_srt(info);
1503     case CONSTR_2_0:
1504       ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1505       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1506       p += sizeofW(StgHeader) + 2;
1507       break;
1508
1509     case THUNK_1_0:
1510       scavenge_srt(info);
1511       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1512       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1513       break;
1514
1515     case FUN_1_0:
1516       scavenge_srt(info);
1517     case CONSTR_1_0:
1518       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1519       p += sizeofW(StgHeader) + 1;
1520       break;
1521
1522     case THUNK_0_1:
1523       scavenge_srt(info);
1524       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1525       break;
1526
1527     case FUN_0_1:
1528       scavenge_srt(info);
1529     case CONSTR_0_1:
1530       p += sizeofW(StgHeader) + 1;
1531       break;
1532
1533     case THUNK_0_2:
1534     case FUN_0_2:
1535       scavenge_srt(info);
1536     case CONSTR_0_2:
1537       p += sizeofW(StgHeader) + 2;
1538       break;
1539
1540     case THUNK_1_1:
1541     case FUN_1_1:
1542       scavenge_srt(info);
1543     case CONSTR_1_1:
1544       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1545       p += sizeofW(StgHeader) + 2;
1546       break;
1547
1548     case FUN:
1549     case THUNK:
1550       scavenge_srt(info);
1551       /* fall through */
1552
1553     case CONSTR:
1554     case WEAK:
1555     case FOREIGN:
1556     case STABLE_NAME:
1557     case IND_PERM:
1558     case IND_OLDGEN_PERM:
1559     case CAF_UNENTERED:
1560     case CAF_ENTERED:
1561       {
1562         StgPtr end;
1563
1564         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1565         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1566           (StgClosure *)*p = evacuate((StgClosure *)*p);
1567         }
1568         p += info->layout.payload.nptrs;
1569         break;
1570       }
1571
1572     case MUT_VAR:
1573       /* ignore MUT_CONSs */
1574       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1575         evac_gen = 0;
1576         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1577         evac_gen = saved_evac_gen;
1578       }
1579       p += sizeofW(StgMutVar);
1580       break;
1581
1582     case CAF_BLACKHOLE:
1583     case BLACKHOLE:
1584         p += BLACKHOLE_sizeW();
1585         break;
1586
1587     case BLACKHOLE_BQ:
1588       {
1589         StgBlockingQueue *bh = (StgBlockingQueue *)p;
1590         (StgClosure *)bh->blocking_queue =
1591           evacuate((StgClosure *)bh->blocking_queue);
1592         if (failed_to_evac) {
1593           failed_to_evac = rtsFalse;
1594           recordMutable((StgMutClosure *)bh);
1595         }
1596         p += BLACKHOLE_sizeW();
1597         break;
1598       }
1599
1600     case THUNK_SELECTOR:
1601       {
1602         StgSelector *s = (StgSelector *)p;
1603         s->selectee = evacuate(s->selectee);
1604         p += THUNK_SELECTOR_sizeW();
1605         break;
1606       }
1607
1608     case IND:
1609     case IND_OLDGEN:
1610       barf("scavenge:IND???\n");
1611
1612     case CONSTR_INTLIKE:
1613     case CONSTR_CHARLIKE:
1614     case CONSTR_STATIC:
1615     case CONSTR_NOCAF_STATIC:
1616     case THUNK_STATIC:
1617     case FUN_STATIC:
1618     case IND_STATIC:
1619       /* Shouldn't see a static object here. */
1620       barf("scavenge: STATIC object\n");
1621
1622     case RET_BCO:
1623     case RET_SMALL:
1624     case RET_VEC_SMALL:
1625     case RET_BIG:
1626     case RET_VEC_BIG:
1627     case RET_DYN:
1628     case UPDATE_FRAME:
1629     case STOP_FRAME:
1630     case CATCH_FRAME:
1631     case SEQ_FRAME:
1632       /* Shouldn't see stack frames here. */
1633       barf("scavenge: stack frame\n");
1634
1635     case AP_UPD: /* same as PAPs */
1636     case PAP:
1637       /* Treat a PAP just like a section of stack, not forgetting to
1638        * evacuate the function pointer too...
1639        */
1640       {
1641         StgPAP* pap = stgCast(StgPAP*,p);
1642
1643         pap->fun = evacuate(pap->fun);
1644         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1645         p += pap_sizeW(pap);
1646         break;
1647       }
1648
1649     case ARR_WORDS:
1650       /* nothing to follow */
1651       p += arr_words_sizeW(stgCast(StgArrWords*,p));
1652       break;
1653
1654     case MUT_ARR_PTRS:
1655       /* follow everything */
1656       {
1657         StgPtr next;
1658
1659         evac_gen = 0;           /* repeatedly mutable */
1660         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1661         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1662           (StgClosure *)*p = evacuate((StgClosure *)*p);
1663         }
1664         evac_gen = saved_evac_gen;
1665         break;
1666       }
1667
1668     case MUT_ARR_PTRS_FROZEN:
1669       /* follow everything */
1670       {
1671         StgPtr start = p, next;
1672
1673         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1674         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1675           (StgClosure *)*p = evacuate((StgClosure *)*p);
1676         }
1677         if (failed_to_evac) {
1678           /* we can do this easier... */
1679           recordMutable((StgMutClosure *)start);
1680           failed_to_evac = rtsFalse;
1681         }
1682         break;
1683       }
1684
1685     case TSO:
1686       {
1687         StgTSO *tso;
1688
1689         tso = (StgTSO *)p;
1690         evac_gen = 0;
1691         /* chase the link field for any TSOs on the same queue */
1692         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1693         /* scavenge this thread's stack */
1694         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1695         evac_gen = saved_evac_gen;
1696         p += tso_sizeW(tso);
1697         break;
1698       }
1699
1700     case BLOCKED_FETCH:
1701     case FETCH_ME:
1702     case EVACUATED:
1703       barf("scavenge: unimplemented/strange closure type\n");
1704
1705     default:
1706       barf("scavenge");
1707     }
1708
1709     /* If we didn't manage to promote all the objects pointed to by
1710      * the current object, then we have to designate this object as
1711      * mutable (because it contains old-to-new generation pointers).
1712      */
1713     if (failed_to_evac) {
1714       mkMutCons((StgClosure *)q, &generations[evac_gen]);
1715       failed_to_evac = rtsFalse;
1716     }
1717   }
1718
1719   step->scan_bd = bd;
1720   step->scan = p;
1721 }
1722
1723 /* -----------------------------------------------------------------------------
1724    Scavenge one object.
1725
1726    This is used for objects that are temporarily marked as mutable
1727    because they contain old-to-new generation pointers.  Only certain
1728    objects can have this property.
1729    -------------------------------------------------------------------------- */
1730 static rtsBool
1731 scavenge_one(StgClosure *p)
1732 {
1733   StgInfoTable *info;
1734   rtsBool no_luck;
1735
1736   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1737                || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1738
1739   info = get_itbl(p);
1740
1741   switch (info -> type) {
1742
1743   case FUN:
1744   case FUN_1_0:                 /* hardly worth specialising these guys */
1745   case FUN_0_1:
1746   case FUN_1_1:
1747   case FUN_0_2:
1748   case FUN_2_0:
1749   case THUNK:
1750   case THUNK_1_0:
1751   case THUNK_0_1:
1752   case THUNK_1_1:
1753   case THUNK_0_2:
1754   case THUNK_2_0:
1755   case CONSTR:
1756   case CONSTR_1_0:
1757   case CONSTR_0_1:
1758   case CONSTR_1_1:
1759   case CONSTR_0_2:
1760   case CONSTR_2_0:
1761   case WEAK:
1762   case FOREIGN:
1763   case IND_PERM:
1764   case IND_OLDGEN_PERM:
1765   case CAF_UNENTERED:
1766   case CAF_ENTERED:
1767     {
1768       StgPtr q, end;
1769
1770       end = (P_)p->payload + info->layout.payload.ptrs;
1771       for (q = (P_)p->payload; q < end; q++) {
1772         (StgClosure *)*q = evacuate((StgClosure *)*q);
1773       }
1774       break;
1775     }
1776
1777   case CAF_BLACKHOLE:
1778   case BLACKHOLE:
1779       break;
1780
1781   case THUNK_SELECTOR:
1782     {
1783       StgSelector *s = (StgSelector *)p;
1784       s->selectee = evacuate(s->selectee);
1785       break;
1786     }
1787
1788   case AP_UPD: /* same as PAPs */
1789   case PAP:
1790     /* Treat a PAP just like a section of stack, not forgetting to
1791      * evacuate the function pointer too...
1792      */
1793     {
1794       StgPAP* pap = (StgPAP *)p;
1795
1796       pap->fun = evacuate(pap->fun);
1797       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1798       break;
1799     }
1800
1801   case IND_OLDGEN:
1802     /* This might happen if for instance a MUT_CONS was pointing to a
1803      * THUNK which has since been updated.  The IND_OLDGEN will
1804      * be on the mutable list anyway, so we don't need to do anything
1805      * here.
1806      */
1807     break;
1808
1809   default:
1810     barf("scavenge_one: strange object");
1811   }
1812
1813   no_luck = failed_to_evac;
1814   failed_to_evac = rtsFalse;
1815   return (no_luck);
1816 }
1817
1818
1819 /* -----------------------------------------------------------------------------
1820    Scavenging mutable lists.
1821
1822    We treat the mutable list of each generation > N (i.e. all the
1823    generations older than the one being collected) as roots.  We also
1824    remove non-mutable objects from the mutable list at this point.
1825    -------------------------------------------------------------------------- */
1826
1827 static void
1828 scavenge_mut_once_list(generation *gen)
1829 {
1830   StgInfoTable *info;
1831   StgMutClosure *p, *next, *new_list;
1832
1833   p = gen->mut_once_list;
1834   new_list = END_MUT_LIST;
1835   next = p->mut_link;
1836
1837   evac_gen = gen->no;
1838   failed_to_evac = rtsFalse;
1839
1840   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1841
1842     /* make sure the info pointer is into text space */
1843     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1844                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1845
1846     info = get_itbl(p);
1847     switch(info->type) {
1848
1849     case IND_OLDGEN:
1850     case IND_OLDGEN_PERM:
1851     case IND_STATIC:
1852       /* Try to pull the indirectee into this generation, so we can
1853        * remove the indirection from the mutable list.
1854        */
1855       ((StgIndOldGen *)p)->indirectee =
1856         evacuate(((StgIndOldGen *)p)->indirectee);
1857
1858 #if 0
1859       /* Debugging code to print out the size of the thing we just
1860        * promoted
1861        */
1862       {
1863         StgPtr start = gen->steps[0].scan;
1864         bdescr *start_bd = gen->steps[0].scan_bd;
1865         nat size = 0;
1866         scavenge(&gen->steps[0]);
1867         if (start_bd != gen->steps[0].scan_bd) {
1868           size += (P_)BLOCK_ROUND_UP(start) - start;
1869           start_bd = start_bd->link;
1870           while (start_bd != gen->steps[0].scan_bd) {
1871             size += BLOCK_SIZE_W;
1872             start_bd = start_bd->link;
1873           }
1874           size += gen->steps[0].scan -
1875             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
1876         } else {
1877           size = gen->steps[0].scan - start;
1878         }
1879         fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
1880       }
1881 #endif
1882
1883       /* failed_to_evac might happen if we've got more than two
1884        * generations, we're collecting only generation 0, the
1885        * indirection resides in generation 2 and the indirectee is
1886        * in generation 1.
1887        */
1888       if (failed_to_evac) {
1889         failed_to_evac = rtsFalse;
1890         p->mut_link = new_list;
1891         new_list = p;
1892       } else {
1893         /* the mut_link field of an IND_STATIC is overloaded as the
1894          * static link field too (it just so happens that we don't need
1895          * both at the same time), so we need to NULL it out when
1896          * removing this object from the mutable list because the static
1897          * link fields are all assumed to be NULL before doing a major
1898          * collection.
1899          */
1900         p->mut_link = NULL;
1901       }
1902       continue;
1903
1904     case MUT_VAR:
1905       /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
1906        * it from the mutable list if possible by promoting whatever it
1907        * points to.
1908        */
1909       ASSERT(p->header.info == &MUT_CONS_info);
1910       if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
1911         /* didn't manage to promote everything, so put the
1912          * MUT_CONS back on the list.
1913          */
1914         p->mut_link = new_list;
1915         new_list = p;
1916       }
1917       continue;
1918
1919     default:
1920       /* shouldn't have anything else on the mutables list */
1921       barf("scavenge_mut_once_list: strange object?");
1922     }
1923   }
1924
1925   gen->mut_once_list = new_list;
1926 }
1927
1928
1929 static void
1930 scavenge_mutable_list(generation *gen)
1931 {
1932   StgInfoTable *info;
1933   StgMutClosure *p, *next, *new_list;
1934
1935   p = gen->saved_mut_list;
1936   new_list = END_MUT_LIST;
1937   next = p->mut_link;
1938
1939   evac_gen = 0;
1940   failed_to_evac = rtsFalse;
1941
1942   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1943
1944     /* make sure the info pointer is into text space */
1945     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1946                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1947
1948     info = get_itbl(p);
1949     switch(info->type) {
1950
1951     case MUT_ARR_PTRS_FROZEN:
1952       /* remove this guy from the mutable list, but follow the ptrs
1953        * anyway (and make sure they get promoted to this gen).
1954        */
1955       {
1956         StgPtr end, q;
1957
1958         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1959         evac_gen = gen->no;
1960         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1961           (StgClosure *)*q = evacuate((StgClosure *)*q);
1962         }
1963         evac_gen = 0;
1964
1965         if (failed_to_evac) {
1966           failed_to_evac = rtsFalse;
1967           p->mut_link = new_list;
1968           new_list = p;
1969         }
1970         continue;
1971       }
1972
1973     case MUT_ARR_PTRS:
1974       /* follow everything */
1975       p->mut_link = new_list;
1976       new_list = p;
1977       {
1978         StgPtr end, q;
1979
1980         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1981         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1982           (StgClosure *)*q = evacuate((StgClosure *)*q);
1983         }
1984         continue;
1985       }
1986
1987     case MUT_VAR:
1988       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
1989        * it from the mutable list if possible by promoting whatever it
1990        * points to.
1991        */
1992       ASSERT(p->header.info != &MUT_CONS_info);
1993       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1994       p->mut_link = new_list;
1995       new_list = p;
1996       continue;
1997
1998     case MVAR:
1999       {
2000         StgMVar *mvar = (StgMVar *)p;
2001         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2002         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2003         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2004         p->mut_link = new_list;
2005         new_list = p;
2006         continue;
2007       }
2008
2009     case TSO:
2010       /* follow ptrs and remove this from the mutable list */
2011       {
2012         StgTSO *tso = (StgTSO *)p;
2013
2014         /* Don't bother scavenging if this thread is dead
2015          */
2016         if (!(tso->whatNext == ThreadComplete ||
2017               tso->whatNext == ThreadKilled)) {
2018           /* Don't need to chase the link field for any TSOs on the
2019            * same queue. Just scavenge this thread's stack
2020            */
2021           scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2022         }
2023
2024         /* Don't take this TSO off the mutable list - it might still
2025          * point to some younger objects (because we set evac_gen to 0
2026          * above).
2027          */
2028         tso->mut_link = new_list;
2029         new_list = (StgMutClosure *)tso;
2030         continue;
2031       }
2032
2033     case BLACKHOLE_BQ:
2034       {
2035         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2036         (StgClosure *)bh->blocking_queue =
2037           evacuate((StgClosure *)bh->blocking_queue);
2038         p->mut_link = new_list;
2039         new_list = p;
2040         continue;
2041       }
2042
2043     default:
2044       /* shouldn't have anything else on the mutables list */
2045       barf("scavenge_mut_list: strange object?");
2046     }
2047   }
2048
2049   gen->mut_list = new_list;
2050 }
2051
2052 static void
2053 scavenge_static(void)
2054 {
2055   StgClosure* p = static_objects;
2056   const StgInfoTable *info;
2057
2058   /* Always evacuate straight to the oldest generation for static
2059    * objects */
2060   evac_gen = oldest_gen->no;
2061
2062   /* keep going until we've scavenged all the objects on the linked
2063      list... */
2064   while (p != END_OF_STATIC_LIST) {
2065
2066     info = get_itbl(p);
2067
2068     /* make sure the info pointer is into text space */
2069     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2070                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2071
2072     /* Take this object *off* the static_objects list,
2073      * and put it on the scavenged_static_objects list.
2074      */
2075     static_objects = STATIC_LINK(info,p);
2076     STATIC_LINK(info,p) = scavenged_static_objects;
2077     scavenged_static_objects = p;
2078
2079     switch (info -> type) {
2080
2081     case IND_STATIC:
2082       {
2083         StgInd *ind = (StgInd *)p;
2084         ind->indirectee = evacuate(ind->indirectee);
2085
2086         /* might fail to evacuate it, in which case we have to pop it
2087          * back on the mutable list (and take it off the
2088          * scavenged_static list because the static link and mut link
2089          * pointers are one and the same).
2090          */
2091         if (failed_to_evac) {
2092           failed_to_evac = rtsFalse;
2093           scavenged_static_objects = STATIC_LINK(info,p);
2094           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2095           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2096         }
2097         break;
2098       }
2099
2100     case THUNK_STATIC:
2101     case FUN_STATIC:
2102       scavenge_srt(info);
2103       /* fall through */
2104
2105     case CONSTR_STATIC:
2106       {
2107         StgPtr q, next;
2108
2109         next = (P_)p->payload + info->layout.payload.ptrs;
2110         /* evacuate the pointers */
2111         for (q = (P_)p->payload; q < next; q++) {
2112           (StgClosure *)*q = evacuate((StgClosure *)*q);
2113         }
2114         break;
2115       }
2116
2117     default:
2118       barf("scavenge_static");
2119     }
2120
2121     ASSERT(failed_to_evac == rtsFalse);
2122
2123     /* get the next static object from the list.  Remeber, there might
2124      * be more stuff on this list now that we've done some evacuating!
2125      * (static_objects is a global)
2126      */
2127     p = static_objects;
2128   }
2129 }
2130
2131 /* -----------------------------------------------------------------------------
2132    scavenge_stack walks over a section of stack and evacuates all the
2133    objects pointed to by it.  We can use the same code for walking
2134    PAPs, since these are just sections of copied stack.
2135    -------------------------------------------------------------------------- */
2136
2137 static void
2138 scavenge_stack(StgPtr p, StgPtr stack_end)
2139 {
2140   StgPtr q;
2141   const StgInfoTable* info;
2142   StgNat32 bitmap;
2143
2144   /*
2145    * Each time around this loop, we are looking at a chunk of stack
2146    * that starts with either a pending argument section or an
2147    * activation record.
2148    */
2149
2150   while (p < stack_end) {
2151     q = *stgCast(StgPtr*,p);
2152
2153     /* If we've got a tag, skip over that many words on the stack */
2154     if (IS_ARG_TAG(stgCast(StgWord,q))) {
2155       p += ARG_SIZE(q);
2156       p++; continue;
2157     }
2158
2159     /* Is q a pointer to a closure?
2160      */
2161     if (! LOOKS_LIKE_GHC_INFO(q)) {
2162
2163 #ifdef DEBUG
2164       if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
2165         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2166       }
2167       /* otherwise, must be a pointer into the allocation space.
2168        */
2169 #endif
2170
2171       (StgClosure *)*p = evacuate((StgClosure *)q);
2172       p++;
2173       continue;
2174     }
2175
2176     /*
2177      * Otherwise, q must be the info pointer of an activation
2178      * record.  All activation records have 'bitmap' style layout
2179      * info.
2180      */
2181     info  = get_itbl(stgCast(StgClosure*,p));
2182
2183     switch (info->type) {
2184
2185       /* Dynamic bitmap: the mask is stored on the stack */
2186     case RET_DYN:
2187       bitmap = stgCast(StgRetDyn*,p)->liveness;
2188       p      = &payloadWord(stgCast(StgRetDyn*,p),0);
2189       goto small_bitmap;
2190
2191       /* probably a slow-entry point return address: */
2192     case FUN:
2193     case FUN_STATIC:
2194       p++;
2195       goto follow_srt;
2196
2197       /* Specialised code for update frames, since they're so common.
2198        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2199        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2200        */
2201     case UPDATE_FRAME:
2202       {
2203         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2204         StgClosure *to;
2205         StgClosureType type = get_itbl(frame->updatee)->type;
2206
2207         p += sizeofW(StgUpdateFrame);
2208         if (type == EVACUATED) {
2209           frame->updatee = evacuate(frame->updatee);
2210           continue;
2211         } else {
2212           bdescr *bd = Bdescr((P_)frame->updatee);
2213           step *step;
2214           if (bd->gen->no > N) {
2215             if (bd->gen->no < evac_gen) {
2216               failed_to_evac = rtsTrue;
2217             }
2218             continue;
2219           }
2220           step = bd->step->to;
2221           switch (type) {
2222           case BLACKHOLE:
2223           case CAF_BLACKHOLE:
2224             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2225                           sizeofW(StgHeader), step);
2226             upd_evacuee(frame->updatee,to);
2227             frame->updatee = to;
2228             continue;
2229           case BLACKHOLE_BQ:
2230             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2231             upd_evacuee(frame->updatee,to);
2232             frame->updatee = to;
2233             recordMutable((StgMutClosure *)to);
2234             continue;
2235           default:
2236             barf("scavenge_stack: UPDATE_FRAME updatee");
2237           }
2238         }
2239       }
2240
2241       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2242     case RET_BCO:
2243     case RET_SMALL:
2244     case RET_VEC_SMALL:
2245     case STOP_FRAME:
2246     case CATCH_FRAME:
2247     case SEQ_FRAME:
2248       bitmap = info->layout.bitmap;
2249       p++;
2250     small_bitmap:
2251       while (bitmap != 0) {
2252         if ((bitmap & 1) == 0) {
2253           (StgClosure *)*p = evacuate((StgClosure *)*p);
2254         }
2255         p++;
2256         bitmap = bitmap >> 1;
2257       }
2258
2259     follow_srt:
2260       scavenge_srt(info);
2261       continue;
2262
2263       /* large bitmap (> 32 entries) */
2264     case RET_BIG:
2265     case RET_VEC_BIG:
2266       {
2267         StgPtr q;
2268         StgLargeBitmap *large_bitmap;
2269         nat i;
2270
2271         large_bitmap = info->layout.large_bitmap;
2272         p++;
2273
2274         for (i=0; i<large_bitmap->size; i++) {
2275           bitmap = large_bitmap->bitmap[i];
2276           q = p + sizeof(W_) * 8;
2277           while (bitmap != 0) {
2278             if ((bitmap & 1) == 0) {
2279               (StgClosure *)*p = evacuate((StgClosure *)*p);
2280             }
2281             p++;
2282             bitmap = bitmap >> 1;
2283           }
2284           if (i+1 < large_bitmap->size) {
2285             while (p < q) {
2286               (StgClosure *)*p = evacuate((StgClosure *)*p);
2287               p++;
2288             }
2289           }
2290         }
2291
2292         /* and don't forget to follow the SRT */
2293         goto follow_srt;
2294       }
2295
2296     default:
2297       barf("scavenge_stack: weird activation record found on stack.\n");
2298     }
2299   }
2300 }
2301
2302 /*-----------------------------------------------------------------------------
2303   scavenge the large object list.
2304
2305   evac_gen set by caller; similar games played with evac_gen as with
2306   scavenge() - see comment at the top of scavenge().  Most large
2307   objects are (repeatedly) mutable, so most of the time evac_gen will
2308   be zero.
2309   --------------------------------------------------------------------------- */
2310
2311 static void
2312 scavenge_large(step *step)
2313 {
2314   bdescr *bd;
2315   StgPtr p;
2316   const StgInfoTable* info;
2317   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2318
2319   evac_gen = 0;                 /* most objects are mutable */
2320   bd = step->new_large_objects;
2321
2322   for (; bd != NULL; bd = step->new_large_objects) {
2323
2324     /* take this object *off* the large objects list and put it on
2325      * the scavenged large objects list.  This is so that we can
2326      * treat new_large_objects as a stack and push new objects on
2327      * the front when evacuating.
2328      */
2329     step->new_large_objects = bd->link;
2330     dbl_link_onto(bd, &step->scavenged_large_objects);
2331
2332     p = bd->start;
2333     info  = get_itbl(stgCast(StgClosure*,p));
2334
2335     switch (info->type) {
2336
2337     /* only certain objects can be "large"... */
2338
2339     case ARR_WORDS:
2340       /* nothing to follow */
2341       continue;
2342
2343     case MUT_ARR_PTRS:
2344       /* follow everything */
2345       {
2346         StgPtr next;
2347
2348         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2349         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2350           (StgClosure *)*p = evacuate((StgClosure *)*p);
2351         }
2352         continue;
2353       }
2354
2355     case MUT_ARR_PTRS_FROZEN:
2356       /* follow everything */
2357       {
2358         StgPtr start = p, next;
2359
2360         evac_gen = saved_evac_gen; /* not really mutable */
2361         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2362         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2363           (StgClosure *)*p = evacuate((StgClosure *)*p);
2364         }
2365         evac_gen = 0;
2366         if (failed_to_evac) {
2367           recordMutable((StgMutClosure *)start);
2368         }
2369         continue;
2370       }
2371
2372     case BCO:
2373       {
2374         StgBCO* bco = stgCast(StgBCO*,p);
2375         nat i;
2376         evac_gen = saved_evac_gen;
2377         for (i = 0; i < bco->n_ptrs; i++) {
2378           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2379         }
2380         evac_gen = 0;
2381         continue;
2382       }
2383
2384     case TSO:
2385       {
2386         StgTSO *tso;
2387
2388         tso = (StgTSO *)p;
2389         /* chase the link field for any TSOs on the same queue */
2390         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2391         /* scavenge this thread's stack */
2392         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2393         continue;
2394       }
2395
2396     default:
2397       barf("scavenge_large: unknown/strange object");
2398     }
2399   }
2400 }
2401
2402 static void
2403 zeroStaticObjectList(StgClosure* first_static)
2404 {
2405   StgClosure* p;
2406   StgClosure* link;
2407   const StgInfoTable *info;
2408
2409   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2410     info = get_itbl(p);
2411     link = STATIC_LINK(info, p);
2412     STATIC_LINK(info,p) = NULL;
2413   }
2414 }
2415
2416 /* This function is only needed because we share the mutable link
2417  * field with the static link field in an IND_STATIC, so we have to
2418  * zero the mut_link field before doing a major GC, which needs the
2419  * static link field.
2420  *
2421  * It doesn't do any harm to zero all the mutable link fields on the
2422  * mutable list.
2423  */
2424 static void
2425 zeroMutableList(StgMutClosure *first)
2426 {
2427   StgMutClosure *next, *c;
2428
2429   for (c = first; c != END_MUT_LIST; c = next) {
2430     next = c->mut_link;
2431     c->mut_link = NULL;
2432   }
2433 }
2434
2435 /* -----------------------------------------------------------------------------
2436    Reverting CAFs
2437    -------------------------------------------------------------------------- */
2438
2439 void RevertCAFs(void)
2440 {
2441   while (enteredCAFs != END_CAF_LIST) {
2442     StgCAF* caf = enteredCAFs;
2443
2444     enteredCAFs = caf->link;
2445     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2446     SET_INFO(caf,&CAF_UNENTERED_info);
2447     caf->value = stgCast(StgClosure*,0xdeadbeef);
2448     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2449   }
2450 }
2451
2452 void revertDeadCAFs(void)
2453 {
2454     StgCAF* caf = enteredCAFs;
2455     enteredCAFs = END_CAF_LIST;
2456     while (caf != END_CAF_LIST) {
2457         StgCAF* next = caf->link;
2458
2459         switch(GET_INFO(caf)->type) {
2460         case EVACUATED:
2461             {
2462                 /* This object has been evacuated, it must be live. */
2463                 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2464                 new->link = enteredCAFs;
2465                 enteredCAFs = new;
2466                 break;
2467             }
2468         case CAF_ENTERED:
2469             {
2470                 SET_INFO(caf,&CAF_UNENTERED_info);
2471                 caf->value = stgCast(StgClosure*,0xdeadbeef);
2472                 caf->link  = stgCast(StgCAF*,0xdeadbeef);
2473                 break;
2474             }
2475         default:
2476                 barf("revertDeadCAFs: enteredCAFs list corrupted");
2477         }
2478         caf = next;
2479     }
2480 }
2481
2482 /* -----------------------------------------------------------------------------
2483    Sanity code for CAF garbage collection.
2484
2485    With DEBUG turned on, we manage a CAF list in addition to the SRT
2486    mechanism.  After GC, we run down the CAF list and blackhole any
2487    CAFs which have been garbage collected.  This means we get an error
2488    whenever the program tries to enter a garbage collected CAF.
2489
2490    Any garbage collected CAFs are taken off the CAF list at the same
2491    time.
2492    -------------------------------------------------------------------------- */
2493
2494 #ifdef DEBUG
2495 static void
2496 gcCAFs(void)
2497 {
2498   StgClosure*  p;
2499   StgClosure** pp;
2500   const StgInfoTable *info;
2501   nat i;
2502
2503   i = 0;
2504   p = caf_list;
2505   pp = &caf_list;
2506
2507   while (p != NULL) {
2508
2509     info = get_itbl(p);
2510
2511     ASSERT(info->type == IND_STATIC);
2512
2513     if (STATIC_LINK(info,p) == NULL) {
2514       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2515       /* black hole it */
2516       SET_INFO(p,&BLACKHOLE_info);
2517       p = STATIC_LINK2(info,p);
2518       *pp = p;
2519     }
2520     else {
2521       pp = &STATIC_LINK2(info,p);
2522       p = *pp;
2523       i++;
2524     }
2525
2526   }
2527
2528   /*  fprintf(stderr, "%d CAFs live\n", i); */
2529 }
2530 #endif
2531
2532 /* -----------------------------------------------------------------------------
2533    Lazy black holing.
2534
2535    Whenever a thread returns to the scheduler after possibly doing
2536    some work, we have to run down the stack and black-hole all the
2537    closures referred to by update frames.
2538    -------------------------------------------------------------------------- */
2539
2540 static void
2541 threadLazyBlackHole(StgTSO *tso)
2542 {
2543   StgUpdateFrame *update_frame;
2544   StgBlockingQueue *bh;
2545   StgPtr stack_end;
2546
2547   stack_end = &tso->stack[tso->stack_size];
2548   update_frame = tso->su;
2549
2550   while (1) {
2551     switch (get_itbl(update_frame)->type) {
2552
2553     case CATCH_FRAME:
2554       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2555       break;
2556
2557     case UPDATE_FRAME:
2558       bh = (StgBlockingQueue *)update_frame->updatee;
2559
2560       /* if the thunk is already blackholed, it means we've also
2561        * already blackholed the rest of the thunks on this stack,
2562        * so we can stop early.
2563        *
2564        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2565        * don't interfere with this optimisation.
2566        */
2567       if (bh->header.info == &BLACKHOLE_info) {
2568         return;
2569       }
2570
2571       if (bh->header.info != &BLACKHOLE_BQ_info &&
2572           bh->header.info != &CAF_BLACKHOLE_info) {
2573         SET_INFO(bh,&BLACKHOLE_info);
2574       }
2575
2576       update_frame = update_frame->link;
2577       break;
2578
2579     case SEQ_FRAME:
2580       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2581       break;
2582
2583     case STOP_FRAME:
2584       return;
2585     default:
2586       barf("threadPaused");
2587     }
2588   }
2589 }
2590
2591 /* -----------------------------------------------------------------------------
2592  * Stack squeezing
2593  *
2594  * Code largely pinched from old RTS, then hacked to bits.  We also do
2595  * lazy black holing here.
2596  *
2597  * -------------------------------------------------------------------------- */
2598
2599 static void
2600 threadSqueezeStack(StgTSO *tso)
2601 {
2602   lnat displacement = 0;
2603   StgUpdateFrame *frame;
2604   StgUpdateFrame *next_frame;                   /* Temporally next */
2605   StgUpdateFrame *prev_frame;                   /* Temporally previous */
2606   StgPtr bottom;
2607   rtsBool prev_was_update_frame;
2608
2609   bottom = &(tso->stack[tso->stack_size]);
2610   frame  = tso->su;
2611
2612   /* There must be at least one frame, namely the STOP_FRAME.
2613    */
2614   ASSERT((P_)frame < bottom);
2615
2616   /* Walk down the stack, reversing the links between frames so that
2617    * we can walk back up as we squeeze from the bottom.  Note that
2618    * next_frame and prev_frame refer to next and previous as they were
2619    * added to the stack, rather than the way we see them in this
2620    * walk. (It makes the next loop less confusing.)
2621    *
2622    * Stop if we find an update frame pointing to a black hole
2623    * (see comment in threadLazyBlackHole()).
2624    */
2625
2626   next_frame = NULL;
2627   while ((P_)frame < bottom - 1) {  /* bottom - 1 is the STOP_FRAME */
2628     prev_frame = frame->link;
2629     frame->link = next_frame;
2630     next_frame = frame;
2631     frame = prev_frame;
2632     if (get_itbl(frame)->type == UPDATE_FRAME
2633         && frame->updatee->header.info == &BLACKHOLE_info) {
2634         break;
2635     }
2636   }
2637
2638   /* Now, we're at the bottom.  Frame points to the lowest update
2639    * frame on the stack, and its link actually points to the frame
2640    * above. We have to walk back up the stack, squeezing out empty
2641    * update frames and turning the pointers back around on the way
2642    * back up.
2643    *
2644    * The bottom-most frame (the STOP_FRAME) has not been altered, and
2645    * we never want to eliminate it anyway.  Just walk one step up
2646    * before starting to squeeze. When you get to the topmost frame,
2647    * remember that there are still some words above it that might have
2648    * to be moved.
2649    */
2650
2651   prev_frame = frame;
2652   frame = next_frame;
2653
2654   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2655
2656   /*
2657    * Loop through all of the frames (everything except the very
2658    * bottom).  Things are complicated by the fact that we have
2659    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2660    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2661    */
2662   while (frame != NULL) {
2663     StgPtr sp;
2664     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2665     rtsBool is_update_frame;
2666
2667     next_frame = frame->link;
2668     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2669
2670     /* Check to see if
2671      *   1. both the previous and current frame are update frames
2672      *   2. the current frame is empty
2673      */
2674     if (prev_was_update_frame && is_update_frame &&
2675         (P_)prev_frame == frame_bottom + displacement) {
2676
2677       /* Now squeeze out the current frame */
2678       StgClosure *updatee_keep   = prev_frame->updatee;
2679       StgClosure *updatee_bypass = frame->updatee;
2680
2681 #if 0 /* DEBUG */
2682       fprintf(stderr, "squeezing frame at %p\n", frame);
2683 #endif
2684
2685       /* Deal with blocking queues.  If both updatees have blocked
2686        * threads, then we should merge the queues into the update
2687        * frame that we're keeping.
2688        *
2689        * Alternatively, we could just wake them up: they'll just go
2690        * straight to sleep on the proper blackhole!  This is less code
2691        * and probably less bug prone, although it's probably much
2692        * slower --SDM
2693        */
2694 #if 0 /* do it properly... */
2695       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
2696         /* Sigh.  It has one.  Don't lose those threads! */
2697           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2698           /* Urgh.  Two queues.  Merge them. */
2699           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2700
2701           while (keep_tso->link != END_TSO_QUEUE) {
2702             keep_tso = keep_tso->link;
2703           }
2704           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2705
2706         } else {
2707           /* For simplicity, just swap the BQ for the BH */
2708           P_ temp = updatee_keep;
2709
2710           updatee_keep = updatee_bypass;
2711           updatee_bypass = temp;
2712
2713           /* Record the swap in the kept frame (below) */
2714           prev_frame->updatee = updatee_keep;
2715         }
2716       }
2717 #endif
2718
2719       TICK_UPD_SQUEEZED();
2720       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2721
2722       sp = (P_)frame - 1;       /* sp = stuff to slide */
2723       displacement += sizeofW(StgUpdateFrame);
2724
2725     } else {
2726       /* No squeeze for this frame */
2727       sp = frame_bottom - 1;    /* Keep the current frame */
2728
2729       /* Do lazy black-holing.
2730        */
2731       if (is_update_frame) {
2732         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2733         if (bh->header.info != &BLACKHOLE_BQ_info &&
2734             bh->header.info != &CAF_BLACKHOLE_info) {
2735           SET_INFO(bh,&BLACKHOLE_info);
2736         }
2737       }
2738
2739       /* Fix the link in the current frame (should point to the frame below) */
2740       frame->link = prev_frame;
2741       prev_was_update_frame = is_update_frame;
2742     }
2743
2744     /* Now slide all words from sp up to the next frame */
2745
2746     if (displacement > 0) {
2747       P_ next_frame_bottom;
2748
2749       if (next_frame != NULL)
2750         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2751       else
2752         next_frame_bottom = tso->sp - 1;
2753
2754 #if 0 /* DEBUG */
2755       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2756               displacement);
2757 #endif
2758
2759       while (sp >= next_frame_bottom) {
2760         sp[displacement] = *sp;
2761         sp -= 1;
2762       }
2763     }
2764     (P_)prev_frame = (P_)frame + displacement;
2765     frame = next_frame;
2766   }
2767
2768   tso->sp += displacement;
2769   tso->su = prev_frame;
2770 }
2771
2772 /* -----------------------------------------------------------------------------
2773  * Pausing a thread
2774  *
2775  * We have to prepare for GC - this means doing lazy black holing
2776  * here.  We also take the opportunity to do stack squeezing if it's
2777  * turned on.
2778  * -------------------------------------------------------------------------- */
2779
2780 void
2781 threadPaused(StgTSO *tso)
2782 {
2783   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2784     threadSqueezeStack(tso);    /* does black holing too */
2785   else
2786     threadLazyBlackHole(tso);
2787 }