ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.67 1999/11/18 16:02:21 sewardj 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 given step until there are no more objects in this step
1519    to scavenge.
1520
1521    evac_gen is set by the caller to be either zero (for a step in a
1522    generation < N) or G where G is the generation of the step being
1523    scavenged.
1524
1525    We sometimes temporarily change evac_gen back to zero if we're
1526    scavenging a mutable object where early promotion isn't such a good
1527    idea.
1528    -------------------------------------------------------------------------- */
1529
1530
1531 static void
1532 scavenge(step *step)
1533 {
1534   StgPtr p, q;
1535   const StgInfoTable *info;
1536   bdescr *bd;
1537   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1538
1539   p = step->scan;
1540   bd = step->scan_bd;
1541
1542   failed_to_evac = rtsFalse;
1543
1544   /* scavenge phase - standard breadth-first scavenging of the
1545    * evacuated objects
1546    */
1547
1548   while (bd != step->hp_bd || p < step->hp) {
1549
1550     /* If we're at the end of this block, move on to the next block */
1551     if (bd != step->hp_bd && p == bd->free) {
1552       bd = bd->link;
1553       p = bd->start;
1554       continue;
1555     }
1556
1557     q = p;                      /* save ptr to object */
1558
1559     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1560                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1561
1562     info = get_itbl((StgClosure *)p);
1563     switch (info -> type) {
1564
1565     case BCO:
1566       {
1567         StgBCO* bco = stgCast(StgBCO*,p);
1568         nat i;
1569         for (i = 0; i < bco->n_ptrs; i++) {
1570           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1571         }
1572         p += bco_sizeW(bco);
1573         break;
1574       }
1575
1576     case MVAR:
1577       /* treat MVars specially, because we don't want to evacuate the
1578        * mut_link field in the middle of the closure.
1579        */
1580       {
1581         StgMVar *mvar = ((StgMVar *)p);
1582         evac_gen = 0;
1583         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1584         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1585         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1586         p += sizeofW(StgMVar);
1587         evac_gen = saved_evac_gen;
1588         break;
1589       }
1590
1591     case THUNK_2_0:
1592     case FUN_2_0:
1593       scavenge_srt(info);
1594     case CONSTR_2_0:
1595       ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1596       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1597       p += sizeofW(StgHeader) + 2;
1598       break;
1599
1600     case THUNK_1_0:
1601       scavenge_srt(info);
1602       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1603       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1604       break;
1605
1606     case FUN_1_0:
1607       scavenge_srt(info);
1608     case CONSTR_1_0:
1609       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1610       p += sizeofW(StgHeader) + 1;
1611       break;
1612
1613     case THUNK_0_1:
1614       scavenge_srt(info);
1615       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1616       break;
1617
1618     case FUN_0_1:
1619       scavenge_srt(info);
1620     case CONSTR_0_1:
1621       p += sizeofW(StgHeader) + 1;
1622       break;
1623
1624     case THUNK_0_2:
1625     case FUN_0_2:
1626       scavenge_srt(info);
1627     case CONSTR_0_2:
1628       p += sizeofW(StgHeader) + 2;
1629       break;
1630
1631     case THUNK_1_1:
1632     case FUN_1_1:
1633       scavenge_srt(info);
1634     case CONSTR_1_1:
1635       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1636       p += sizeofW(StgHeader) + 2;
1637       break;
1638
1639     case FUN:
1640     case THUNK:
1641       scavenge_srt(info);
1642       /* fall through */
1643
1644     case CONSTR:
1645     case WEAK:
1646     case FOREIGN:
1647     case STABLE_NAME:
1648       {
1649         StgPtr end;
1650
1651         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1652         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1653           (StgClosure *)*p = evacuate((StgClosure *)*p);
1654         }
1655         p += info->layout.payload.nptrs;
1656         break;
1657       }
1658
1659     case IND_PERM:
1660       if (step->gen->no != 0) {
1661         SET_INFO(((StgClosure *)p), &IND_OLDGEN_PERM_info);
1662       }
1663       /* fall through */
1664     case IND_OLDGEN_PERM:
1665       ((StgIndOldGen *)p)->indirectee =
1666         evacuate(((StgIndOldGen *)p)->indirectee);
1667       if (failed_to_evac) {
1668         failed_to_evac = rtsFalse;
1669         recordOldToNewPtrs((StgMutClosure *)p);
1670       }
1671       p += sizeofW(StgIndOldGen);
1672       break;
1673
1674     case CAF_UNENTERED:
1675       {
1676         StgCAF *caf = (StgCAF *)p;
1677
1678         caf->body = evacuate(caf->body);
1679         if (failed_to_evac) {
1680           failed_to_evac = rtsFalse;
1681           recordOldToNewPtrs((StgMutClosure *)p);
1682         } else {
1683           caf->mut_link = NULL;
1684         }
1685         p += sizeofW(StgCAF);
1686         break;
1687       }
1688
1689     case CAF_ENTERED:
1690       {
1691         StgCAF *caf = (StgCAF *)p;
1692
1693         caf->body = evacuate(caf->body);
1694         caf->value = evacuate(caf->value);
1695         if (failed_to_evac) {
1696           failed_to_evac = rtsFalse;
1697           recordOldToNewPtrs((StgMutClosure *)p);
1698         } else {
1699           caf->mut_link = NULL;
1700         }
1701         p += sizeofW(StgCAF);
1702         break;
1703       }
1704
1705     case MUT_VAR:
1706       /* ignore MUT_CONSs */
1707       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1708         evac_gen = 0;
1709         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1710         evac_gen = saved_evac_gen;
1711       }
1712       p += sizeofW(StgMutVar);
1713       break;
1714
1715     case CAF_BLACKHOLE:
1716     case SE_CAF_BLACKHOLE:
1717     case SE_BLACKHOLE:
1718     case BLACKHOLE:
1719         p += BLACKHOLE_sizeW();
1720         break;
1721
1722     case BLACKHOLE_BQ:
1723       {
1724         StgBlockingQueue *bh = (StgBlockingQueue *)p;
1725         (StgClosure *)bh->blocking_queue =
1726           evacuate((StgClosure *)bh->blocking_queue);
1727         if (failed_to_evac) {
1728           failed_to_evac = rtsFalse;
1729           recordMutable((StgMutClosure *)bh);
1730         }
1731         p += BLACKHOLE_sizeW();
1732         break;
1733       }
1734
1735     case THUNK_SELECTOR:
1736       {
1737         StgSelector *s = (StgSelector *)p;
1738         s->selectee = evacuate(s->selectee);
1739         p += THUNK_SELECTOR_sizeW();
1740         break;
1741       }
1742
1743     case IND:
1744     case IND_OLDGEN:
1745       barf("scavenge:IND???\n");
1746
1747     case CONSTR_INTLIKE:
1748     case CONSTR_CHARLIKE:
1749     case CONSTR_STATIC:
1750     case CONSTR_NOCAF_STATIC:
1751     case THUNK_STATIC:
1752     case FUN_STATIC:
1753     case IND_STATIC:
1754       /* Shouldn't see a static object here. */
1755       barf("scavenge: STATIC object\n");
1756
1757     case RET_BCO:
1758     case RET_SMALL:
1759     case RET_VEC_SMALL:
1760     case RET_BIG:
1761     case RET_VEC_BIG:
1762     case RET_DYN:
1763     case UPDATE_FRAME:
1764     case STOP_FRAME:
1765     case CATCH_FRAME:
1766     case SEQ_FRAME:
1767       /* Shouldn't see stack frames here. */
1768       barf("scavenge: stack frame\n");
1769
1770     case AP_UPD: /* same as PAPs */
1771     case PAP:
1772       /* Treat a PAP just like a section of stack, not forgetting to
1773        * evacuate the function pointer too...
1774        */
1775       {
1776         StgPAP* pap = stgCast(StgPAP*,p);
1777
1778         pap->fun = evacuate(pap->fun);
1779         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1780         p += pap_sizeW(pap);
1781         break;
1782       }
1783
1784     case ARR_WORDS:
1785       /* nothing to follow */
1786       p += arr_words_sizeW(stgCast(StgArrWords*,p));
1787       break;
1788
1789     case MUT_ARR_PTRS:
1790       /* follow everything */
1791       {
1792         StgPtr next;
1793
1794         evac_gen = 0;           /* repeatedly mutable */
1795         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1796         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1797           (StgClosure *)*p = evacuate((StgClosure *)*p);
1798         }
1799         evac_gen = saved_evac_gen;
1800         break;
1801       }
1802
1803     case MUT_ARR_PTRS_FROZEN:
1804       /* follow everything */
1805       {
1806         StgPtr start = p, next;
1807
1808         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1809         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1810           (StgClosure *)*p = evacuate((StgClosure *)*p);
1811         }
1812         if (failed_to_evac) {
1813           /* we can do this easier... */
1814           recordMutable((StgMutClosure *)start);
1815           failed_to_evac = rtsFalse;
1816         }
1817         break;
1818       }
1819
1820     case TSO:
1821       {
1822         StgTSO *tso;
1823
1824         tso = (StgTSO *)p;
1825         evac_gen = 0;
1826         /* chase the link field for any TSOs on the same queue */
1827         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1828         if (   tso->why_blocked == BlockedOnMVar
1829             || tso->why_blocked == BlockedOnBlackHole) {
1830           tso->block_info.closure = evacuate(tso->block_info.closure);
1831         }
1832         /* scavenge this thread's stack */
1833         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1834         evac_gen = saved_evac_gen;
1835         p += tso_sizeW(tso);
1836         break;
1837       }
1838
1839     case BLOCKED_FETCH:
1840     case FETCH_ME:
1841     case EVACUATED:
1842       barf("scavenge: unimplemented/strange closure type\n");
1843
1844     default:
1845       barf("scavenge");
1846     }
1847
1848     /* If we didn't manage to promote all the objects pointed to by
1849      * the current object, then we have to designate this object as
1850      * mutable (because it contains old-to-new generation pointers).
1851      */
1852     if (failed_to_evac) {
1853       mkMutCons((StgClosure *)q, &generations[evac_gen]);
1854       failed_to_evac = rtsFalse;
1855     }
1856   }
1857
1858   step->scan_bd = bd;
1859   step->scan = p;
1860 }
1861
1862 /* -----------------------------------------------------------------------------
1863    Scavenge one object.
1864
1865    This is used for objects that are temporarily marked as mutable
1866    because they contain old-to-new generation pointers.  Only certain
1867    objects can have this property.
1868    -------------------------------------------------------------------------- */
1869 static rtsBool
1870 scavenge_one(StgClosure *p)
1871 {
1872   const StgInfoTable *info;
1873   rtsBool no_luck;
1874
1875   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1876                || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1877
1878   info = get_itbl(p);
1879
1880   switch (info -> type) {
1881
1882   case FUN:
1883   case FUN_1_0:                 /* hardly worth specialising these guys */
1884   case FUN_0_1:
1885   case FUN_1_1:
1886   case FUN_0_2:
1887   case FUN_2_0:
1888   case THUNK:
1889   case THUNK_1_0:
1890   case THUNK_0_1:
1891   case THUNK_1_1:
1892   case THUNK_0_2:
1893   case THUNK_2_0:
1894   case CONSTR:
1895   case CONSTR_1_0:
1896   case CONSTR_0_1:
1897   case CONSTR_1_1:
1898   case CONSTR_0_2:
1899   case CONSTR_2_0:
1900   case WEAK:
1901   case FOREIGN:
1902   case IND_PERM:
1903   case IND_OLDGEN_PERM:
1904   case CAF_UNENTERED:
1905     {
1906       StgPtr q, end;
1907
1908       end = (P_)p->payload + info->layout.payload.ptrs;
1909       for (q = (P_)p->payload; q < end; q++) {
1910         (StgClosure *)*q = evacuate((StgClosure *)*q);
1911       }
1912       break;
1913     }
1914
1915   case CAF_BLACKHOLE:
1916   case SE_CAF_BLACKHOLE:
1917   case SE_BLACKHOLE:
1918   case BLACKHOLE:
1919       break;
1920
1921   case THUNK_SELECTOR:
1922     {
1923       StgSelector *s = (StgSelector *)p;
1924       s->selectee = evacuate(s->selectee);
1925       break;
1926     }
1927
1928   case AP_UPD: /* same as PAPs */
1929   case PAP:
1930     /* Treat a PAP just like a section of stack, not forgetting to
1931      * evacuate the function pointer too...
1932      */
1933     {
1934       StgPAP* pap = (StgPAP *)p;
1935
1936       pap->fun = evacuate(pap->fun);
1937       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1938       break;
1939     }
1940
1941   case IND_OLDGEN:
1942     /* This might happen if for instance a MUT_CONS was pointing to a
1943      * THUNK which has since been updated.  The IND_OLDGEN will
1944      * be on the mutable list anyway, so we don't need to do anything
1945      * here.
1946      */
1947     break;
1948
1949   default:
1950     barf("scavenge_one: strange object");
1951   }
1952
1953   no_luck = failed_to_evac;
1954   failed_to_evac = rtsFalse;
1955   return (no_luck);
1956 }
1957
1958
1959 /* -----------------------------------------------------------------------------
1960    Scavenging mutable lists.
1961
1962    We treat the mutable list of each generation > N (i.e. all the
1963    generations older than the one being collected) as roots.  We also
1964    remove non-mutable objects from the mutable list at this point.
1965    -------------------------------------------------------------------------- */
1966
1967 static void
1968 scavenge_mut_once_list(generation *gen)
1969 {
1970   const StgInfoTable *info;
1971   StgMutClosure *p, *next, *new_list;
1972
1973   p = gen->mut_once_list;
1974   new_list = END_MUT_LIST;
1975   next = p->mut_link;
1976
1977   evac_gen = gen->no;
1978   failed_to_evac = rtsFalse;
1979
1980   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1981
1982     /* make sure the info pointer is into text space */
1983     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1984                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1985
1986     info = get_itbl(p);
1987     switch(info->type) {
1988
1989     case IND_OLDGEN:
1990     case IND_OLDGEN_PERM:
1991     case IND_STATIC:
1992       /* Try to pull the indirectee into this generation, so we can
1993        * remove the indirection from the mutable list.
1994        */
1995       ((StgIndOldGen *)p)->indirectee =
1996         evacuate(((StgIndOldGen *)p)->indirectee);
1997
1998 #if 0
1999       /* Debugging code to print out the size of the thing we just
2000        * promoted
2001        */
2002       {
2003         StgPtr start = gen->steps[0].scan;
2004         bdescr *start_bd = gen->steps[0].scan_bd;
2005         nat size = 0;
2006         scavenge(&gen->steps[0]);
2007         if (start_bd != gen->steps[0].scan_bd) {
2008           size += (P_)BLOCK_ROUND_UP(start) - start;
2009           start_bd = start_bd->link;
2010           while (start_bd != gen->steps[0].scan_bd) {
2011             size += BLOCK_SIZE_W;
2012             start_bd = start_bd->link;
2013           }
2014           size += gen->steps[0].scan -
2015             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
2016         } else {
2017           size = gen->steps[0].scan - start;
2018         }
2019         fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
2020       }
2021 #endif
2022
2023       /* failed_to_evac might happen if we've got more than two
2024        * generations, we're collecting only generation 0, the
2025        * indirection resides in generation 2 and the indirectee is
2026        * in generation 1.
2027        */
2028       if (failed_to_evac) {
2029         failed_to_evac = rtsFalse;
2030         p->mut_link = new_list;
2031         new_list = p;
2032       } else {
2033         /* the mut_link field of an IND_STATIC is overloaded as the
2034          * static link field too (it just so happens that we don't need
2035          * both at the same time), so we need to NULL it out when
2036          * removing this object from the mutable list because the static
2037          * link fields are all assumed to be NULL before doing a major
2038          * collection.
2039          */
2040         p->mut_link = NULL;
2041       }
2042       continue;
2043
2044     case MUT_VAR:
2045       /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
2046        * it from the mutable list if possible by promoting whatever it
2047        * points to.
2048        */
2049       ASSERT(p->header.info == &MUT_CONS_info);
2050       if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
2051         /* didn't manage to promote everything, so put the
2052          * MUT_CONS back on the list.
2053          */
2054         p->mut_link = new_list;
2055         new_list = p;
2056       }
2057       continue;
2058
2059     case CAF_ENTERED:
2060       {
2061         StgCAF *caf = (StgCAF *)p;
2062         caf->body  = evacuate(caf->body);
2063         caf->value = evacuate(caf->value);
2064         if (failed_to_evac) {
2065           failed_to_evac = rtsFalse;
2066           p->mut_link = new_list;
2067           new_list = p;
2068         } else {
2069           p->mut_link = NULL;
2070         }
2071       }
2072       continue;
2073
2074     case CAF_UNENTERED:
2075       {
2076         StgCAF *caf = (StgCAF *)p;
2077         caf->body  = evacuate(caf->body);
2078         if (failed_to_evac) {
2079           failed_to_evac = rtsFalse;
2080           p->mut_link = new_list;
2081           new_list = p;
2082         } else {
2083           p->mut_link = NULL;
2084         }
2085       }
2086       continue;
2087
2088     default:
2089       /* shouldn't have anything else on the mutables list */
2090       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
2091     }
2092   }
2093
2094   gen->mut_once_list = new_list;
2095 }
2096
2097
2098 static void
2099 scavenge_mutable_list(generation *gen)
2100 {
2101   const StgInfoTable *info;
2102   StgMutClosure *p, *next;
2103
2104   p = gen->saved_mut_list;
2105   next = p->mut_link;
2106
2107   evac_gen = 0;
2108   failed_to_evac = rtsFalse;
2109
2110   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2111
2112     /* make sure the info pointer is into text space */
2113     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2114                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2115
2116     info = get_itbl(p);
2117     switch(info->type) {
2118
2119     case MUT_ARR_PTRS_FROZEN:
2120       /* remove this guy from the mutable list, but follow the ptrs
2121        * anyway (and make sure they get promoted to this gen).
2122        */
2123       {
2124         StgPtr end, q;
2125
2126         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2127         evac_gen = gen->no;
2128         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2129           (StgClosure *)*q = evacuate((StgClosure *)*q);
2130         }
2131         evac_gen = 0;
2132
2133         if (failed_to_evac) {
2134           failed_to_evac = rtsFalse;
2135           p->mut_link = gen->mut_list;
2136           gen->mut_list = p;
2137         }
2138         continue;
2139       }
2140
2141     case MUT_ARR_PTRS:
2142       /* follow everything */
2143       p->mut_link = gen->mut_list;
2144       gen->mut_list = p;
2145       {
2146         StgPtr end, q;
2147
2148         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2149         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2150           (StgClosure *)*q = evacuate((StgClosure *)*q);
2151         }
2152         continue;
2153       }
2154
2155     case MUT_VAR:
2156       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2157        * it from the mutable list if possible by promoting whatever it
2158        * points to.
2159        */
2160       ASSERT(p->header.info != &MUT_CONS_info);
2161       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2162       p->mut_link = gen->mut_list;
2163       gen->mut_list = p;
2164       continue;
2165
2166     case MVAR:
2167       {
2168         StgMVar *mvar = (StgMVar *)p;
2169         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2170         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2171         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2172         p->mut_link = gen->mut_list;
2173         gen->mut_list = p;
2174         continue;
2175       }
2176
2177     case TSO:
2178       {
2179         StgTSO *tso = (StgTSO *)p;
2180
2181         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2182         if (   tso->why_blocked == BlockedOnMVar
2183             || tso->why_blocked == BlockedOnBlackHole) {
2184           tso->block_info.closure = evacuate(tso->block_info.closure);
2185         }
2186         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2187
2188         /* Don't take this TSO off the mutable list - it might still
2189          * point to some younger objects (because we set evac_gen to 0
2190          * above).
2191          */
2192         tso->mut_link = gen->mut_list;
2193         gen->mut_list = (StgMutClosure *)tso;
2194         continue;
2195       }
2196
2197     case BLACKHOLE_BQ:
2198       {
2199         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2200         (StgClosure *)bh->blocking_queue =
2201           evacuate((StgClosure *)bh->blocking_queue);
2202         p->mut_link = gen->mut_list;
2203         gen->mut_list = p;
2204         continue;
2205       }
2206
2207       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
2208        */
2209     case IND_OLDGEN:
2210     case IND_OLDGEN_PERM:
2211       /* Try to pull the indirectee into this generation, so we can
2212        * remove the indirection from the mutable list.
2213        */
2214       evac_gen = gen->no;
2215       ((StgIndOldGen *)p)->indirectee =
2216         evacuate(((StgIndOldGen *)p)->indirectee);
2217       evac_gen = 0;
2218
2219       if (failed_to_evac) {
2220         failed_to_evac = rtsFalse;
2221         p->mut_link = gen->mut_once_list;
2222         gen->mut_once_list = p;
2223       } else {
2224         p->mut_link = NULL;
2225       }
2226       continue;
2227
2228     default:
2229       /* shouldn't have anything else on the mutables list */
2230       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
2231     }
2232   }
2233 }
2234
2235 static void
2236 scavenge_static(void)
2237 {
2238   StgClosure* p = static_objects;
2239   const StgInfoTable *info;
2240
2241   /* Always evacuate straight to the oldest generation for static
2242    * objects */
2243   evac_gen = oldest_gen->no;
2244
2245   /* keep going until we've scavenged all the objects on the linked
2246      list... */
2247   while (p != END_OF_STATIC_LIST) {
2248
2249     info = get_itbl(p);
2250
2251     /* make sure the info pointer is into text space */
2252     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2253                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2254
2255     /* Take this object *off* the static_objects list,
2256      * and put it on the scavenged_static_objects list.
2257      */
2258     static_objects = STATIC_LINK(info,p);
2259     STATIC_LINK(info,p) = scavenged_static_objects;
2260     scavenged_static_objects = p;
2261
2262     switch (info -> type) {
2263
2264     case IND_STATIC:
2265       {
2266         StgInd *ind = (StgInd *)p;
2267         ind->indirectee = evacuate(ind->indirectee);
2268
2269         /* might fail to evacuate it, in which case we have to pop it
2270          * back on the mutable list (and take it off the
2271          * scavenged_static list because the static link and mut link
2272          * pointers are one and the same).
2273          */
2274         if (failed_to_evac) {
2275           failed_to_evac = rtsFalse;
2276           scavenged_static_objects = STATIC_LINK(info,p);
2277           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2278           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2279         }
2280         break;
2281       }
2282
2283     case THUNK_STATIC:
2284     case FUN_STATIC:
2285       scavenge_srt(info);
2286       /* fall through */
2287
2288     case CONSTR_STATIC:
2289       {
2290         StgPtr q, next;
2291
2292         next = (P_)p->payload + info->layout.payload.ptrs;
2293         /* evacuate the pointers */
2294         for (q = (P_)p->payload; q < next; q++) {
2295           (StgClosure *)*q = evacuate((StgClosure *)*q);
2296         }
2297         break;
2298       }
2299
2300     default:
2301       barf("scavenge_static");
2302     }
2303
2304     ASSERT(failed_to_evac == rtsFalse);
2305
2306     /* get the next static object from the list.  Remeber, there might
2307      * be more stuff on this list now that we've done some evacuating!
2308      * (static_objects is a global)
2309      */
2310     p = static_objects;
2311   }
2312 }
2313
2314 /* -----------------------------------------------------------------------------
2315    scavenge_stack walks over a section of stack and evacuates all the
2316    objects pointed to by it.  We can use the same code for walking
2317    PAPs, since these are just sections of copied stack.
2318    -------------------------------------------------------------------------- */
2319
2320 static void
2321 scavenge_stack(StgPtr p, StgPtr stack_end)
2322 {
2323   StgPtr q;
2324   const StgInfoTable* info;
2325   StgWord32 bitmap;
2326
2327   /*
2328    * Each time around this loop, we are looking at a chunk of stack
2329    * that starts with either a pending argument section or an
2330    * activation record.
2331    */
2332
2333   while (p < stack_end) {
2334     q = *(P_ *)p;
2335
2336     /* If we've got a tag, skip over that many words on the stack */
2337     if (IS_ARG_TAG((W_)q)) {
2338       p += ARG_SIZE(q);
2339       p++; continue;
2340     }
2341
2342     /* Is q a pointer to a closure?
2343      */
2344     if (! LOOKS_LIKE_GHC_INFO(q) ) {
2345 #ifdef DEBUG
2346       if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  /* Is it a static closure? */
2347         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2348       }
2349       /* otherwise, must be a pointer into the allocation space. */
2350 #endif
2351
2352       (StgClosure *)*p = evacuate((StgClosure *)q);
2353       p++;
2354       continue;
2355     }
2356
2357     /*
2358      * Otherwise, q must be the info pointer of an activation
2359      * record.  All activation records have 'bitmap' style layout
2360      * info.
2361      */
2362     info  = get_itbl((StgClosure *)p);
2363
2364     switch (info->type) {
2365
2366       /* Dynamic bitmap: the mask is stored on the stack */
2367     case RET_DYN:
2368       bitmap = ((StgRetDyn *)p)->liveness;
2369       p      = (P_)&((StgRetDyn *)p)->payload[0];
2370       goto small_bitmap;
2371
2372       /* probably a slow-entry point return address: */
2373     case FUN:
2374     case FUN_STATIC:
2375       p++;
2376       goto follow_srt;
2377
2378       /* Specialised code for update frames, since they're so common.
2379        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2380        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2381        */
2382     case UPDATE_FRAME:
2383       {
2384         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2385         StgClosure *to;
2386         nat type = get_itbl(frame->updatee)->type;
2387
2388         p += sizeofW(StgUpdateFrame);
2389         if (type == EVACUATED) {
2390           frame->updatee = evacuate(frame->updatee);
2391           continue;
2392         } else {
2393           bdescr *bd = Bdescr((P_)frame->updatee);
2394           step *step;
2395           if (bd->gen->no > N) {
2396             if (bd->gen->no < evac_gen) {
2397               failed_to_evac = rtsTrue;
2398             }
2399             continue;
2400           }
2401
2402           /* Don't promote blackholes */
2403           step = bd->step;
2404           if (!(step->gen->no == 0 &&
2405                 step->no != 0 &&
2406                 step->no == step->gen->n_steps-1)) {
2407             step = step->to;
2408           }
2409
2410           switch (type) {
2411           case BLACKHOLE:
2412           case CAF_BLACKHOLE:
2413             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2414                           sizeofW(StgHeader), step);
2415             frame->updatee = to;
2416             continue;
2417           case BLACKHOLE_BQ:
2418             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2419             frame->updatee = to;
2420             recordMutable((StgMutClosure *)to);
2421             continue;
2422           default:
2423             /* will never be SE_{,CAF_}BLACKHOLE, since we
2424                don't push an update frame for single-entry thunks.  KSW 1999-01. */
2425             barf("scavenge_stack: UPDATE_FRAME updatee");
2426           }
2427         }
2428       }
2429
2430       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2431     case RET_BCO:
2432     case RET_SMALL:
2433     case RET_VEC_SMALL:
2434     case STOP_FRAME:
2435     case CATCH_FRAME:
2436     case SEQ_FRAME:
2437       bitmap = info->layout.bitmap;
2438       p++;
2439     small_bitmap:
2440       while (bitmap != 0) {
2441         if ((bitmap & 1) == 0) {
2442           (StgClosure *)*p = evacuate((StgClosure *)*p);
2443         }
2444         p++;
2445         bitmap = bitmap >> 1;
2446       }
2447
2448     follow_srt:
2449       scavenge_srt(info);
2450       continue;
2451
2452       /* large bitmap (> 32 entries) */
2453     case RET_BIG:
2454     case RET_VEC_BIG:
2455       {
2456         StgPtr q;
2457         StgLargeBitmap *large_bitmap;
2458         nat i;
2459
2460         large_bitmap = info->layout.large_bitmap;
2461         p++;
2462
2463         for (i=0; i<large_bitmap->size; i++) {
2464           bitmap = large_bitmap->bitmap[i];
2465           q = p + sizeof(W_) * 8;
2466           while (bitmap != 0) {
2467             if ((bitmap & 1) == 0) {
2468               (StgClosure *)*p = evacuate((StgClosure *)*p);
2469             }
2470             p++;
2471             bitmap = bitmap >> 1;
2472           }
2473           if (i+1 < large_bitmap->size) {
2474             while (p < q) {
2475               (StgClosure *)*p = evacuate((StgClosure *)*p);
2476               p++;
2477             }
2478           }
2479         }
2480
2481         /* and don't forget to follow the SRT */
2482         goto follow_srt;
2483       }
2484
2485     default:
2486       barf("scavenge_stack: weird activation record found on stack.\n");
2487     }
2488   }
2489 }
2490
2491 /*-----------------------------------------------------------------------------
2492   scavenge the large object list.
2493
2494   evac_gen set by caller; similar games played with evac_gen as with
2495   scavenge() - see comment at the top of scavenge().  Most large
2496   objects are (repeatedly) mutable, so most of the time evac_gen will
2497   be zero.
2498   --------------------------------------------------------------------------- */
2499
2500 static void
2501 scavenge_large(step *step)
2502 {
2503   bdescr *bd;
2504   StgPtr p;
2505   const StgInfoTable* info;
2506   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2507
2508   evac_gen = 0;                 /* most objects are mutable */
2509   bd = step->new_large_objects;
2510
2511   for (; bd != NULL; bd = step->new_large_objects) {
2512
2513     /* take this object *off* the large objects list and put it on
2514      * the scavenged large objects list.  This is so that we can
2515      * treat new_large_objects as a stack and push new objects on
2516      * the front when evacuating.
2517      */
2518     step->new_large_objects = bd->link;
2519     dbl_link_onto(bd, &step->scavenged_large_objects);
2520
2521     p = bd->start;
2522     info  = get_itbl(stgCast(StgClosure*,p));
2523
2524     switch (info->type) {
2525
2526     /* only certain objects can be "large"... */
2527
2528     case ARR_WORDS:
2529       /* nothing to follow */
2530       continue;
2531
2532     case MUT_ARR_PTRS:
2533       /* follow everything */
2534       {
2535         StgPtr next;
2536
2537         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2538         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2539           (StgClosure *)*p = evacuate((StgClosure *)*p);
2540         }
2541         continue;
2542       }
2543
2544     case MUT_ARR_PTRS_FROZEN:
2545       /* follow everything */
2546       {
2547         StgPtr start = p, next;
2548
2549         evac_gen = saved_evac_gen; /* not really mutable */
2550         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2551         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2552           (StgClosure *)*p = evacuate((StgClosure *)*p);
2553         }
2554         evac_gen = 0;
2555         if (failed_to_evac) {
2556           recordMutable((StgMutClosure *)start);
2557         }
2558         continue;
2559       }
2560
2561     case BCO:
2562       {
2563         StgBCO* bco = stgCast(StgBCO*,p);
2564         nat i;
2565         evac_gen = saved_evac_gen;
2566         for (i = 0; i < bco->n_ptrs; i++) {
2567           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2568         }
2569         evac_gen = 0;
2570         continue;
2571       }
2572
2573     case TSO:
2574       {
2575         StgTSO *tso;
2576
2577         tso = (StgTSO *)p;
2578         /* chase the link field for any TSOs on the same queue */
2579         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2580         if (   tso->why_blocked == BlockedOnMVar
2581             || tso->why_blocked == BlockedOnBlackHole) {
2582           tso->block_info.closure = evacuate(tso->block_info.closure);
2583         }
2584         /* scavenge this thread's stack */
2585         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2586         continue;
2587       }
2588
2589     default:
2590       barf("scavenge_large: unknown/strange object");
2591     }
2592   }
2593 }
2594
2595 static void
2596 zero_static_object_list(StgClosure* first_static)
2597 {
2598   StgClosure* p;
2599   StgClosure* link;
2600   const StgInfoTable *info;
2601
2602   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2603     info = get_itbl(p);
2604     link = STATIC_LINK(info, p);
2605     STATIC_LINK(info,p) = NULL;
2606   }
2607 }
2608
2609 /* This function is only needed because we share the mutable link
2610  * field with the static link field in an IND_STATIC, so we have to
2611  * zero the mut_link field before doing a major GC, which needs the
2612  * static link field.
2613  *
2614  * It doesn't do any harm to zero all the mutable link fields on the
2615  * mutable list.
2616  */
2617 static void
2618 zero_mutable_list( StgMutClosure *first )
2619 {
2620   StgMutClosure *next, *c;
2621
2622   for (c = first; c != END_MUT_LIST; c = next) {
2623     next = c->mut_link;
2624     c->mut_link = NULL;
2625   }
2626 }
2627
2628 /* -----------------------------------------------------------------------------
2629    Reverting CAFs
2630    -------------------------------------------------------------------------- */
2631
2632 void RevertCAFs(void)
2633 {
2634   while (enteredCAFs != END_CAF_LIST) {
2635     StgCAF* caf = enteredCAFs;
2636
2637     enteredCAFs = caf->link;
2638     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2639     SET_INFO(caf,&CAF_UNENTERED_info);
2640     caf->value = stgCast(StgClosure*,0xdeadbeef);
2641     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2642   }
2643   enteredCAFs = END_CAF_LIST;
2644 }
2645
2646 void revert_dead_CAFs(void)
2647 {
2648     StgCAF* caf = enteredCAFs;
2649     enteredCAFs = END_CAF_LIST;
2650     while (caf != END_CAF_LIST) {
2651         StgCAF *next, *new;
2652         next = caf->link;
2653         new = (StgCAF*)isAlive((StgClosure*)caf);
2654         if (new) {
2655            new->link = enteredCAFs;
2656            enteredCAFs = new;
2657         } else {
2658            /* ASSERT(0); */
2659            SET_INFO(caf,&CAF_UNENTERED_info);
2660            caf->value = (StgClosure*)0xdeadbeef;
2661            caf->link  = (StgCAF*)0xdeadbeef;
2662         }
2663         caf = next;
2664     }
2665 }
2666
2667 /* -----------------------------------------------------------------------------
2668    Sanity code for CAF garbage collection.
2669
2670    With DEBUG turned on, we manage a CAF list in addition to the SRT
2671    mechanism.  After GC, we run down the CAF list and blackhole any
2672    CAFs which have been garbage collected.  This means we get an error
2673    whenever the program tries to enter a garbage collected CAF.
2674
2675    Any garbage collected CAFs are taken off the CAF list at the same
2676    time.
2677    -------------------------------------------------------------------------- */
2678
2679 #ifdef DEBUG
2680 static void
2681 gcCAFs(void)
2682 {
2683   StgClosure*  p;
2684   StgClosure** pp;
2685   const StgInfoTable *info;
2686   nat i;
2687
2688   i = 0;
2689   p = caf_list;
2690   pp = &caf_list;
2691
2692   while (p != NULL) {
2693
2694     info = get_itbl(p);
2695
2696     ASSERT(info->type == IND_STATIC);
2697
2698     if (STATIC_LINK(info,p) == NULL) {
2699       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2700       /* black hole it */
2701       SET_INFO(p,&BLACKHOLE_info);
2702       p = STATIC_LINK2(info,p);
2703       *pp = p;
2704     }
2705     else {
2706       pp = &STATIC_LINK2(info,p);
2707       p = *pp;
2708       i++;
2709     }
2710
2711   }
2712
2713   /*  fprintf(stderr, "%d CAFs live\n", i); */
2714 }
2715 #endif
2716
2717 /* -----------------------------------------------------------------------------
2718    Lazy black holing.
2719
2720    Whenever a thread returns to the scheduler after possibly doing
2721    some work, we have to run down the stack and black-hole all the
2722    closures referred to by update frames.
2723    -------------------------------------------------------------------------- */
2724
2725 static void
2726 threadLazyBlackHole(StgTSO *tso)
2727 {
2728   StgUpdateFrame *update_frame;
2729   StgBlockingQueue *bh;
2730   StgPtr stack_end;
2731
2732   stack_end = &tso->stack[tso->stack_size];
2733   update_frame = tso->su;
2734
2735   while (1) {
2736     switch (get_itbl(update_frame)->type) {
2737
2738     case CATCH_FRAME:
2739       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2740       break;
2741
2742     case UPDATE_FRAME:
2743       bh = (StgBlockingQueue *)update_frame->updatee;
2744
2745       /* if the thunk is already blackholed, it means we've also
2746        * already blackholed the rest of the thunks on this stack,
2747        * so we can stop early.
2748        *
2749        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2750        * don't interfere with this optimisation.
2751        */
2752       if (bh->header.info == &BLACKHOLE_info) {
2753         return;
2754       }
2755
2756       if (bh->header.info != &BLACKHOLE_BQ_info &&
2757           bh->header.info != &CAF_BLACKHOLE_info) {
2758 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
2759         fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
2760 #endif
2761         SET_INFO(bh,&BLACKHOLE_info);
2762       }
2763
2764       update_frame = update_frame->link;
2765       break;
2766
2767     case SEQ_FRAME:
2768       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2769       break;
2770
2771     case STOP_FRAME:
2772       return;
2773     default:
2774       barf("threadPaused");
2775     }
2776   }
2777 }
2778
2779 /* -----------------------------------------------------------------------------
2780  * Stack squeezing
2781  *
2782  * Code largely pinched from old RTS, then hacked to bits.  We also do
2783  * lazy black holing here.
2784  *
2785  * -------------------------------------------------------------------------- */
2786
2787 static void
2788 threadSqueezeStack(StgTSO *tso)
2789 {
2790   lnat displacement = 0;
2791   StgUpdateFrame *frame;
2792   StgUpdateFrame *next_frame;                   /* Temporally next */
2793   StgUpdateFrame *prev_frame;                   /* Temporally previous */
2794   StgPtr bottom;
2795   rtsBool prev_was_update_frame;
2796
2797   bottom = &(tso->stack[tso->stack_size]);
2798   frame  = tso->su;
2799
2800   /* There must be at least one frame, namely the STOP_FRAME.
2801    */
2802   ASSERT((P_)frame < bottom);
2803
2804   /* Walk down the stack, reversing the links between frames so that
2805    * we can walk back up as we squeeze from the bottom.  Note that
2806    * next_frame and prev_frame refer to next and previous as they were
2807    * added to the stack, rather than the way we see them in this
2808    * walk. (It makes the next loop less confusing.)
2809    *
2810    * Stop if we find an update frame pointing to a black hole
2811    * (see comment in threadLazyBlackHole()).
2812    */
2813
2814   next_frame = NULL;
2815   /* bottom - sizeof(StgStopFrame) is the STOP_FRAME */
2816   while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
2817     prev_frame = frame->link;
2818     frame->link = next_frame;
2819     next_frame = frame;
2820     frame = prev_frame;
2821     if (get_itbl(frame)->type == UPDATE_FRAME
2822         && frame->updatee->header.info == &BLACKHOLE_info) {
2823         break;
2824     }
2825   }
2826
2827   /* Now, we're at the bottom.  Frame points to the lowest update
2828    * frame on the stack, and its link actually points to the frame
2829    * above. We have to walk back up the stack, squeezing out empty
2830    * update frames and turning the pointers back around on the way
2831    * back up.
2832    *
2833    * The bottom-most frame (the STOP_FRAME) has not been altered, and
2834    * we never want to eliminate it anyway.  Just walk one step up
2835    * before starting to squeeze. When you get to the topmost frame,
2836    * remember that there are still some words above it that might have
2837    * to be moved.
2838    */
2839
2840   prev_frame = frame;
2841   frame = next_frame;
2842
2843   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2844
2845   /*
2846    * Loop through all of the frames (everything except the very
2847    * bottom).  Things are complicated by the fact that we have
2848    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2849    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2850    */
2851   while (frame != NULL) {
2852     StgPtr sp;
2853     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2854     rtsBool is_update_frame;
2855
2856     next_frame = frame->link;
2857     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2858
2859     /* Check to see if
2860      *   1. both the previous and current frame are update frames
2861      *   2. the current frame is empty
2862      */
2863     if (prev_was_update_frame && is_update_frame &&
2864         (P_)prev_frame == frame_bottom + displacement) {
2865
2866       /* Now squeeze out the current frame */
2867       StgClosure *updatee_keep   = prev_frame->updatee;
2868       StgClosure *updatee_bypass = frame->updatee;
2869
2870 #if 0 /* DEBUG */
2871       fprintf(stderr, "squeezing frame at %p\n", frame);
2872 #endif
2873
2874       /* Deal with blocking queues.  If both updatees have blocked
2875        * threads, then we should merge the queues into the update
2876        * frame that we're keeping.
2877        *
2878        * Alternatively, we could just wake them up: they'll just go
2879        * straight to sleep on the proper blackhole!  This is less code
2880        * and probably less bug prone, although it's probably much
2881        * slower --SDM
2882        */
2883 #if 0 /* do it properly... */
2884 #  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
2885 #    error Unimplemented lazy BH warning.  (KSW 1999-01)
2886 #  endif
2887       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info
2888           || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
2889           ) {
2890         /* Sigh.  It has one.  Don't lose those threads! */
2891           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2892           /* Urgh.  Two queues.  Merge them. */
2893           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2894
2895           while (keep_tso->link != END_TSO_QUEUE) {
2896             keep_tso = keep_tso->link;
2897           }
2898           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2899
2900         } else {
2901           /* For simplicity, just swap the BQ for the BH */
2902           P_ temp = updatee_keep;
2903
2904           updatee_keep = updatee_bypass;
2905           updatee_bypass = temp;
2906
2907           /* Record the swap in the kept frame (below) */
2908           prev_frame->updatee = updatee_keep;
2909         }
2910       }
2911 #endif
2912
2913       TICK_UPD_SQUEEZED();
2914       /* wasn't there something about update squeezing and ticky to be
2915        * sorted out?  oh yes: we aren't counting each enter properly
2916        * in this case.  See the log somewhere.  KSW 1999-04-21
2917        */
2918       UPD_IND_NOLOCK(updatee_bypass, updatee_keep); /* this wakes the threads up */
2919
2920       sp = (P_)frame - 1;       /* sp = stuff to slide */
2921       displacement += sizeofW(StgUpdateFrame);
2922
2923     } else {
2924       /* No squeeze for this frame */
2925       sp = frame_bottom - 1;    /* Keep the current frame */
2926
2927       /* Do lazy black-holing.
2928        */
2929       if (is_update_frame) {
2930         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2931         if (bh->header.info != &BLACKHOLE_info &&
2932             bh->header.info != &BLACKHOLE_BQ_info &&
2933             bh->header.info != &CAF_BLACKHOLE_info) {
2934 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
2935           fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
2936 #endif
2937           SET_INFO(bh,&BLACKHOLE_info);
2938         }
2939       }
2940
2941       /* Fix the link in the current frame (should point to the frame below) */
2942       frame->link = prev_frame;
2943       prev_was_update_frame = is_update_frame;
2944     }
2945
2946     /* Now slide all words from sp up to the next frame */
2947
2948     if (displacement > 0) {
2949       P_ next_frame_bottom;
2950
2951       if (next_frame != NULL)
2952         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2953       else
2954         next_frame_bottom = tso->sp - 1;
2955
2956 #if 0 /* DEBUG */
2957       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2958               displacement);
2959 #endif
2960
2961       while (sp >= next_frame_bottom) {
2962         sp[displacement] = *sp;
2963         sp -= 1;
2964       }
2965     }
2966     (P_)prev_frame = (P_)frame + displacement;
2967     frame = next_frame;
2968   }
2969
2970   tso->sp += displacement;
2971   tso->su = prev_frame;
2972 }
2973
2974 /* -----------------------------------------------------------------------------
2975  * Pausing a thread
2976  *
2977  * We have to prepare for GC - this means doing lazy black holing
2978  * here.  We also take the opportunity to do stack squeezing if it's
2979  * turned on.
2980  * -------------------------------------------------------------------------- */
2981
2982 void
2983 threadPaused(StgTSO *tso)
2984 {
2985   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2986     threadSqueezeStack(tso);    /* does black holing too */
2987   else
2988     threadLazyBlackHole(tso);
2989 }