ghc/rts/GC.c

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