ghc/rts/GC.c

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