ghc/rts/GC.c

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