ghc/rts/GC.c

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