ghc/rts/GC.c

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