ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.61 1999/08/25 16:11:46 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 "DebugProf.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   CCCS = prev_CCS;
 697 #endif
 698
 699   /* check for memory leaks if sanity checking is on */
 700   IF_DEBUG(sanity, memInventory());
 701
 702   /* ok, GC over: tell the stats department what happened. */
 703   stat_endGC(allocated, collected, live, copied, N);
 704 }
 705
 706 /* -----------------------------------------------------------------------------
 707    Weak Pointers
 708
 709    traverse_weak_ptr_list is called possibly many times during garbage
 710    collection.  It returns a flag indicating whether it did any work
 711    (i.e. called evacuate on any live pointers).
 712
 713    Invariant: traverse_weak_ptr_list is called when the heap is in an
 714    idempotent state.  That means that there are no pending
 715    evacuate/scavenge operations.  This invariant helps the weak
 716    pointer code decide which weak pointers are dead - if there are no
 717    new live weak pointers, then all the currently unreachable ones are
 718    dead.
 719
 720    For generational GC: we just don't try to finalize weak pointers in
 721    older generations than the one we're collecting.  This could
 722    probably be optimised by keeping per-generation lists of weak
 723    pointers, but for a few weak pointers this scheme will work.
 724    -------------------------------------------------------------------------- */
 725
 726 static rtsBool
 727 traverse_weak_ptr_list(void)
 728 {
 729   StgWeak *w, **last_w, *next_w;
 730   StgClosure *new;
 731   rtsBool flag = rtsFalse;
 732
 733   if (weak_done) { return rtsFalse; }
 734
 735   /* doesn't matter where we evacuate values/finalizers to, since
 736    * these pointers are treated as roots (iff the keys are alive).
 737    */
 738   evac_gen = 0;
 739
 740   last_w = &old_weak_ptr_list;
 741   for (w = old_weak_ptr_list; w; w = next_w) {
 742
 743     /* First, this weak pointer might have been evacuated.  If so,
 744      * remove the forwarding pointer from the weak_ptr_list.
 745      */
 746     if (get_itbl(w)->type == EVACUATED) {
 747       w = (StgWeak *)((StgEvacuated *)w)->evacuee;
 748       *last_w = w;
 749     }
 750
 751     /* There might be a DEAD_WEAK on the list if finalizeWeak# was
 752      * called on a live weak pointer object.  Just remove it.
 753      */
 754     if (w->header.info == &DEAD_WEAK_info) {
 755       next_w = ((StgDeadWeak *)w)->link;
 756       *last_w = next_w;
 757       continue;
 758     }
 759
 760     ASSERT(get_itbl(w)->type == WEAK);
 761
 762     /* Now, check whether the key is reachable.
 763      */
 764     if ((new = isAlive(w->key))) {
 765       w->key = new;
 766       /* evacuate the value and finalizer */
 767       w->value = evacuate(w->value);
 768       w->finalizer = evacuate(w->finalizer);
 769       /* remove this weak ptr from the old_weak_ptr list */
 770       *last_w = w->link;
 771       /* and put it on the new weak ptr list */
 772       next_w  = w->link;
 773       w->link = weak_ptr_list;
 774       weak_ptr_list = w;
 775       flag = rtsTrue;
 776       IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
 777       continue;
 778     }
 779     else {
 780       last_w = &(w->link);
 781       next_w = w->link;
 782       continue;
 783     }
 784   }
 785
 786   /* If we didn't make any changes, then we can go round and kill all
 787    * the dead weak pointers.  The old_weak_ptr list is used as a list
 788    * of pending finalizers later on.
 789    */
 790   if (flag == rtsFalse) {
 791     cleanup_weak_ptr_list(&old_weak_ptr_list);
 792     for (w = old_weak_ptr_list; w; w = w->link) {
 793       w->finalizer = evacuate(w->finalizer);
 794     }
 795     weak_done = rtsTrue;
 796   }
 797
 798   return rtsTrue;
 799 }
 800
 801 /* -----------------------------------------------------------------------------
 802    After GC, the live weak pointer list may have forwarding pointers
 803    on it, because a weak pointer object was evacuated after being
 804    moved to the live weak pointer list.  We remove those forwarding
 805    pointers here.
 806
 807    Also, we don't consider weak pointer objects to be reachable, but
 808    we must nevertheless consider them to be "live" and retain them.
 809    Therefore any weak pointer objects which haven't as yet been
 810    evacuated need to be evacuated now.
 811    -------------------------------------------------------------------------- */
 812
 813 static void
 814 cleanup_weak_ptr_list ( StgWeak **list )
 815 {
 816   StgWeak *w, **last_w;
 817
 818   last_w = list;
 819   for (w = *list; w; w = w->link) {
 820
 821     if (get_itbl(w)->type == EVACUATED) {
 822       w = (StgWeak *)((StgEvacuated *)w)->evacuee;
 823       *last_w = w;
 824     }
 825
 826     if (Bdescr((P_)w)->evacuated == 0) {
 827       (StgClosure *)w = evacuate((StgClosure *)w);
 828       *last_w = w;
 829     }
 830     last_w = &(w->link);
 831   }
 832 }
 833
 834 /* -----------------------------------------------------------------------------
 835    isAlive determines whether the given closure is still alive (after
 836    a garbage collection) or not.  It returns the new address of the
 837    closure if it is alive, or NULL otherwise.
 838    -------------------------------------------------------------------------- */
 839
 840 StgClosure *
 841 isAlive(StgClosure *p)
 842 {
 843   const StgInfoTable *info;
 844
 845   while (1) {
 846
 847     info = get_itbl(p);
 848
 849     /* ToDo: for static closures, check the static link field.
 850      * Problem here is that we sometimes don't set the link field, eg.
 851      * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
 852      */
 853
 854     /* ignore closures in generations that we're not collecting. */
 855     if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
 856       return p;
 857     }
 858
 859     switch (info->type) {
 860
 861     case IND:
 862     case IND_STATIC:
 863     case IND_PERM:
 864     case IND_OLDGEN:            /* rely on compatible layout with StgInd */
 865     case IND_OLDGEN_PERM:
 866       /* follow indirections */
 867       p = ((StgInd *)p)->indirectee;
 868       continue;
 869
 870     case EVACUATED:
 871       /* alive! */
 872       return ((StgEvacuated *)p)->evacuee;
 873
 874     default:
 875       /* dead. */
 876       return NULL;
 877     }
 878   }
 879 }
 880
 881 StgClosure *
 882 MarkRoot(StgClosure *root)
 883 {
 884   return evacuate(root);
 885 }
 886
 887 static void addBlock(step *step)
 888 {
 889   bdescr *bd = allocBlock();
 890   bd->gen = step->gen;
 891   bd->step = step;
 892
 893   if (step->gen->no <= N) {
 894     bd->evacuated = 1;
 895   } else {
 896     bd->evacuated = 0;
 897   }
 898
 899   step->hp_bd->free = step->hp;
 900   step->hp_bd->link = bd;
 901   step->hp = bd->start;
 902   step->hpLim = step->hp + BLOCK_SIZE_W;
 903   step->hp_bd = bd;
 904   step->to_blocks++;
 905   new_blocks++;
 906 }
 907
 908 static __inline__ void
 909 upd_evacuee(StgClosure *p, StgClosure *dest)
 910 {
 911   p->header.info = &EVACUATED_info;
 912   ((StgEvacuated *)p)->evacuee = dest;
 913 }
 914
 915 static __inline__ StgClosure *
 916 copy(StgClosure *src, nat size, step *step)
 917 {
 918   P_ to, from, dest;
 919
 920   TICK_GC_WORDS_COPIED(size);
 921   /* Find out where we're going, using the handy "to" pointer in
 922    * the step of the source object.  If it turns out we need to
 923    * evacuate to an older generation, adjust it here (see comment
 924    * by evacuate()).
 925    */
 926   if (step->gen->no < evac_gen) {
 927 #ifdef NO_EAGER_PROMOTION
 928     failed_to_evac = rtsTrue;
 929 #else
 930     step = &generations[evac_gen].steps[0];
 931 #endif
 932   }
 933
 934   /* chain a new block onto the to-space for the destination step if
 935    * necessary.
 936    */
 937   if (step->hp + size >= step->hpLim) {
 938     addBlock(step);
 939   }
 940
 941   for(to = step->hp, from = (P_)src; size>0; --size) {
 942     *to++ = *from++;
 943   }
 944
 945   dest = step->hp;
 946   step->hp = to;
 947   upd_evacuee(src,(StgClosure *)dest);
 948   return (StgClosure *)dest;
 949 }
 950
 951 /* Special version of copy() for when we only want to copy the info
 952  * pointer of an object, but reserve some padding after it.  This is
 953  * used to optimise evacuation of BLACKHOLEs.
 954  */
 955
 956 static __inline__ StgClosure *
 957 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
 958 {
 959   P_ dest, to, from;
 960
 961   TICK_GC_WORDS_COPIED(size_to_copy);
 962   if (step->gen->no < evac_gen) {
 963 #ifdef NO_EAGER_PROMOTION
 964     failed_to_evac = rtsTrue;
 965 #else
 966     step = &generations[evac_gen].steps[0];
 967 #endif
 968   }
 969
 970   if (step->hp + size_to_reserve >= step->hpLim) {
 971     addBlock(step);
 972   }
 973
 974   for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
 975     *to++ = *from++;
 976   }
 977
 978   dest = step->hp;
 979   step->hp += size_to_reserve;
 980   upd_evacuee(src,(StgClosure *)dest);
 981   return (StgClosure *)dest;
 982 }
 983
 984 /* -----------------------------------------------------------------------------
 985    Evacuate a large object
 986
 987    This just consists of removing the object from the (doubly-linked)
 988    large_alloc_list, and linking it on to the (singly-linked)
 989    new_large_objects list, from where it will be scavenged later.
 990
 991    Convention: bd->evacuated is /= 0 for a large object that has been
 992    evacuated, or 0 otherwise.
 993    -------------------------------------------------------------------------- */
 994
 995 static inline void
 996 evacuate_large(StgPtr p, rtsBool mutable)
 997 {
 998   bdescr *bd = Bdescr(p);
 999   step *step;
1000
1001   /* should point to the beginning of the block */
1002   ASSERT(((W_)p & BLOCK_MASK) == 0);
1003
1004   /* already evacuated? */
1005   if (bd->evacuated) {
1006     /* Don't forget to set the failed_to_evac flag if we didn't get
1007      * the desired destination (see comments in evacuate()).
1008      */
1009     if (bd->gen->no < evac_gen) {
1010       failed_to_evac = rtsTrue;
1011       TICK_GC_FAILED_PROMOTION();
1012     }
1013     return;
1014   }
1015
1016   step = bd->step;
1017   /* remove from large_object list */
1018   if (bd->back) {
1019     bd->back->link = bd->link;
1020   } else { /* first object in the list */
1021     step->large_objects = bd->link;
1022   }
1023   if (bd->link) {
1024     bd->link->back = bd->back;
1025   }
1026
1027   /* link it on to the evacuated large object list of the destination step
1028    */
1029   step = bd->step->to;
1030   if (step->gen->no < evac_gen) {
1031 #ifdef NO_EAGER_PROMOTION
1032     failed_to_evac = rtsTrue;
1033 #else
1034     step = &generations[evac_gen].steps[0];
1035 #endif
1036   }
1037
1038   bd->step = step;
1039   bd->gen = step->gen;
1040   bd->link = step->new_large_objects;
1041   step->new_large_objects = bd;
1042   bd->evacuated = 1;
1043
1044   if (mutable) {
1045     recordMutable((StgMutClosure *)p);
1046   }
1047 }
1048
1049 /* -----------------------------------------------------------------------------
1050    Adding a MUT_CONS to an older generation.
1051
1052    This is necessary from time to time when we end up with an
1053    old-to-new generation pointer in a non-mutable object.  We defer
1054    the promotion until the next GC.
1055    -------------------------------------------------------------------------- */
1056
1057 static StgClosure *
1058 mkMutCons(StgClosure *ptr, generation *gen)
1059 {
1060   StgMutVar *q;
1061   step *step;
1062
1063   step = &gen->steps[0];
1064
1065   /* chain a new block onto the to-space for the destination step if
1066    * necessary.
1067    */
1068   if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
1069     addBlock(step);
1070   }
1071
1072   q = (StgMutVar *)step->hp;
1073   step->hp += sizeofW(StgMutVar);
1074
1075   SET_HDR(q,&MUT_CONS_info,CCS_GC);
1076   q->var = ptr;
1077   recordOldToNewPtrs((StgMutClosure *)q);
1078
1079   return (StgClosure *)q;
1080 }
1081
1082 /* -----------------------------------------------------------------------------
1083    Evacuate
1084
1085    This is called (eventually) for every live object in the system.
1086
1087    The caller to evacuate specifies a desired generation in the
1088    evac_gen global variable.  The following conditions apply to
1089    evacuating an object which resides in generation M when we're
1090    collecting up to generation N
1091
1092    if  M >= evac_gen
1093            if  M > N     do nothing
1094            else          evac to step->to
1095
1096    if  M < evac_gen      evac to evac_gen, step 0
1097
1098    if the object is already evacuated, then we check which generation
1099    it now resides in.
1100
1101    if  M >= evac_gen     do nothing
1102    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1103                          didn't manage to evacuate this object into evac_gen.
1104
1105    -------------------------------------------------------------------------- */
1106
1107
1108 static StgClosure *
1109 evacuate(StgClosure *q)
1110 {
1111   StgClosure *to;
1112   bdescr *bd = NULL;
1113   step *step;
1114   const StgInfoTable *info;
1115
1116 loop:
1117   if (HEAP_ALLOCED(q)) {
1118     bd = Bdescr((P_)q);
1119     if (bd->gen->no > N) {
1120       /* Can't evacuate this object, because it's in a generation
1121        * older than the ones we're collecting.  Let's hope that it's
1122        * in evac_gen or older, or we will have to make an IND_OLDGEN object.
1123        */
1124       if (bd->gen->no < evac_gen) {
1125         /* nope */
1126         failed_to_evac = rtsTrue;
1127         TICK_GC_FAILED_PROMOTION();
1128       }
1129       return q;
1130     }
1131     step = bd->step->to;
1132   }
1133 #ifdef DEBUG
1134   else step = NULL; /* make sure copy() will crash if HEAP_ALLOCED is wrong */
1135 #endif
1136
1137   /* make sure the info pointer is into text space */
1138   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1139                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1140   info = get_itbl(q);
1141
1142   switch (info -> type) {
1143
1144   case BCO:
1145     return copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
1146
1147   case MUT_VAR:
1148     ASSERT(q->header.info != &MUT_CONS_info);
1149   case MVAR:
1150     to = copy(q,sizeW_fromITBL(info),step);
1151     recordMutable((StgMutClosure *)to);
1152     return to;
1153
1154   case FUN_1_0:
1155   case FUN_0_1:
1156   case CONSTR_1_0:
1157   case CONSTR_0_1:
1158     return copy(q,sizeofW(StgHeader)+1,step);
1159
1160   case THUNK_1_0:               /* here because of MIN_UPD_SIZE */
1161   case THUNK_0_1:
1162   case THUNK_1_1:
1163   case THUNK_0_2:
1164   case THUNK_2_0:
1165 #ifdef NO_PROMOTE_THUNKS
1166     if (bd->gen->no == 0 &&
1167         bd->step->no != 0 &&
1168         bd->step->no == bd->gen->n_steps-1) {
1169       step = bd->step;
1170     }
1171 #endif
1172     return copy(q,sizeofW(StgHeader)+2,step);
1173
1174   case FUN_1_1:
1175   case FUN_0_2:
1176   case FUN_2_0:
1177   case CONSTR_1_1:
1178   case CONSTR_0_2:
1179   case CONSTR_2_0:
1180     return copy(q,sizeofW(StgHeader)+2,step);
1181
1182   case FUN:
1183   case THUNK:
1184   case CONSTR:
1185   case IND_PERM:
1186   case IND_OLDGEN_PERM:
1187   case CAF_UNENTERED:
1188   case CAF_ENTERED:
1189   case WEAK:
1190   case FOREIGN:
1191   case STABLE_NAME:
1192     return copy(q,sizeW_fromITBL(info),step);
1193
1194   case CAF_BLACKHOLE:
1195   case SE_CAF_BLACKHOLE:
1196   case SE_BLACKHOLE:
1197   case BLACKHOLE:
1198     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
1199
1200   case BLACKHOLE_BQ:
1201     to = copy(q,BLACKHOLE_sizeW(),step);
1202     recordMutable((StgMutClosure *)to);
1203     return to;
1204
1205   case THUNK_SELECTOR:
1206     {
1207       const StgInfoTable* selectee_info;
1208       StgClosure* selectee = ((StgSelector*)q)->selectee;
1209
1210     selector_loop:
1211       selectee_info = get_itbl(selectee);
1212       switch (selectee_info->type) {
1213       case CONSTR:
1214       case CONSTR_1_0:
1215       case CONSTR_0_1:
1216       case CONSTR_2_0:
1217       case CONSTR_1_1:
1218       case CONSTR_0_2:
1219       case CONSTR_STATIC:
1220         {
1221           StgWord32 offset = info->layout.selector_offset;
1222
1223           /* check that the size is in range */
1224           ASSERT(offset <
1225                  (StgWord32)(selectee_info->layout.payload.ptrs +
1226                             selectee_info->layout.payload.nptrs));
1227
1228           /* perform the selection! */
1229           q = selectee->payload[offset];
1230
1231           /* if we're already in to-space, there's no need to continue
1232            * with the evacuation, just update the source address with
1233            * a pointer to the (evacuated) constructor field.
1234            */
1235           if (HEAP_ALLOCED(q)) {
1236             bdescr *bd = Bdescr((P_)q);
1237             if (bd->evacuated) {
1238               if (bd->gen->no < evac_gen) {
1239                 failed_to_evac = rtsTrue;
1240                 TICK_GC_FAILED_PROMOTION();
1241               }
1242               return q;
1243             }
1244           }
1245
1246           /* otherwise, carry on and evacuate this constructor field,
1247            * (but not the constructor itself)
1248            */
1249           goto loop;
1250         }
1251
1252       case IND:
1253       case IND_STATIC:
1254       case IND_PERM:
1255       case IND_OLDGEN:
1256       case IND_OLDGEN_PERM:
1257         selectee = stgCast(StgInd *,selectee)->indirectee;
1258         goto selector_loop;
1259
1260       case CAF_ENTERED:
1261         selectee = stgCast(StgCAF *,selectee)->value;
1262         goto selector_loop;
1263
1264       case EVACUATED:
1265         selectee = stgCast(StgEvacuated*,selectee)->evacuee;
1266         goto selector_loop;
1267
1268       case THUNK:
1269       case THUNK_1_0:
1270       case THUNK_0_1:
1271       case THUNK_2_0:
1272       case THUNK_1_1:
1273       case THUNK_0_2:
1274       case THUNK_STATIC:
1275       case THUNK_SELECTOR:
1276         /* aargh - do recursively???? */
1277       case CAF_UNENTERED:
1278       case CAF_BLACKHOLE:
1279       case SE_CAF_BLACKHOLE:
1280       case SE_BLACKHOLE:
1281       case BLACKHOLE:
1282       case BLACKHOLE_BQ:
1283         /* not evaluated yet */
1284         break;
1285
1286       default:
1287         barf("evacuate: THUNK_SELECTOR: strange selectee %d",
1288              (int)(selectee_info->type));
1289       }
1290     }
1291     return copy(q,THUNK_SELECTOR_sizeW(),step);
1292
1293   case IND:
1294   case IND_OLDGEN:
1295     /* follow chains of indirections, don't evacuate them */
1296     q = ((StgInd*)q)->indirectee;
1297     goto loop;
1298
1299   case THUNK_STATIC:
1300     if (info->srt_len > 0 && major_gc &&
1301         THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1302       THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1303       static_objects = (StgClosure *)q;
1304     }
1305     return q;
1306
1307   case FUN_STATIC:
1308     if (info->srt_len > 0 && major_gc &&
1309         FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1310       FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1311       static_objects = (StgClosure *)q;
1312     }
1313     return q;
1314
1315   case IND_STATIC:
1316     if (major_gc && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1317       IND_STATIC_LINK((StgClosure *)q) = static_objects;
1318       static_objects = (StgClosure *)q;
1319     }
1320     return q;
1321
1322   case CONSTR_STATIC:
1323     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1324       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1325       static_objects = (StgClosure *)q;
1326     }
1327     return q;
1328
1329   case CONSTR_INTLIKE:
1330   case CONSTR_CHARLIKE:
1331   case CONSTR_NOCAF_STATIC:
1332     /* no need to put these on the static linked list, they don't need
1333      * to be scavenged.
1334      */
1335     return q;
1336
1337   case RET_BCO:
1338   case RET_SMALL:
1339   case RET_VEC_SMALL:
1340   case RET_BIG:
1341   case RET_VEC_BIG:
1342   case RET_DYN:
1343   case UPDATE_FRAME:
1344   case STOP_FRAME:
1345   case CATCH_FRAME:
1346   case SEQ_FRAME:
1347     /* shouldn't see these */
1348     barf("evacuate: stack frame\n");
1349
1350   case AP_UPD:
1351   case PAP:
1352     /* these are special - the payload is a copy of a chunk of stack,
1353        tagging and all. */
1354     return copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
1355
1356   case EVACUATED:
1357     /* Already evacuated, just return the forwarding address.
1358      * HOWEVER: if the requested destination generation (evac_gen) is
1359      * older than the actual generation (because the object was
1360      * already evacuated to a younger generation) then we have to
1361      * set the failed_to_evac flag to indicate that we couldn't
1362      * manage to promote the object to the desired generation.
1363      */
1364     if (evac_gen > 0) {         /* optimisation */
1365       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1366       if (Bdescr((P_)p)->gen->no < evac_gen) {
1367         /*      fprintf(stderr,"evac failed!\n");*/
1368         failed_to_evac = rtsTrue;
1369         TICK_GC_FAILED_PROMOTION();
1370       }
1371     }
1372     return ((StgEvacuated*)q)->evacuee;
1373
1374   case ARR_WORDS:
1375     {
1376       nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1377
1378       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1379         evacuate_large((P_)q, rtsFalse);
1380         return q;
1381       } else {
1382         /* just copy the block */
1383         return copy(q,size,step);
1384       }
1385     }
1386
1387   case MUT_ARR_PTRS:
1388   case MUT_ARR_PTRS_FROZEN:
1389     {
1390       nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1391
1392       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1393         evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1394         to = q;
1395       } else {
1396         /* just copy the block */
1397         to = copy(q,size,step);
1398         if (info->type == MUT_ARR_PTRS) {
1399           recordMutable((StgMutClosure *)to);
1400         }
1401       }
1402       return to;
1403     }
1404
1405   case TSO:
1406     {
1407       StgTSO *tso = stgCast(StgTSO *,q);
1408       nat size = tso_sizeW(tso);
1409       int diff;
1410
1411       /* Large TSOs don't get moved, so no relocation is required.
1412        */
1413       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1414         evacuate_large((P_)q, rtsTrue);
1415         return q;
1416
1417       /* To evacuate a small TSO, we need to relocate the update frame
1418        * list it contains.
1419        */
1420       } else {
1421         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
1422
1423         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1424
1425         /* relocate the stack pointers... */
1426         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1427         new_tso->sp = (StgPtr)new_tso->sp + diff;
1428         new_tso->splim = (StgPtr)new_tso->splim + diff;
1429
1430         relocate_TSO(tso, new_tso);
1431
1432         recordMutable((StgMutClosure *)new_tso);
1433         return (StgClosure *)new_tso;
1434       }
1435     }
1436
1437   case BLOCKED_FETCH:
1438   case FETCH_ME:
1439     fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1440     return q;
1441
1442   default:
1443     barf("evacuate: strange closure type %d", (int)(info->type));
1444   }
1445
1446   barf("evacuate");
1447 }
1448
1449 /* -----------------------------------------------------------------------------
1450    relocate_TSO is called just after a TSO has been copied from src to
1451    dest.  It adjusts the update frame list for the new location.
1452    -------------------------------------------------------------------------- */
1453
1454 StgTSO *
1455 relocate_TSO(StgTSO *src, StgTSO *dest)
1456 {
1457   StgUpdateFrame *su;
1458   StgCatchFrame  *cf;
1459   StgSeqFrame    *sf;
1460   int diff;
1461
1462   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1463
1464   su = dest->su;
1465
1466   while ((P_)su < dest->stack + dest->stack_size) {
1467     switch (get_itbl(su)->type) {
1468
1469       /* GCC actually manages to common up these three cases! */
1470
1471     case UPDATE_FRAME:
1472       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1473       su = su->link;
1474       continue;
1475
1476     case CATCH_FRAME:
1477       cf = (StgCatchFrame *)su;
1478       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1479       su = cf->link;
1480       continue;
1481
1482     case SEQ_FRAME:
1483       sf = (StgSeqFrame *)su;
1484       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1485       su = sf->link;
1486       continue;
1487
1488     case STOP_FRAME:
1489       /* all done! */
1490       break;
1491
1492     default:
1493       barf("relocate_TSO %d", (int)(get_itbl(su)->type));
1494     }
1495     break;
1496   }
1497
1498   return dest;
1499 }
1500
1501 static inline void
1502 scavenge_srt(const StgInfoTable *info)
1503 {
1504   StgClosure **srt, **srt_end;
1505
1506   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1507    * srt field in the info table.  That's ok, because we'll
1508    * never dereference it.
1509    */
1510   srt = stgCast(StgClosure **,info->srt);
1511   srt_end = srt + info->srt_len;
1512   for (; srt < srt_end; srt++) {
1513     /* Special-case to handle references to closures hiding out in DLLs, since
1514        double indirections required to get at those. The code generator knows
1515        which is which when generating the SRT, so it stores the (indirect)
1516        reference to the DLL closure in the table by first adding one to it.
1517        We check for this here, and undo the addition before evacuating it.
1518
1519        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1520        closure that's fixed at link-time, and no extra magic is required.
1521     */
1522 #ifdef ENABLE_WIN32_DLL_SUPPORT
1523     if ( stgCast(unsigned long,*srt) & 0x1 ) {
1524        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
1525     } else {
1526        evacuate(*srt);
1527     }
1528 #else
1529        evacuate(*srt);
1530 #endif
1531   }
1532 }
1533
1534 /* -----------------------------------------------------------------------------
1535    Scavenge a given step until there are no more objects in this step
1536    to scavenge.
1537
1538    evac_gen is set by the caller to be either zero (for a step in a
1539    generation < N) or G where G is the generation of the step being
1540    scavenged.
1541
1542    We sometimes temporarily change evac_gen back to zero if we're
1543    scavenging a mutable object where early promotion isn't such a good
1544    idea.
1545    -------------------------------------------------------------------------- */
1546
1547
1548 static void
1549 scavenge(step *step)
1550 {
1551   StgPtr p, q;
1552   const StgInfoTable *info;
1553   bdescr *bd;
1554   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1555
1556   p = step->scan;
1557   bd = step->scan_bd;
1558
1559   failed_to_evac = rtsFalse;
1560
1561   /* scavenge phase - standard breadth-first scavenging of the
1562    * evacuated objects
1563    */
1564
1565   while (bd != step->hp_bd || p < step->hp) {
1566
1567     /* If we're at the end of this block, move on to the next block */
1568     if (bd != step->hp_bd && p == bd->free) {
1569       bd = bd->link;
1570       p = bd->start;
1571       continue;
1572     }
1573
1574     q = p;                      /* save ptr to object */
1575
1576     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1577                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1578
1579     info = get_itbl((StgClosure *)p);
1580     switch (info -> type) {
1581
1582     case BCO:
1583       {
1584         StgBCO* bco = stgCast(StgBCO*,p);
1585         nat i;
1586         for (i = 0; i < bco->n_ptrs; i++) {
1587           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1588         }
1589         p += bco_sizeW(bco);
1590         break;
1591       }
1592
1593     case MVAR:
1594       /* treat MVars specially, because we don't want to evacuate the
1595        * mut_link field in the middle of the closure.
1596        */
1597       {
1598         StgMVar *mvar = ((StgMVar *)p);
1599         evac_gen = 0;
1600         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1601         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1602         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1603         p += sizeofW(StgMVar);
1604         evac_gen = saved_evac_gen;
1605         break;
1606       }
1607
1608     case THUNK_2_0:
1609     case FUN_2_0:
1610       scavenge_srt(info);
1611     case CONSTR_2_0:
1612       ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
1613       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1614       p += sizeofW(StgHeader) + 2;
1615       break;
1616
1617     case THUNK_1_0:
1618       scavenge_srt(info);
1619       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1620       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1621       break;
1622
1623     case FUN_1_0:
1624       scavenge_srt(info);
1625     case CONSTR_1_0:
1626       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1627       p += sizeofW(StgHeader) + 1;
1628       break;
1629
1630     case THUNK_0_1:
1631       scavenge_srt(info);
1632       p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
1633       break;
1634
1635     case FUN_0_1:
1636       scavenge_srt(info);
1637     case CONSTR_0_1:
1638       p += sizeofW(StgHeader) + 1;
1639       break;
1640
1641     case THUNK_0_2:
1642     case FUN_0_2:
1643       scavenge_srt(info);
1644     case CONSTR_0_2:
1645       p += sizeofW(StgHeader) + 2;
1646       break;
1647
1648     case THUNK_1_1:
1649     case FUN_1_1:
1650       scavenge_srt(info);
1651     case CONSTR_1_1:
1652       ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
1653       p += sizeofW(StgHeader) + 2;
1654       break;
1655
1656     case FUN:
1657     case THUNK:
1658       scavenge_srt(info);
1659       /* fall through */
1660
1661     case CONSTR:
1662     case WEAK:
1663     case FOREIGN:
1664     case STABLE_NAME:
1665       {
1666         StgPtr end;
1667
1668         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1669         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1670           (StgClosure *)*p = evacuate((StgClosure *)*p);
1671         }
1672         p += info->layout.payload.nptrs;
1673         break;
1674       }
1675
1676     case IND_PERM:
1677       if (step->gen->no != 0) {
1678         SET_INFO(((StgClosure *)p), &IND_OLDGEN_PERM_info);
1679       }
1680       /* fall through */
1681     case IND_OLDGEN_PERM:
1682       ((StgIndOldGen *)p)->indirectee =
1683         evacuate(((StgIndOldGen *)p)->indirectee);
1684       if (failed_to_evac) {
1685         failed_to_evac = rtsFalse;
1686         recordOldToNewPtrs((StgMutClosure *)p);
1687       }
1688       p += sizeofW(StgIndOldGen);
1689       break;
1690
1691     case CAF_UNENTERED:
1692       {
1693         StgCAF *caf = (StgCAF *)p;
1694
1695         caf->body = evacuate(caf->body);
1696         if (failed_to_evac) {
1697           failed_to_evac = rtsFalse;
1698           recordOldToNewPtrs((StgMutClosure *)p);
1699         } else {
1700           caf->mut_link = NULL;
1701         }
1702         p += sizeofW(StgCAF);
1703         break;
1704       }
1705
1706     case CAF_ENTERED:
1707       {
1708         StgCAF *caf = (StgCAF *)p;
1709
1710         caf->body = evacuate(caf->body);
1711         caf->value = evacuate(caf->value);
1712         if (failed_to_evac) {
1713           failed_to_evac = rtsFalse;
1714           recordOldToNewPtrs((StgMutClosure *)p);
1715         } else {
1716           caf->mut_link = NULL;
1717         }
1718         p += sizeofW(StgCAF);
1719         break;
1720       }
1721
1722     case MUT_VAR:
1723       /* ignore MUT_CONSs */
1724       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1725         evac_gen = 0;
1726         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1727         evac_gen = saved_evac_gen;
1728       }
1729       p += sizeofW(StgMutVar);
1730       break;
1731
1732     case CAF_BLACKHOLE:
1733     case SE_CAF_BLACKHOLE:
1734     case SE_BLACKHOLE:
1735     case BLACKHOLE:
1736         p += BLACKHOLE_sizeW();
1737         break;
1738
1739     case BLACKHOLE_BQ:
1740       {
1741         StgBlockingQueue *bh = (StgBlockingQueue *)p;
1742         (StgClosure *)bh->blocking_queue =
1743           evacuate((StgClosure *)bh->blocking_queue);
1744         if (failed_to_evac) {
1745           failed_to_evac = rtsFalse;
1746           recordMutable((StgMutClosure *)bh);
1747         }
1748         p += BLACKHOLE_sizeW();
1749         break;
1750       }
1751
1752     case THUNK_SELECTOR:
1753       {
1754         StgSelector *s = (StgSelector *)p;
1755         s->selectee = evacuate(s->selectee);
1756         p += THUNK_SELECTOR_sizeW();
1757         break;
1758       }
1759
1760     case IND:
1761     case IND_OLDGEN:
1762       barf("scavenge:IND???\n");
1763
1764     case CONSTR_INTLIKE:
1765     case CONSTR_CHARLIKE:
1766     case CONSTR_STATIC:
1767     case CONSTR_NOCAF_STATIC:
1768     case THUNK_STATIC:
1769     case FUN_STATIC:
1770     case IND_STATIC:
1771       /* Shouldn't see a static object here. */
1772       barf("scavenge: STATIC object\n");
1773
1774     case RET_BCO:
1775     case RET_SMALL:
1776     case RET_VEC_SMALL:
1777     case RET_BIG:
1778     case RET_VEC_BIG:
1779     case RET_DYN:
1780     case UPDATE_FRAME:
1781     case STOP_FRAME:
1782     case CATCH_FRAME:
1783     case SEQ_FRAME:
1784       /* Shouldn't see stack frames here. */
1785       barf("scavenge: stack frame\n");
1786
1787     case AP_UPD: /* same as PAPs */
1788     case PAP:
1789       /* Treat a PAP just like a section of stack, not forgetting to
1790        * evacuate the function pointer too...
1791        */
1792       {
1793         StgPAP* pap = stgCast(StgPAP*,p);
1794
1795         pap->fun = evacuate(pap->fun);
1796         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1797         p += pap_sizeW(pap);
1798         break;
1799       }
1800
1801     case ARR_WORDS:
1802       /* nothing to follow */
1803       p += arr_words_sizeW(stgCast(StgArrWords*,p));
1804       break;
1805
1806     case MUT_ARR_PTRS:
1807       /* follow everything */
1808       {
1809         StgPtr next;
1810
1811         evac_gen = 0;           /* repeatedly mutable */
1812         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1813         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1814           (StgClosure *)*p = evacuate((StgClosure *)*p);
1815         }
1816         evac_gen = saved_evac_gen;
1817         break;
1818       }
1819
1820     case MUT_ARR_PTRS_FROZEN:
1821       /* follow everything */
1822       {
1823         StgPtr start = p, next;
1824
1825         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1826         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1827           (StgClosure *)*p = evacuate((StgClosure *)*p);
1828         }
1829         if (failed_to_evac) {
1830           /* we can do this easier... */
1831           recordMutable((StgMutClosure *)start);
1832           failed_to_evac = rtsFalse;
1833         }
1834         break;
1835       }
1836
1837     case TSO:
1838       {
1839         StgTSO *tso;
1840
1841         tso = (StgTSO *)p;
1842         evac_gen = 0;
1843         /* chase the link field for any TSOs on the same queue */
1844         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1845         if (   tso->why_blocked == BlockedOnMVar
1846             || tso->why_blocked == BlockedOnBlackHole) {
1847           tso->block_info.closure = evacuate(tso->block_info.closure);
1848         }
1849         /* scavenge this thread's stack */
1850         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1851         evac_gen = saved_evac_gen;
1852         p += tso_sizeW(tso);
1853         break;
1854       }
1855
1856     case BLOCKED_FETCH:
1857     case FETCH_ME:
1858     case EVACUATED:
1859       barf("scavenge: unimplemented/strange closure type\n");
1860
1861     default:
1862       barf("scavenge");
1863     }
1864
1865     /* If we didn't manage to promote all the objects pointed to by
1866      * the current object, then we have to designate this object as
1867      * mutable (because it contains old-to-new generation pointers).
1868      */
1869     if (failed_to_evac) {
1870       mkMutCons((StgClosure *)q, &generations[evac_gen]);
1871       failed_to_evac = rtsFalse;
1872     }
1873   }
1874
1875   step->scan_bd = bd;
1876   step->scan = p;
1877 }
1878
1879 /* -----------------------------------------------------------------------------
1880    Scavenge one object.
1881
1882    This is used for objects that are temporarily marked as mutable
1883    because they contain old-to-new generation pointers.  Only certain
1884    objects can have this property.
1885    -------------------------------------------------------------------------- */
1886 static rtsBool
1887 scavenge_one(StgClosure *p)
1888 {
1889   const StgInfoTable *info;
1890   rtsBool no_luck;
1891
1892   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1893                || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1894
1895   info = get_itbl(p);
1896
1897   switch (info -> type) {
1898
1899   case FUN:
1900   case FUN_1_0:                 /* hardly worth specialising these guys */
1901   case FUN_0_1:
1902   case FUN_1_1:
1903   case FUN_0_2:
1904   case FUN_2_0:
1905   case THUNK:
1906   case THUNK_1_0:
1907   case THUNK_0_1:
1908   case THUNK_1_1:
1909   case THUNK_0_2:
1910   case THUNK_2_0:
1911   case CONSTR:
1912   case CONSTR_1_0:
1913   case CONSTR_0_1:
1914   case CONSTR_1_1:
1915   case CONSTR_0_2:
1916   case CONSTR_2_0:
1917   case WEAK:
1918   case FOREIGN:
1919   case IND_PERM:
1920   case IND_OLDGEN_PERM:
1921   case CAF_UNENTERED:
1922     {
1923       StgPtr q, end;
1924
1925       end = (P_)p->payload + info->layout.payload.ptrs;
1926       for (q = (P_)p->payload; q < end; q++) {
1927         (StgClosure *)*q = evacuate((StgClosure *)*q);
1928       }
1929       break;
1930     }
1931
1932   case CAF_BLACKHOLE:
1933   case SE_CAF_BLACKHOLE:
1934   case SE_BLACKHOLE:
1935   case BLACKHOLE:
1936       break;
1937
1938   case THUNK_SELECTOR:
1939     {
1940       StgSelector *s = (StgSelector *)p;
1941       s->selectee = evacuate(s->selectee);
1942       break;
1943     }
1944
1945   case AP_UPD: /* same as PAPs */
1946   case PAP:
1947     /* Treat a PAP just like a section of stack, not forgetting to
1948      * evacuate the function pointer too...
1949      */
1950     {
1951       StgPAP* pap = (StgPAP *)p;
1952
1953       pap->fun = evacuate(pap->fun);
1954       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1955       break;
1956     }
1957
1958   case IND_OLDGEN:
1959     /* This might happen if for instance a MUT_CONS was pointing to a
1960      * THUNK which has since been updated.  The IND_OLDGEN will
1961      * be on the mutable list anyway, so we don't need to do anything
1962      * here.
1963      */
1964     break;
1965
1966   default:
1967     barf("scavenge_one: strange object");
1968   }
1969
1970   no_luck = failed_to_evac;
1971   failed_to_evac = rtsFalse;
1972   return (no_luck);
1973 }
1974
1975
1976 /* -----------------------------------------------------------------------------
1977    Scavenging mutable lists.
1978
1979    We treat the mutable list of each generation > N (i.e. all the
1980    generations older than the one being collected) as roots.  We also
1981    remove non-mutable objects from the mutable list at this point.
1982    -------------------------------------------------------------------------- */
1983
1984 static void
1985 scavenge_mut_once_list(generation *gen)
1986 {
1987   const StgInfoTable *info;
1988   StgMutClosure *p, *next, *new_list;
1989
1990   p = gen->mut_once_list;
1991   new_list = END_MUT_LIST;
1992   next = p->mut_link;
1993
1994   evac_gen = gen->no;
1995   failed_to_evac = rtsFalse;
1996
1997   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
1998
1999     /* make sure the info pointer is into text space */
2000     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2001                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2002
2003     info = get_itbl(p);
2004     switch(info->type) {
2005
2006     case IND_OLDGEN:
2007     case IND_OLDGEN_PERM:
2008     case IND_STATIC:
2009       /* Try to pull the indirectee into this generation, so we can
2010        * remove the indirection from the mutable list.
2011        */
2012       ((StgIndOldGen *)p)->indirectee =
2013         evacuate(((StgIndOldGen *)p)->indirectee);
2014
2015 #if 0
2016       /* Debugging code to print out the size of the thing we just
2017        * promoted
2018        */
2019       {
2020         StgPtr start = gen->steps[0].scan;
2021         bdescr *start_bd = gen->steps[0].scan_bd;
2022         nat size = 0;
2023         scavenge(&gen->steps[0]);
2024         if (start_bd != gen->steps[0].scan_bd) {
2025           size += (P_)BLOCK_ROUND_UP(start) - start;
2026           start_bd = start_bd->link;
2027           while (start_bd != gen->steps[0].scan_bd) {
2028             size += BLOCK_SIZE_W;
2029             start_bd = start_bd->link;
2030           }
2031           size += gen->steps[0].scan -
2032             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
2033         } else {
2034           size = gen->steps[0].scan - start;
2035         }
2036         fprintf(stderr,"evac IND_OLDGEN: %d bytes\n", size * sizeof(W_));
2037       }
2038 #endif
2039
2040       /* failed_to_evac might happen if we've got more than two
2041        * generations, we're collecting only generation 0, the
2042        * indirection resides in generation 2 and the indirectee is
2043        * in generation 1.
2044        */
2045       if (failed_to_evac) {
2046         failed_to_evac = rtsFalse;
2047         p->mut_link = new_list;
2048         new_list = p;
2049       } else {
2050         /* the mut_link field of an IND_STATIC is overloaded as the
2051          * static link field too (it just so happens that we don't need
2052          * both at the same time), so we need to NULL it out when
2053          * removing this object from the mutable list because the static
2054          * link fields are all assumed to be NULL before doing a major
2055          * collection.
2056          */
2057         p->mut_link = NULL;
2058       }
2059       continue;
2060
2061     case MUT_VAR:
2062       /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
2063        * it from the mutable list if possible by promoting whatever it
2064        * points to.
2065        */
2066       ASSERT(p->header.info == &MUT_CONS_info);
2067       if (scavenge_one(((StgMutVar *)p)->var) == rtsTrue) {
2068         /* didn't manage to promote everything, so put the
2069          * MUT_CONS back on the list.
2070          */
2071         p->mut_link = new_list;
2072         new_list = p;
2073       }
2074       continue;
2075
2076     case CAF_ENTERED:
2077       {
2078         StgCAF *caf = (StgCAF *)p;
2079         caf->body  = evacuate(caf->body);
2080         caf->value = evacuate(caf->value);
2081         if (failed_to_evac) {
2082           failed_to_evac = rtsFalse;
2083           p->mut_link = new_list;
2084           new_list = p;
2085         } else {
2086           p->mut_link = NULL;
2087         }
2088       }
2089       continue;
2090
2091     case CAF_UNENTERED:
2092       {
2093         StgCAF *caf = (StgCAF *)p;
2094         caf->body  = evacuate(caf->body);
2095         if (failed_to_evac) {
2096           failed_to_evac = rtsFalse;
2097           p->mut_link = new_list;
2098           new_list = p;
2099         } else {
2100           p->mut_link = NULL;
2101         }
2102       }
2103       continue;
2104
2105     default:
2106       /* shouldn't have anything else on the mutables list */
2107       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
2108     }
2109   }
2110
2111   gen->mut_once_list = new_list;
2112 }
2113
2114
2115 static void
2116 scavenge_mutable_list(generation *gen)
2117 {
2118   const StgInfoTable *info;
2119   StgMutClosure *p, *next;
2120
2121   p = gen->saved_mut_list;
2122   next = p->mut_link;
2123
2124   evac_gen = 0;
2125   failed_to_evac = rtsFalse;
2126
2127   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2128
2129     /* make sure the info pointer is into text space */
2130     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2131                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2132
2133     info = get_itbl(p);
2134     switch(info->type) {
2135
2136     case MUT_ARR_PTRS_FROZEN:
2137       /* remove this guy from the mutable list, but follow the ptrs
2138        * anyway (and make sure they get promoted to this gen).
2139        */
2140       {
2141         StgPtr end, q;
2142
2143         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2144         evac_gen = gen->no;
2145         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2146           (StgClosure *)*q = evacuate((StgClosure *)*q);
2147         }
2148         evac_gen = 0;
2149
2150         if (failed_to_evac) {
2151           failed_to_evac = rtsFalse;
2152           p->mut_link = gen->mut_list;
2153           gen->mut_list = p;
2154         }
2155         continue;
2156       }
2157
2158     case MUT_ARR_PTRS:
2159       /* follow everything */
2160       p->mut_link = gen->mut_list;
2161       gen->mut_list = p;
2162       {
2163         StgPtr end, q;
2164
2165         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2166         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2167           (StgClosure *)*q = evacuate((StgClosure *)*q);
2168         }
2169         continue;
2170       }
2171
2172     case MUT_VAR:
2173       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
2174        * it from the mutable list if possible by promoting whatever it
2175        * points to.
2176        */
2177       ASSERT(p->header.info != &MUT_CONS_info);
2178       ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2179       p->mut_link = gen->mut_list;
2180       gen->mut_list = p;
2181       continue;
2182
2183     case MVAR:
2184       {
2185         StgMVar *mvar = (StgMVar *)p;
2186         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2187         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2188         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2189         p->mut_link = gen->mut_list;
2190         gen->mut_list = p;
2191         continue;
2192       }
2193
2194     case TSO:
2195       {
2196         StgTSO *tso = (StgTSO *)p;
2197
2198         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2199         if (   tso->why_blocked == BlockedOnMVar
2200             || tso->why_blocked == BlockedOnBlackHole) {
2201           tso->block_info.closure = evacuate(tso->block_info.closure);
2202         }
2203         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2204
2205         /* Don't take this TSO off the mutable list - it might still
2206          * point to some younger objects (because we set evac_gen to 0
2207          * above).
2208          */
2209         tso->mut_link = gen->mut_list;
2210         gen->mut_list = (StgMutClosure *)tso;
2211         continue;
2212       }
2213
2214     case BLACKHOLE_BQ:
2215       {
2216         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2217         (StgClosure *)bh->blocking_queue =
2218           evacuate((StgClosure *)bh->blocking_queue);
2219         p->mut_link = gen->mut_list;
2220         gen->mut_list = p;
2221         continue;
2222       }
2223
2224     default:
2225       /* shouldn't have anything else on the mutables list */
2226       barf("scavenge_mut_list: strange object? %d", (int)(info->type));
2227     }
2228   }
2229 }
2230
2231 static void
2232 scavenge_static(void)
2233 {
2234   StgClosure* p = static_objects;
2235   const StgInfoTable *info;
2236
2237   /* Always evacuate straight to the oldest generation for static
2238    * objects */
2239   evac_gen = oldest_gen->no;
2240
2241   /* keep going until we've scavenged all the objects on the linked
2242      list... */
2243   while (p != END_OF_STATIC_LIST) {
2244
2245     info = get_itbl(p);
2246
2247     /* make sure the info pointer is into text space */
2248     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2249                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2250
2251     /* Take this object *off* the static_objects list,
2252      * and put it on the scavenged_static_objects list.
2253      */
2254     static_objects = STATIC_LINK(info,p);
2255     STATIC_LINK(info,p) = scavenged_static_objects;
2256     scavenged_static_objects = p;
2257
2258     switch (info -> type) {
2259
2260     case IND_STATIC:
2261       {
2262         StgInd *ind = (StgInd *)p;
2263         ind->indirectee = evacuate(ind->indirectee);
2264
2265         /* might fail to evacuate it, in which case we have to pop it
2266          * back on the mutable list (and take it off the
2267          * scavenged_static list because the static link and mut link
2268          * pointers are one and the same).
2269          */
2270         if (failed_to_evac) {
2271           failed_to_evac = rtsFalse;
2272           scavenged_static_objects = STATIC_LINK(info,p);
2273           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
2274           oldest_gen->mut_once_list = (StgMutClosure *)ind;
2275         }
2276         break;
2277       }
2278
2279     case THUNK_STATIC:
2280     case FUN_STATIC:
2281       scavenge_srt(info);
2282       /* fall through */
2283
2284     case CONSTR_STATIC:
2285       {
2286         StgPtr q, next;
2287
2288         next = (P_)p->payload + info->layout.payload.ptrs;
2289         /* evacuate the pointers */
2290         for (q = (P_)p->payload; q < next; q++) {
2291           (StgClosure *)*q = evacuate((StgClosure *)*q);
2292         }
2293         break;
2294       }
2295
2296     default:
2297       barf("scavenge_static");
2298     }
2299
2300     ASSERT(failed_to_evac == rtsFalse);
2301
2302     /* get the next static object from the list.  Remeber, there might
2303      * be more stuff on this list now that we've done some evacuating!
2304      * (static_objects is a global)
2305      */
2306     p = static_objects;
2307   }
2308 }
2309
2310 /* -----------------------------------------------------------------------------
2311    scavenge_stack walks over a section of stack and evacuates all the
2312    objects pointed to by it.  We can use the same code for walking
2313    PAPs, since these are just sections of copied stack.
2314    -------------------------------------------------------------------------- */
2315
2316 static void
2317 scavenge_stack(StgPtr p, StgPtr stack_end)
2318 {
2319   StgPtr q;
2320   const StgInfoTable* info;
2321   StgWord32 bitmap;
2322
2323   /*
2324    * Each time around this loop, we are looking at a chunk of stack
2325    * that starts with either a pending argument section or an
2326    * activation record.
2327    */
2328
2329   while (p < stack_end) {
2330     q = *(P_ *)p;
2331
2332     /* If we've got a tag, skip over that many words on the stack */
2333     if (IS_ARG_TAG((W_)q)) {
2334       p += ARG_SIZE(q);
2335       p++; continue;
2336     }
2337
2338     /* Is q a pointer to a closure?
2339      */
2340     if (! LOOKS_LIKE_GHC_INFO(q) ) {
2341 #ifdef DEBUG
2342       if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  /* Is it a static closure? */
2343         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
2344       }
2345       /* otherwise, must be a pointer into the allocation space. */
2346 #endif
2347
2348       (StgClosure *)*p = evacuate((StgClosure *)q);
2349       p++;
2350       continue;
2351     }
2352
2353     /*
2354      * Otherwise, q must be the info pointer of an activation
2355      * record.  All activation records have 'bitmap' style layout
2356      * info.
2357      */
2358     info  = get_itbl((StgClosure *)p);
2359
2360     switch (info->type) {
2361
2362       /* Dynamic bitmap: the mask is stored on the stack */
2363     case RET_DYN:
2364       bitmap = ((StgRetDyn *)p)->liveness;
2365       p      = (P_)&((StgRetDyn *)p)->payload[0];
2366       goto small_bitmap;
2367
2368       /* probably a slow-entry point return address: */
2369     case FUN:
2370     case FUN_STATIC:
2371       p++;
2372       goto follow_srt;
2373
2374       /* Specialised code for update frames, since they're so common.
2375        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
2376        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
2377        */
2378     case UPDATE_FRAME:
2379       {
2380         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2381         StgClosure *to;
2382         nat type = get_itbl(frame->updatee)->type;
2383
2384         p += sizeofW(StgUpdateFrame);
2385         if (type == EVACUATED) {
2386           frame->updatee = evacuate(frame->updatee);
2387           continue;
2388         } else {
2389           bdescr *bd = Bdescr((P_)frame->updatee);
2390           step *step;
2391           if (bd->gen->no > N) {
2392             if (bd->gen->no < evac_gen) {
2393               failed_to_evac = rtsTrue;
2394             }
2395             continue;
2396           }
2397
2398           /* Don't promote blackholes */
2399           step = bd->step;
2400           if (!(step->gen->no == 0 &&
2401                 step->no != 0 &&
2402                 step->no == step->gen->n_steps-1)) {
2403             step = step->to;
2404           }
2405
2406           switch (type) {
2407           case BLACKHOLE:
2408           case CAF_BLACKHOLE:
2409             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
2410                           sizeofW(StgHeader), step);
2411             frame->updatee = to;
2412             continue;
2413           case BLACKHOLE_BQ:
2414             to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
2415             frame->updatee = to;
2416             recordMutable((StgMutClosure *)to);
2417             continue;
2418           default:
2419             /* will never be SE_{,CAF_}BLACKHOLE, since we
2420                don't push an update frame for single-entry thunks.  KSW 1999-01. */
2421             barf("scavenge_stack: UPDATE_FRAME updatee");
2422           }
2423         }
2424       }
2425
2426       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2427     case RET_BCO:
2428     case RET_SMALL:
2429     case RET_VEC_SMALL:
2430     case STOP_FRAME:
2431     case CATCH_FRAME:
2432     case SEQ_FRAME:
2433       bitmap = info->layout.bitmap;
2434       p++;
2435     small_bitmap:
2436       while (bitmap != 0) {
2437         if ((bitmap & 1) == 0) {
2438           (StgClosure *)*p = evacuate((StgClosure *)*p);
2439         }
2440         p++;
2441         bitmap = bitmap >> 1;
2442       }
2443
2444     follow_srt:
2445       scavenge_srt(info);
2446       continue;
2447
2448       /* large bitmap (> 32 entries) */
2449     case RET_BIG:
2450     case RET_VEC_BIG:
2451       {
2452         StgPtr q;
2453         StgLargeBitmap *large_bitmap;
2454         nat i;
2455
2456         large_bitmap = info->layout.large_bitmap;
2457         p++;
2458
2459         for (i=0; i<large_bitmap->size; i++) {
2460           bitmap = large_bitmap->bitmap[i];
2461           q = p + sizeof(W_) * 8;
2462           while (bitmap != 0) {
2463             if ((bitmap & 1) == 0) {
2464               (StgClosure *)*p = evacuate((StgClosure *)*p);
2465             }
2466             p++;
2467             bitmap = bitmap >> 1;
2468           }
2469           if (i+1 < large_bitmap->size) {
2470             while (p < q) {
2471               (StgClosure *)*p = evacuate((StgClosure *)*p);
2472               p++;
2473             }
2474           }
2475         }
2476
2477         /* and don't forget to follow the SRT */
2478         goto follow_srt;
2479       }
2480
2481     default:
2482       barf("scavenge_stack: weird activation record found on stack.\n");
2483     }
2484   }
2485 }
2486
2487 /*-----------------------------------------------------------------------------
2488   scavenge the large object list.
2489
2490   evac_gen set by caller; similar games played with evac_gen as with
2491   scavenge() - see comment at the top of scavenge().  Most large
2492   objects are (repeatedly) mutable, so most of the time evac_gen will
2493   be zero.
2494   --------------------------------------------------------------------------- */
2495
2496 static void
2497 scavenge_large(step *step)
2498 {
2499   bdescr *bd;
2500   StgPtr p;
2501   const StgInfoTable* info;
2502   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
2503
2504   evac_gen = 0;                 /* most objects are mutable */
2505   bd = step->new_large_objects;
2506
2507   for (; bd != NULL; bd = step->new_large_objects) {
2508
2509     /* take this object *off* the large objects list and put it on
2510      * the scavenged large objects list.  This is so that we can
2511      * treat new_large_objects as a stack and push new objects on
2512      * the front when evacuating.
2513      */
2514     step->new_large_objects = bd->link;
2515     dbl_link_onto(bd, &step->scavenged_large_objects);
2516
2517     p = bd->start;
2518     info  = get_itbl(stgCast(StgClosure*,p));
2519
2520     switch (info->type) {
2521
2522     /* only certain objects can be "large"... */
2523
2524     case ARR_WORDS:
2525       /* nothing to follow */
2526       continue;
2527
2528     case MUT_ARR_PTRS:
2529       /* follow everything */
2530       {
2531         StgPtr next;
2532
2533         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2534         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2535           (StgClosure *)*p = evacuate((StgClosure *)*p);
2536         }
2537         continue;
2538       }
2539
2540     case MUT_ARR_PTRS_FROZEN:
2541       /* follow everything */
2542       {
2543         StgPtr start = p, next;
2544
2545         evac_gen = saved_evac_gen; /* not really mutable */
2546         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2547         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2548           (StgClosure *)*p = evacuate((StgClosure *)*p);
2549         }
2550         evac_gen = 0;
2551         if (failed_to_evac) {
2552           recordMutable((StgMutClosure *)start);
2553         }
2554         continue;
2555       }
2556
2557     case BCO:
2558       {
2559         StgBCO* bco = stgCast(StgBCO*,p);
2560         nat i;
2561         evac_gen = saved_evac_gen;
2562         for (i = 0; i < bco->n_ptrs; i++) {
2563           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2564         }
2565         evac_gen = 0;
2566         continue;
2567       }
2568
2569     case TSO:
2570       {
2571         StgTSO *tso;
2572
2573         tso = (StgTSO *)p;
2574         /* chase the link field for any TSOs on the same queue */
2575         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2576         if (   tso->why_blocked == BlockedOnMVar
2577             || tso->why_blocked == BlockedOnBlackHole) {
2578           tso->block_info.closure = evacuate(tso->block_info.closure);
2579         }
2580         /* scavenge this thread's stack */
2581         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2582         continue;
2583       }
2584
2585     default:
2586       barf("scavenge_large: unknown/strange object");
2587     }
2588   }
2589 }
2590
2591 static void
2592 zero_static_object_list(StgClosure* first_static)
2593 {
2594   StgClosure* p;
2595   StgClosure* link;
2596   const StgInfoTable *info;
2597
2598   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2599     info = get_itbl(p);
2600     link = STATIC_LINK(info, p);
2601     STATIC_LINK(info,p) = NULL;
2602   }
2603 }
2604
2605 /* This function is only needed because we share the mutable link
2606  * field with the static link field in an IND_STATIC, so we have to
2607  * zero the mut_link field before doing a major GC, which needs the
2608  * static link field.
2609  *
2610  * It doesn't do any harm to zero all the mutable link fields on the
2611  * mutable list.
2612  */
2613 static void
2614 zero_mutable_list( StgMutClosure *first )
2615 {
2616   StgMutClosure *next, *c;
2617
2618   for (c = first; c != END_MUT_LIST; c = next) {
2619     next = c->mut_link;
2620     c->mut_link = NULL;
2621   }
2622 }
2623
2624 /* -----------------------------------------------------------------------------
2625    Reverting CAFs
2626    -------------------------------------------------------------------------- */
2627
2628 void RevertCAFs(void)
2629 {
2630   while (enteredCAFs != END_CAF_LIST) {
2631     StgCAF* caf = enteredCAFs;
2632
2633     enteredCAFs = caf->link;
2634     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2635     SET_INFO(caf,&CAF_UNENTERED_info);
2636     caf->value = stgCast(StgClosure*,0xdeadbeef);
2637     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2638   }
2639   enteredCAFs = END_CAF_LIST;
2640 }
2641
2642 void revert_dead_CAFs(void)
2643 {
2644     StgCAF* caf = enteredCAFs;
2645     enteredCAFs = END_CAF_LIST;
2646     while (caf != END_CAF_LIST) {
2647         StgCAF *next, *new;
2648         next = caf->link;
2649         new = (StgCAF*)isAlive((StgClosure*)caf);
2650         if (new) {
2651            new->link = enteredCAFs;
2652            enteredCAFs = new;
2653         } else {
2654            ASSERT(0);
2655            SET_INFO(caf,&CAF_UNENTERED_info);
2656            caf->value = (StgClosure*)0xdeadbeef;
2657            caf->link  = (StgCAF*)0xdeadbeef;
2658         }
2659         caf = next;
2660     }
2661 }
2662
2663 /* -----------------------------------------------------------------------------
2664    Sanity code for CAF garbage collection.
2665
2666    With DEBUG turned on, we manage a CAF list in addition to the SRT
2667    mechanism.  After GC, we run down the CAF list and blackhole any
2668    CAFs which have been garbage collected.  This means we get an error
2669    whenever the program tries to enter a garbage collected CAF.
2670
2671    Any garbage collected CAFs are taken off the CAF list at the same
2672    time.
2673    -------------------------------------------------------------------------- */
2674
2675 #ifdef DEBUG
2676 static void
2677 gcCAFs(void)
2678 {
2679   StgClosure*  p;
2680   StgClosure** pp;
2681   const StgInfoTable *info;
2682   nat i;
2683
2684   i = 0;
2685   p = caf_list;
2686   pp = &caf_list;
2687
2688   while (p != NULL) {
2689
2690     info = get_itbl(p);
2691
2692     ASSERT(info->type == IND_STATIC);
2693
2694     if (STATIC_LINK(info,p) == NULL) {
2695       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2696       /* black hole it */
2697       SET_INFO(p,&BLACKHOLE_info);
2698       p = STATIC_LINK2(info,p);
2699       *pp = p;
2700     }
2701     else {
2702       pp = &STATIC_LINK2(info,p);
2703       p = *pp;
2704       i++;
2705     }
2706
2707   }
2708
2709   /*  fprintf(stderr, "%d CAFs live\n", i); */
2710 }
2711 #endif
2712
2713 /* -----------------------------------------------------------------------------
2714    Lazy black holing.
2715
2716    Whenever a thread returns to the scheduler after possibly doing
2717    some work, we have to run down the stack and black-hole all the
2718    closures referred to by update frames.
2719    -------------------------------------------------------------------------- */
2720
2721 static void
2722 threadLazyBlackHole(StgTSO *tso)
2723 {
2724   StgUpdateFrame *update_frame;
2725   StgBlockingQueue *bh;
2726   StgPtr stack_end;
2727
2728   stack_end = &tso->stack[tso->stack_size];
2729   update_frame = tso->su;
2730
2731   while (1) {
2732     switch (get_itbl(update_frame)->type) {
2733
2734     case CATCH_FRAME:
2735       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2736       break;
2737
2738     case UPDATE_FRAME:
2739       bh = (StgBlockingQueue *)update_frame->updatee;
2740
2741       /* if the thunk is already blackholed, it means we've also
2742        * already blackholed the rest of the thunks on this stack,
2743        * so we can stop early.
2744        *
2745        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
2746        * don't interfere with this optimisation.
2747        */
2748       if (bh->header.info == &BLACKHOLE_info) {
2749         return;
2750       }
2751
2752       if (bh->header.info != &BLACKHOLE_BQ_info &&
2753           bh->header.info != &CAF_BLACKHOLE_info) {
2754 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
2755         fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
2756 #endif
2757         SET_INFO(bh,&BLACKHOLE_info);
2758       }
2759
2760       update_frame = update_frame->link;
2761       break;
2762
2763     case SEQ_FRAME:
2764       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2765       break;
2766
2767     case STOP_FRAME:
2768       return;
2769     default:
2770       barf("threadPaused");
2771     }
2772   }
2773 }
2774
2775 /* -----------------------------------------------------------------------------
2776  * Stack squeezing
2777  *
2778  * Code largely pinched from old RTS, then hacked to bits.  We also do
2779  * lazy black holing here.
2780  *
2781  * -------------------------------------------------------------------------- */
2782
2783 static void
2784 threadSqueezeStack(StgTSO *tso)
2785 {
2786   lnat displacement = 0;
2787   StgUpdateFrame *frame;
2788   StgUpdateFrame *next_frame;                   /* Temporally next */
2789   StgUpdateFrame *prev_frame;                   /* Temporally previous */
2790   StgPtr bottom;
2791   rtsBool prev_was_update_frame;
2792
2793   bottom = &(tso->stack[tso->stack_size]);
2794   frame  = tso->su;
2795
2796   /* There must be at least one frame, namely the STOP_FRAME.
2797    */
2798   ASSERT((P_)frame < bottom);
2799
2800   /* Walk down the stack, reversing the links between frames so that
2801    * we can walk back up as we squeeze from the bottom.  Note that
2802    * next_frame and prev_frame refer to next and previous as they were
2803    * added to the stack, rather than the way we see them in this
2804    * walk. (It makes the next loop less confusing.)
2805    *
2806    * Stop if we find an update frame pointing to a black hole
2807    * (see comment in threadLazyBlackHole()).
2808    */
2809
2810   next_frame = NULL;
2811   /* bottom - sizeof(StgStopFrame) is the STOP_FRAME */
2812   while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
2813     prev_frame = frame->link;
2814     frame->link = next_frame;
2815     next_frame = frame;
2816     frame = prev_frame;
2817     if (get_itbl(frame)->type == UPDATE_FRAME
2818         && frame->updatee->header.info == &BLACKHOLE_info) {
2819         break;
2820     }
2821   }
2822
2823   /* Now, we're at the bottom.  Frame points to the lowest update
2824    * frame on the stack, and its link actually points to the frame
2825    * above. We have to walk back up the stack, squeezing out empty
2826    * update frames and turning the pointers back around on the way
2827    * back up.
2828    *
2829    * The bottom-most frame (the STOP_FRAME) has not been altered, and
2830    * we never want to eliminate it anyway.  Just walk one step up
2831    * before starting to squeeze. When you get to the topmost frame,
2832    * remember that there are still some words above it that might have
2833    * to be moved.
2834    */
2835
2836   prev_frame = frame;
2837   frame = next_frame;
2838
2839   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2840
2841   /*
2842    * Loop through all of the frames (everything except the very
2843    * bottom).  Things are complicated by the fact that we have
2844    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2845    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2846    */
2847   while (frame != NULL) {
2848     StgPtr sp;
2849     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2850     rtsBool is_update_frame;
2851
2852     next_frame = frame->link;
2853     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2854
2855     /* Check to see if
2856      *   1. both the previous and current frame are update frames
2857      *   2. the current frame is empty
2858      */
2859     if (prev_was_update_frame && is_update_frame &&
2860         (P_)prev_frame == frame_bottom + displacement) {
2861
2862       /* Now squeeze out the current frame */
2863       StgClosure *updatee_keep   = prev_frame->updatee;
2864       StgClosure *updatee_bypass = frame->updatee;
2865
2866 #if 0 /* DEBUG */
2867       fprintf(stderr, "squeezing frame at %p\n", frame);
2868 #endif
2869
2870       /* Deal with blocking queues.  If both updatees have blocked
2871        * threads, then we should merge the queues into the update
2872        * frame that we're keeping.
2873        *
2874        * Alternatively, we could just wake them up: they'll just go
2875        * straight to sleep on the proper blackhole!  This is less code
2876        * and probably less bug prone, although it's probably much
2877        * slower --SDM
2878        */
2879 #if 0 /* do it properly... */
2880 #  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
2881 #    error Unimplemented lazy BH warning.  (KSW 1999-01)
2882 #  endif
2883       if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info
2884           || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
2885           ) {
2886         /* Sigh.  It has one.  Don't lose those threads! */
2887           if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
2888           /* Urgh.  Two queues.  Merge them. */
2889           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
2890
2891           while (keep_tso->link != END_TSO_QUEUE) {
2892             keep_tso = keep_tso->link;
2893           }
2894           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
2895
2896         } else {
2897           /* For simplicity, just swap the BQ for the BH */
2898           P_ temp = updatee_keep;
2899
2900           updatee_keep = updatee_bypass;
2901           updatee_bypass = temp;
2902
2903           /* Record the swap in the kept frame (below) */
2904           prev_frame->updatee = updatee_keep;
2905         }
2906       }
2907 #endif
2908
2909       TICK_UPD_SQUEEZED();
2910       /* wasn't there something about update squeezing and ticky to be sorted out?
2911        * oh yes: we aren't counting each enter properly in this case.  See the log somewhere.
2912        * KSW 1999-04-21 */
2913       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2914
2915       sp = (P_)frame - 1;       /* sp = stuff to slide */
2916       displacement += sizeofW(StgUpdateFrame);
2917
2918     } else {
2919       /* No squeeze for this frame */
2920       sp = frame_bottom - 1;    /* Keep the current frame */
2921
2922       /* Do lazy black-holing.
2923        */
2924       if (is_update_frame) {
2925         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
2926         if (bh->header.info != &BLACKHOLE_BQ_info &&
2927             bh->header.info != &CAF_BLACKHOLE_info) {
2928 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
2929           fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
2930 #endif
2931           SET_INFO(bh,&BLACKHOLE_info);
2932         }
2933       }
2934
2935       /* Fix the link in the current frame (should point to the frame below) */
2936       frame->link = prev_frame;
2937       prev_was_update_frame = is_update_frame;
2938     }
2939
2940     /* Now slide all words from sp up to the next frame */
2941
2942     if (displacement > 0) {
2943       P_ next_frame_bottom;
2944
2945       if (next_frame != NULL)
2946         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2947       else
2948         next_frame_bottom = tso->sp - 1;
2949
2950 #if 0 /* DEBUG */
2951       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2952               displacement);
2953 #endif
2954
2955       while (sp >= next_frame_bottom) {
2956         sp[displacement] = *sp;
2957         sp -= 1;
2958       }
2959     }
2960     (P_)prev_frame = (P_)frame + displacement;
2961     frame = next_frame;
2962   }
2963
2964   tso->sp += displacement;
2965   tso->su = prev_frame;
2966 }
2967
2968 /* -----------------------------------------------------------------------------
2969  * Pausing a thread
2970  *
2971  * We have to prepare for GC - this means doing lazy black holing
2972  * here.  We also take the opportunity to do stack squeezing if it's
2973  * turned on.
2974  * -------------------------------------------------------------------------- */
2975
2976 void
2977 threadPaused(StgTSO *tso)
2978 {
2979   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2980     threadSqueezeStack(tso);    /* does black holing too */
2981   else
2982     threadLazyBlackHole(tso);
2983 }