ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.114 2001/08/07 09:20:52 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 "BlockAlloc.h"
  20 #include "MBlock.h"
  21 #include "Main.h"
  22 #include "ProfHeap.h"
  23 #include "SchedAPI.h"
  24 #include "Weak.h"
  25 #include "StablePriv.h"
  26 #include "Prelude.h"
  27 #include "ParTicky.h"           // ToDo: move into Rts.h
  28 #include "GCCompact.h"
  29 #if defined(GRAN) || defined(PAR)
  30 # include "GranSimRts.h"
  31 # include "ParallelRts.h"
  32 # include "FetchMe.h"
  33 # if defined(DEBUG)
  34 #  include "Printer.h"
  35 #  include "ParallelDebug.h"
  36 # endif
  37 #endif
  38 #include "HsFFI.h"
  39 #include "Linker.h"
  40 #if defined(RTS_GTK_FRONTPANEL)
  41 #include "FrontPanel.h"
  42 #endif
  43
  44 /* STATIC OBJECT LIST.
  45  *
  46  * During GC:
  47  * We maintain a linked list of static objects that are still live.
  48  * The requirements for this list are:
  49  *
  50  *  - we need to scan the list while adding to it, in order to
  51  *    scavenge all the static objects (in the same way that
  52  *    breadth-first scavenging works for dynamic objects).
  53  *
  54  *  - we need to be able to tell whether an object is already on
  55  *    the list, to break loops.
  56  *
  57  * Each static object has a "static link field", which we use for
  58  * linking objects on to the list.  We use a stack-type list, consing
  59  * objects on the front as they are added (this means that the
  60  * scavenge phase is depth-first, not breadth-first, but that
  61  * shouldn't matter).
  62  *
  63  * A separate list is kept for objects that have been scavenged
  64  * already - this is so that we can zero all the marks afterwards.
  65  *
  66  * An object is on the list if its static link field is non-zero; this
  67  * means that we have to mark the end of the list with '1', not NULL.
  68  *
  69  * Extra notes for generational GC:
  70  *
  71  * Each generation has a static object list associated with it.  When
  72  * collecting generations up to N, we treat the static object lists
  73  * from generations > N as roots.
  74  *
  75  * We build up a static object list while collecting generations 0..N,
  76  * which is then appended to the static object list of generation N+1.
  77  */
  78 StgClosure* static_objects;           // live static objects
  79 StgClosure* scavenged_static_objects; // static objects scavenged so far
  80
  81 /* N is the oldest generation being collected, where the generations
  82  * are numbered starting at 0.  A major GC (indicated by the major_gc
  83  * flag) is when we're collecting all generations.  We only attempt to
  84  * deal with static objects and GC CAFs when doing a major GC.
  85  */
  86 static nat N;
  87 static rtsBool major_gc;
  88
  89 /* Youngest generation that objects should be evacuated to in
  90  * evacuate().  (Logically an argument to evacuate, but it's static
  91  * a lot of the time so we optimise it into a global variable).
  92  */
  93 static nat evac_gen;
  94
  95 /* Weak pointers
  96  */
  97 StgWeak *old_weak_ptr_list; // also pending finaliser list
  98 static rtsBool weak_done;          // all done for this pass
  99
 100 /* List of all threads during GC
 101  */
 102 static StgTSO *old_all_threads;
 103 static StgTSO *resurrected_threads;
 104
 105 /* Flag indicating failure to evacuate an object to the desired
 106  * generation.
 107  */
 108 static rtsBool failed_to_evac;
 109
 110 /* Old to-space (used for two-space collector only)
 111  */
 112 bdescr *old_to_blocks;
 113
 114 /* Data used for allocation area sizing.
 115  */
 116 lnat new_blocks;                // blocks allocated during this GC
 117 lnat g0s0_pcnt_kept = 30;       // percentage of g0s0 live at last minor GC
 118
 119 /* Used to avoid long recursion due to selector thunks
 120  */
 121 lnat thunk_selector_depth = 0;
 122 #define MAX_THUNK_SELECTOR_DEPTH 256
 123
 124 /* -----------------------------------------------------------------------------
 125    Static function declarations
 126    -------------------------------------------------------------------------- */
 127
 128 static void         mark_root               ( StgClosure **root );
 129 static StgClosure * evacuate                ( StgClosure *q );
 130 static void         zero_static_object_list ( StgClosure* first_static );
 131 static void         zero_mutable_list       ( StgMutClosure *first );
 132
 133 static rtsBool      traverse_weak_ptr_list  ( void );
 134 static void         mark_weak_ptr_list      ( StgWeak **list );
 135
 136 static void         scavenge                ( step * );
 137 static void         scavenge_mark_stack     ( void );
 138 static void         scavenge_stack          ( StgPtr p, StgPtr stack_end );
 139 static rtsBool      scavenge_one            ( StgPtr p );
 140 static void         scavenge_large          ( step * );
 141 static void         scavenge_static         ( void );
 142 static void         scavenge_mutable_list   ( generation *g );
 143 static void         scavenge_mut_once_list  ( generation *g );
 144 static void         scavengeCAFs            ( void );
 145
 146 #if 0 && defined(DEBUG)
 147 static void         gcCAFs                  ( void );
 148 #endif
 149
 150 /* -----------------------------------------------------------------------------
 151    inline functions etc. for dealing with the mark bitmap & stack.
 152    -------------------------------------------------------------------------- */
 153
 154 #define MARK_STACK_BLOCKS 4
 155
 156 static bdescr *mark_stack_bdescr;
 157 static StgPtr *mark_stack;
 158 static StgPtr *mark_sp;
 159 static StgPtr *mark_splim;
 160
 161 // Flag and pointers used for falling back to a linear scan when the
 162 // mark stack overflows.
 163 static rtsBool mark_stack_overflowed;
 164 static bdescr *oldgen_scan_bd;
 165 static StgPtr  oldgen_scan;
 166
 167 static inline rtsBool
 168 mark_stack_empty(void)
 169 {
 170     return mark_sp == mark_stack;
 171 }
 172
 173 static inline rtsBool
 174 mark_stack_full(void)
 175 {
 176     return mark_sp >= mark_splim;
 177 }
 178
 179 static inline void
 180 reset_mark_stack(void)
 181 {
 182     mark_sp = mark_stack;
 183 }
 184
 185 static inline void
 186 push_mark_stack(StgPtr p)
 187 {
 188     *mark_sp++ = p;
 189 }
 190
 191 static inline StgPtr
 192 pop_mark_stack(void)
 193 {
 194     return *--mark_sp;
 195 }
 196
 197 /* -----------------------------------------------------------------------------
 198    GarbageCollect
 199
 200    For garbage collecting generation N (and all younger generations):
 201
 202      - follow all pointers in the root set.  the root set includes all
 203        mutable objects in all steps in all generations.
 204
 205      - for each pointer, evacuate the object it points to into either
 206        + to-space in the next higher step in that generation, if one exists,
 207        + if the object's generation == N, then evacuate it to the next
 208          generation if one exists, or else to-space in the current
 209          generation.
 210        + if the object's generation < N, then evacuate it to to-space
 211          in the next generation.
 212
 213      - repeatedly scavenge to-space from each step in each generation
 214        being collected until no more objects can be evacuated.
 215
 216      - free from-space in each step, and set from-space = to-space.
 217
 218    -------------------------------------------------------------------------- */
 219
 220 void
 221 GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
 222 {
 223   bdescr *bd;
 224   step *stp;
 225   lnat live, allocated, collected = 0, copied = 0;
 226   lnat oldgen_saved_blocks = 0;
 227   nat g, s;
 228
 229 #ifdef PROFILING
 230   CostCentreStack *prev_CCS;
 231 #endif
 232
 233 #if defined(DEBUG) && defined(GRAN)
 234   IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n",
 235                      Now, Now));
 236 #endif
 237
 238   // tell the stats department that we've started a GC
 239   stat_startGC();
 240
 241   // Init stats and print par specific (timing) info
 242   PAR_TICKY_PAR_START();
 243
 244   // attribute any costs to CCS_GC
 245 #ifdef PROFILING
 246   prev_CCS = CCCS;
 247   CCCS = CCS_GC;
 248 #endif
 249
 250   /* Approximate how much we allocated.
 251    * Todo: only when generating stats?
 252    */
 253   allocated = calcAllocated();
 254
 255   /* Figure out which generation to collect
 256    */
 257   if (force_major_gc) {
 258     N = RtsFlags.GcFlags.generations - 1;
 259     major_gc = rtsTrue;
 260   } else {
 261     N = 0;
 262     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 263       if (generations[g].steps[0].n_blocks +
 264           generations[g].steps[0].n_large_blocks
 265           >= generations[g].max_blocks) {
 266         N = g;
 267       }
 268     }
 269     major_gc = (N == RtsFlags.GcFlags.generations-1);
 270   }
 271
 272 #ifdef RTS_GTK_FRONTPANEL
 273   if (RtsFlags.GcFlags.frontpanel) {
 274       updateFrontPanelBeforeGC(N);
 275   }
 276 #endif
 277
 278   // check stack sanity *before* GC (ToDo: check all threads)
 279 #if defined(GRAN)
 280   // ToDo!: check sanity  IF_DEBUG(sanity, checkTSOsSanity());
 281 #endif
 282   IF_DEBUG(sanity, checkFreeListSanity());
 283
 284   /* Initialise the static object lists
 285    */
 286   static_objects = END_OF_STATIC_LIST;
 287   scavenged_static_objects = END_OF_STATIC_LIST;
 288
 289   /* zero the mutable list for the oldest generation (see comment by
 290    * zero_mutable_list below).
 291    */
 292   if (major_gc) {
 293     zero_mutable_list(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
 294   }
 295
 296   /* Save the old to-space if we're doing a two-space collection
 297    */
 298   if (RtsFlags.GcFlags.generations == 1) {
 299     old_to_blocks = g0s0->to_blocks;
 300     g0s0->to_blocks = NULL;
 301   }
 302
 303   /* Keep a count of how many new blocks we allocated during this GC
 304    * (used for resizing the allocation area, later).
 305    */
 306   new_blocks = 0;
 307
 308   /* Initialise to-space in all the generations/steps that we're
 309    * collecting.
 310    */
 311   for (g = 0; g <= N; g++) {
 312     generations[g].mut_once_list = END_MUT_LIST;
 313     generations[g].mut_list = END_MUT_LIST;
 314
 315     for (s = 0; s < generations[g].n_steps; s++) {
 316
 317       // generation 0, step 0 doesn't need to-space
 318       if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) {
 319         continue;
 320       }
 321
 322       /* Get a free block for to-space.  Extra blocks will be chained on
 323        * as necessary.
 324        */
 325       bd = allocBlock();
 326       stp = &generations[g].steps[s];
 327       ASSERT(stp->gen_no == g);
 328       ASSERT(stp->hp ? Bdescr(stp->hp)->step == stp : rtsTrue);
 329       bd->gen_no = g;
 330       bd->step = stp;
 331       bd->link = NULL;
 332       bd->flags        = BF_EVACUATED;  // it's a to-space block
 333       stp->hp          = bd->start;
 334       stp->hpLim       = stp->hp + BLOCK_SIZE_W;
 335       stp->hp_bd       = bd;
 336       stp->to_blocks   = bd;
 337       stp->n_to_blocks = 1;
 338       stp->scan        = bd->start;
 339       stp->scan_bd     = bd;
 340       stp->new_large_objects = NULL;
 341       stp->scavenged_large_objects = NULL;
 342       stp->n_scavenged_large_blocks = 0;
 343       new_blocks++;
 344       // mark the large objects as not evacuated yet
 345       for (bd = stp->large_objects; bd; bd = bd->link) {
 346         bd->flags = BF_LARGE;
 347       }
 348
 349       // for a compacted step, we need to allocate the bitmap
 350       if (stp->is_compacted) {
 351           nat bitmap_size; // in bytes
 352           bdescr *bitmap_bdescr;
 353           StgWord *bitmap;
 354
 355           bitmap_size = stp->n_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);
 356
 357           if (bitmap_size > 0) {
 358               bitmap_bdescr = allocGroup((nat)BLOCK_ROUND_UP(bitmap_size)
 359                                          / BLOCK_SIZE);
 360               stp->bitmap = bitmap_bdescr;
 361               bitmap = bitmap_bdescr->start;
 362
 363               IF_DEBUG(gc, belch("bitmap_size: %d, bitmap: %p",
 364                                    bitmap_size, bitmap););
 365
 366               // don't forget to fill it with zeros!
 367               memset(bitmap, 0, bitmap_size);
 368
 369               // for each block in this step, point to its bitmap from the
 370               // block descriptor.
 371               for (bd=stp->blocks; bd != NULL; bd = bd->link) {
 372                   bd->u.bitmap = bitmap;
 373                   bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
 374               }
 375           }
 376       }
 377     }
 378   }
 379
 380   /* make sure the older generations have at least one block to
 381    * allocate into (this makes things easier for copy(), see below.
 382    */
 383   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 384     for (s = 0; s < generations[g].n_steps; s++) {
 385       stp = &generations[g].steps[s];
 386       if (stp->hp_bd == NULL) {
 387           ASSERT(stp->blocks == NULL);
 388           bd = allocBlock();
 389           bd->gen_no = g;
 390           bd->step = stp;
 391           bd->link = NULL;
 392           bd->flags = 0;        // *not* a to-space block or a large object
 393           stp->hp = bd->start;
 394           stp->hpLim = stp->hp + BLOCK_SIZE_W;
 395           stp->hp_bd = bd;
 396           stp->blocks = bd;
 397           stp->n_blocks = 1;
 398           new_blocks++;
 399       }
 400       /* Set the scan pointer for older generations: remember we
 401        * still have to scavenge objects that have been promoted. */
 402       stp->scan = stp->hp;
 403       stp->scan_bd = stp->hp_bd;
 404       stp->to_blocks = NULL;
 405       stp->n_to_blocks = 0;
 406       stp->new_large_objects = NULL;
 407       stp->scavenged_large_objects = NULL;
 408       stp->n_scavenged_large_blocks = 0;
 409     }
 410   }
 411
 412   /* Allocate a mark stack if we're doing a major collection.
 413    */
 414   if (major_gc) {
 415       mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
 416       mark_stack = (StgPtr *)mark_stack_bdescr->start;
 417       mark_sp    = mark_stack;
 418       mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
 419   } else {
 420       mark_stack_bdescr = NULL;
 421   }
 422
 423   /* -----------------------------------------------------------------------
 424    * follow all the roots that we know about:
 425    *   - mutable lists from each generation > N
 426    * we want to *scavenge* these roots, not evacuate them: they're not
 427    * going to move in this GC.
 428    * Also: do them in reverse generation order.  This is because we
 429    * often want to promote objects that are pointed to by older
 430    * generations early, so we don't have to repeatedly copy them.
 431    * Doing the generations in reverse order ensures that we don't end
 432    * up in the situation where we want to evac an object to gen 3 and
 433    * it has already been evaced to gen 2.
 434    */
 435   {
 436     int st;
 437     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 438       generations[g].saved_mut_list = generations[g].mut_list;
 439       generations[g].mut_list = END_MUT_LIST;
 440     }
 441
 442     // Do the mut-once lists first
 443     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 444       IF_PAR_DEBUG(verbose,
 445                    printMutOnceList(&generations[g]));
 446       scavenge_mut_once_list(&generations[g]);
 447       evac_gen = g;
 448       for (st = generations[g].n_steps-1; st >= 0; st--) {
 449         scavenge(&generations[g].steps[st]);
 450       }
 451     }
 452
 453     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 454       IF_PAR_DEBUG(verbose,
 455                    printMutableList(&generations[g]));
 456       scavenge_mutable_list(&generations[g]);
 457       evac_gen = g;
 458       for (st = generations[g].n_steps-1; st >= 0; st--) {
 459         scavenge(&generations[g].steps[st]);
 460       }
 461     }
 462   }
 463
 464   scavengeCAFs();
 465
 466   /* follow all the roots that the application knows about.
 467    */
 468   evac_gen = 0;
 469   get_roots(mark_root);
 470
 471 #if defined(PAR)
 472   /* And don't forget to mark the TSO if we got here direct from
 473    * Haskell! */
 474   /* Not needed in a seq version?
 475   if (CurrentTSO) {
 476     CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
 477   }
 478   */
 479
 480   // Mark the entries in the GALA table of the parallel system
 481   markLocalGAs(major_gc);
 482   // Mark all entries on the list of pending fetches
 483   markPendingFetches(major_gc);
 484 #endif
 485
 486   /* Mark the weak pointer list, and prepare to detect dead weak
 487    * pointers.
 488    */
 489   mark_weak_ptr_list(&weak_ptr_list);
 490   old_weak_ptr_list = weak_ptr_list;
 491   weak_ptr_list = NULL;
 492   weak_done = rtsFalse;
 493
 494   /* The all_threads list is like the weak_ptr_list.
 495    * See traverse_weak_ptr_list() for the details.
 496    */
 497   old_all_threads = all_threads;
 498   all_threads = END_TSO_QUEUE;
 499   resurrected_threads = END_TSO_QUEUE;
 500
 501   /* Mark the stable pointer table.
 502    */
 503   markStablePtrTable(mark_root);
 504
 505 #ifdef INTERPRETER
 506   {
 507       /* ToDo: To fix the caf leak, we need to make the commented out
 508        * parts of this code do something sensible - as described in
 509        * the CAF document.
 510        */
 511       extern void markHugsObjects(void);
 512       markHugsObjects();
 513   }
 514 #endif
 515
 516   /* -------------------------------------------------------------------------
 517    * Repeatedly scavenge all the areas we know about until there's no
 518    * more scavenging to be done.
 519    */
 520   {
 521     rtsBool flag;
 522   loop:
 523     flag = rtsFalse;
 524
 525     // scavenge static objects
 526     if (major_gc && static_objects != END_OF_STATIC_LIST) {
 527         IF_DEBUG(sanity, checkStaticObjects(static_objects));
 528         scavenge_static();
 529     }
 530
 531     /* When scavenging the older generations:  Objects may have been
 532      * evacuated from generations <= N into older generations, and we
 533      * need to scavenge these objects.  We're going to try to ensure that
 534      * any evacuations that occur move the objects into at least the
 535      * same generation as the object being scavenged, otherwise we
 536      * have to create new entries on the mutable list for the older
 537      * generation.
 538      */
 539
 540     // scavenge each step in generations 0..maxgen
 541     {
 542       long gen;
 543       int st;
 544
 545     loop2:
 546       // scavenge objects in compacted generation
 547       if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
 548           (mark_stack_bdescr != NULL && !mark_stack_empty())) {
 549           scavenge_mark_stack();
 550           flag = rtsTrue;
 551       }
 552
 553       for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
 554         for (st = generations[gen].n_steps; --st >= 0; ) {
 555           if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) {
 556             continue;
 557           }
 558           stp = &generations[gen].steps[st];
 559           evac_gen = gen;
 560           if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
 561             scavenge(stp);
 562             flag = rtsTrue;
 563             goto loop2;
 564           }
 565           if (stp->new_large_objects != NULL) {
 566             scavenge_large(stp);
 567             flag = rtsTrue;
 568             goto loop2;
 569           }
 570         }
 571       }
 572     }
 573
 574     if (flag) { goto loop; }
 575
 576     // must be last...
 577     if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something
 578       goto loop;
 579     }
 580   }
 581
 582 #if defined(PAR)
 583   // Reconstruct the Global Address tables used in GUM
 584   rebuildGAtables(major_gc);
 585   IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
 586 #endif
 587
 588   // Now see which stable names are still alive.
 589   gcStablePtrTable();
 590
 591   // Tidy the end of the to-space chains
 592   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 593       for (s = 0; s < generations[g].n_steps; s++) {
 594           stp = &generations[g].steps[s];
 595           if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 596               stp->hp_bd->free = stp->hp;
 597               stp->hp_bd->link = NULL;
 598           }
 599       }
 600   }
 601
 602   // NO MORE EVACUATION AFTER THIS POINT!
 603   // Finally: compaction of the oldest generation.
 604   if (major_gc && oldest_gen->steps[0].is_compacted) {
 605       // save number of blocks for stats
 606       oldgen_saved_blocks = oldest_gen->steps[0].n_blocks;
 607       compact(get_roots);
 608   }
 609
 610   IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));
 611
 612   /* run through all the generations/steps and tidy up
 613    */
 614   copied = new_blocks * BLOCK_SIZE_W;
 615   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 616
 617     if (g <= N) {
 618       generations[g].collections++; // for stats
 619     }
 620
 621     for (s = 0; s < generations[g].n_steps; s++) {
 622       bdescr *next;
 623       stp = &generations[g].steps[s];
 624
 625       if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
 626         // stats information: how much we copied
 627         if (g <= N) {
 628           copied -= stp->hp_bd->start + BLOCK_SIZE_W -
 629             stp->hp_bd->free;
 630         }
 631       }
 632
 633       // for generations we collected...
 634       if (g <= N) {
 635
 636           // rough calculation of garbage collected, for stats output
 637           if (stp->is_compacted) {
 638               collected += (oldgen_saved_blocks - stp->n_blocks) * BLOCK_SIZE_W;
 639           } else {
 640               collected += stp->n_blocks * BLOCK_SIZE_W;
 641           }
 642
 643         /* free old memory and shift to-space into from-space for all
 644          * the collected steps (except the allocation area).  These
 645          * freed blocks will probaby be quickly recycled.
 646          */
 647         if (!(g == 0 && s == 0)) {
 648             if (stp->is_compacted) {
 649                 // for a compacted step, just shift the new to-space
 650                 // onto the front of the now-compacted existing blocks.
 651                 for (bd = stp->to_blocks; bd != NULL; bd = bd->link) {
 652                     bd->flags &= ~BF_EVACUATED; // now from-space
 653                 }
 654                 // tack the new blocks on the end of the existing blocks
 655                 if (stp->blocks == NULL) {
 656                     stp->blocks = stp->to_blocks;
 657                 } else {
 658                     for (bd = stp->blocks; bd != NULL; bd = next) {
 659                         next = bd->link;
 660                         if (next == NULL) {
 661                             bd->link = stp->to_blocks;
 662                         }
 663                     }
 664                 }
 665                 // add the new blocks to the block tally
 666                 stp->n_blocks += stp->n_to_blocks;
 667             } else {
 668                 freeChain(stp->blocks);
 669                 stp->blocks = stp->to_blocks;
 670                 stp->n_blocks = stp->n_to_blocks;
 671                 for (bd = stp->blocks; bd != NULL; bd = bd->link) {
 672                     bd->flags &= ~BF_EVACUATED; // now from-space
 673                 }
 674             }
 675             stp->to_blocks = NULL;
 676             stp->n_to_blocks = 0;
 677         }
 678
 679         /* LARGE OBJECTS.  The current live large objects are chained on
 680          * scavenged_large, having been moved during garbage
 681          * collection from large_objects.  Any objects left on
 682          * large_objects list are therefore dead, so we free them here.
 683          */
 684         for (bd = stp->large_objects; bd != NULL; bd = next) {
 685           next = bd->link;
 686           freeGroup(bd);
 687           bd = next;
 688         }
 689
 690         // update the count of blocks used by large objects
 691         for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
 692           bd->flags &= ~BF_EVACUATED;
 693         }
 694         stp->large_objects  = stp->scavenged_large_objects;
 695         stp->n_large_blocks = stp->n_scavenged_large_blocks;
 696
 697       } else {
 698         // for older generations...
 699
 700         /* For older generations, we need to append the
 701          * scavenged_large_object list (i.e. large objects that have been
 702          * promoted during this GC) to the large_object list for that step.
 703          */
 704         for (bd = stp->scavenged_large_objects; bd; bd = next) {
 705           next = bd->link;
 706           bd->flags &= ~BF_EVACUATED;
 707           dbl_link_onto(bd, &stp->large_objects);
 708         }
 709
 710         // add the new blocks we promoted during this GC
 711         stp->n_blocks += stp->n_to_blocks;
 712         stp->n_large_blocks += stp->n_scavenged_large_blocks;
 713       }
 714     }
 715   }
 716
 717   /* Reset the sizes of the older generations when we do a major
 718    * collection.
 719    *
 720    * CURRENT STRATEGY: make all generations except zero the same size.
 721    * We have to stay within the maximum heap size, and leave a certain
 722    * percentage of the maximum heap size available to allocate into.
 723    */
 724   if (major_gc && RtsFlags.GcFlags.generations > 1) {
 725       nat live, size, min_alloc;
 726       nat max  = RtsFlags.GcFlags.maxHeapSize;
 727       nat gens = RtsFlags.GcFlags.generations;
 728
 729       // live in the oldest generations
 730       live = oldest_gen->steps[0].n_blocks +
 731              oldest_gen->steps[0].n_large_blocks;
 732
 733       // default max size for all generations except zero
 734       size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
 735                      RtsFlags.GcFlags.minOldGenSize);
 736
 737       // minimum size for generation zero
 738       min_alloc = (RtsFlags.GcFlags.pcFreeHeap * max) / 200;
 739
 740       // if we're going to go over the maximum heap size, reduce the
 741       // size of the generations accordingly.  The calculation is
 742       // different if compaction is turned on, because we don't need
 743       // to double the space required to collect the old generation.
 744       if (max != 0) {
 745           if (RtsFlags.GcFlags.compact) {
 746               if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
 747                   size = (max - min_alloc) / ((gens - 1) * 2 - 1);
 748               }
 749           } else {
 750               if ( (size * (gens - 1) * 2) + min_alloc > max ) {
 751                   size = (max - min_alloc) / ((gens - 1) * 2);
 752               }
 753           }
 754
 755           if (size < live) {
 756               heapOverflow();
 757           }
 758       }
 759
 760 #if 0
 761       fprintf(stderr,"live: %d, min_alloc: %d, size : %d, max = %d\n", live,
 762               min_alloc, size, max);
 763 #endif
 764
 765       for (g = 0; g < gens; g++) {
 766           generations[g].max_blocks = size;
 767       }
 768
 769       // Auto-enable compaction when the residency reaches a
 770       // certain percentage of the maximum heap size (default: 30%).
 771       if (RtsFlags.GcFlags.compact &&
 772           oldest_gen->steps[0].n_blocks >
 773             (RtsFlags.GcFlags.compactThreshold * max) / 100) {
 774           oldest_gen->steps[0].is_compacted = 1;
 775 //        fprintf(stderr,"compaction: on\n", live);
 776       } else {
 777           oldest_gen->steps[0].is_compacted = 0;
 778 //        fprintf(stderr,"compaction: off\n", live);
 779       }
 780   }
 781
 782   // Guess the amount of live data for stats.
 783   live = calcLive();
 784
 785   /* Free the small objects allocated via allocate(), since this will
 786    * all have been copied into G0S1 now.
 787    */
 788   if (small_alloc_list != NULL) {
 789     freeChain(small_alloc_list);
 790   }
 791   small_alloc_list = NULL;
 792   alloc_blocks = 0;
 793   alloc_Hp = NULL;
 794   alloc_HpLim = NULL;
 795   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 796
 797   /* Free the mark stack.
 798    */
 799   if (mark_stack_bdescr != NULL) {
 800       freeGroup(mark_stack_bdescr);
 801   }
 802
 803   /* Free any bitmaps.
 804    */
 805   for (g = 0; g <= N; g++) {
 806       for (s = 0; s < generations[g].n_steps; s++) {
 807           stp = &generations[g].steps[s];
 808           if (stp->is_compacted && stp->bitmap != NULL) {
 809               freeGroup(stp->bitmap);
 810           }
 811       }
 812   }
 813
 814   /* Two-space collector:
 815    * Free the old to-space, and estimate the amount of live data.
 816    */
 817   if (RtsFlags.GcFlags.generations == 1) {
 818     nat blocks;
 819
 820     if (old_to_blocks != NULL) {
 821       freeChain(old_to_blocks);
 822     }
 823     for (bd = g0s0->to_blocks; bd != NULL; bd = bd->link) {
 824       bd->flags = 0;    // now from-space
 825     }
 826
 827     /* For a two-space collector, we need to resize the nursery. */
 828
 829     /* set up a new nursery.  Allocate a nursery size based on a
 830      * function of the amount of live data (by default a factor of 2)
 831      * Use the blocks from the old nursery if possible, freeing up any
 832      * left over blocks.
 833      *
 834      * If we get near the maximum heap size, then adjust our nursery
 835      * size accordingly.  If the nursery is the same size as the live
 836      * data (L), then we need 3L bytes.  We can reduce the size of the
 837      * nursery to bring the required memory down near 2L bytes.
 838      *
 839      * A normal 2-space collector would need 4L bytes to give the same
 840      * performance we get from 3L bytes, reducing to the same
 841      * performance at 2L bytes.
 842      */
 843     blocks = g0s0->n_to_blocks;
 844
 845     if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 >
 846          RtsFlags.GcFlags.maxHeapSize ) {
 847       long adjusted_blocks;  // signed on purpose
 848       int pc_free;
 849
 850       adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
 851       IF_DEBUG(gc, belch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
 852       pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
 853       if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
 854         heapOverflow();
 855       }
 856       blocks = adjusted_blocks;
 857
 858     } else {
 859       blocks *= RtsFlags.GcFlags.oldGenFactor;
 860       if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
 861         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 862       }
 863     }
 864     resizeNursery(blocks);
 865
 866   } else {
 867     /* Generational collector:
 868      * If the user has given us a suggested heap size, adjust our
 869      * allocation area to make best use of the memory available.
 870      */
 871
 872     if (RtsFlags.GcFlags.heapSizeSuggestion) {
 873       long blocks;
 874       nat needed = calcNeeded();        // approx blocks needed at next GC
 875
 876       /* Guess how much will be live in generation 0 step 0 next time.
 877        * A good approximation is obtained by finding the
 878        * percentage of g0s0 that was live at the last minor GC.
 879        */
 880       if (N == 0) {
 881         g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
 882       }
 883
 884       /* Estimate a size for the allocation area based on the
 885        * information available.  We might end up going slightly under
 886        * or over the suggested heap size, but we should be pretty
 887        * close on average.
 888        *
 889        * Formula:            suggested - needed
 890        *                ----------------------------
 891        *                    1 + g0s0_pcnt_kept/100
 892        *
 893        * where 'needed' is the amount of memory needed at the next
 894        * collection for collecting all steps except g0s0.
 895        */
 896       blocks =
 897         (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
 898         (100 + (long)g0s0_pcnt_kept);
 899
 900       if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
 901         blocks = RtsFlags.GcFlags.minAllocAreaSize;
 902       }
 903
 904       resizeNursery((nat)blocks);
 905     }
 906   }
 907
 908  // mark the garbage collected CAFs as dead
 909 #if 0 && defined(DEBUG) // doesn't work at the moment
 910   if (major_gc) { gcCAFs(); }
 911 #endif
 912
 913   // zero the scavenged static object list
 914   if (major_gc) {
 915     zero_static_object_list(scavenged_static_objects);
 916   }
 917
 918   // Reset the nursery
 919   resetNurseries();
 920
 921   // start any pending finalizers
 922   scheduleFinalizers(old_weak_ptr_list);
 923
 924   // send exceptions to any threads which were about to die
 925   resurrectThreads(resurrected_threads);
 926
 927   // Update the stable pointer hash table.
 928   updateStablePtrTable(major_gc);
 929
 930   // check sanity after GC
 931   IF_DEBUG(sanity, checkSanity());
 932
 933   // extra GC trace info
 934   IF_DEBUG(gc, statDescribeGens());
 935
 936 #ifdef DEBUG
 937   // symbol-table based profiling
 938   /*  heapCensus(to_blocks); */ /* ToDo */
 939 #endif
 940
 941   // restore enclosing cost centre
 942 #ifdef PROFILING
 943   heapCensus();
 944   CCCS = prev_CCS;
 945 #endif
 946
 947   // check for memory leaks if sanity checking is on
 948   IF_DEBUG(sanity, memInventory());
 949
 950 #ifdef RTS_GTK_FRONTPANEL
 951   if (RtsFlags.GcFlags.frontpanel) {
 952       updateFrontPanelAfterGC( N, live );
 953   }
 954 #endif
 955
 956   // ok, GC over: tell the stats department what happened.
 957   stat_endGC(allocated, collected, live, copied, N);
 958
 959   //PAR_TICKY_TP();
 960 }
 961
 962
 963 /* -----------------------------------------------------------------------------
 964    Weak Pointers
 965
 966    traverse_weak_ptr_list is called possibly many times during garbage
 967    collection.  It returns a flag indicating whether it did any work
 968    (i.e. called evacuate on any live pointers).
 969
 970    Invariant: traverse_weak_ptr_list is called when the heap is in an
 971    idempotent state.  That means that there are no pending
 972    evacuate/scavenge operations.  This invariant helps the weak
 973    pointer code decide which weak pointers are dead - if there are no
 974    new live weak pointers, then all the currently unreachable ones are
 975    dead.
 976
 977    For generational GC: we just don't try to finalize weak pointers in
 978    older generations than the one we're collecting.  This could
 979    probably be optimised by keeping per-generation lists of weak
 980    pointers, but for a few weak pointers this scheme will work.
 981    -------------------------------------------------------------------------- */
 982
 983 static rtsBool
 984 traverse_weak_ptr_list(void)
 985 {
 986   StgWeak *w, **last_w, *next_w;
 987   StgClosure *new;
 988   rtsBool flag = rtsFalse;
 989
 990   if (weak_done) { return rtsFalse; }
 991
 992   /* doesn't matter where we evacuate values/finalizers to, since
 993    * these pointers are treated as roots (iff the keys are alive).
 994    */
 995   evac_gen = 0;
 996
 997   last_w = &old_weak_ptr_list;
 998   for (w = old_weak_ptr_list; w != NULL; w = next_w) {
 999
1000     /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1001      * called on a live weak pointer object.  Just remove it.
1002      */
1003     if (w->header.info == &stg_DEAD_WEAK_info) {
1004       next_w = ((StgDeadWeak *)w)->link;
1005       *last_w = next_w;
1006       continue;
1007     }
1008
1009     ASSERT(get_itbl(w)->type == WEAK);
1010
1011     /* Now, check whether the key is reachable.
1012      */
1013     new = isAlive(w->key);
1014     if (new != NULL) {
1015       w->key = new;
1016       // evacuate the value and finalizer
1017       w->value = evacuate(w->value);
1018       w->finalizer = evacuate(w->finalizer);
1019       // remove this weak ptr from the old_weak_ptr list
1020       *last_w = w->link;
1021       // and put it on the new weak ptr list
1022       next_w  = w->link;
1023       w->link = weak_ptr_list;
1024       weak_ptr_list = w;
1025       flag = rtsTrue;
1026       IF_DEBUG(weak, belch("Weak pointer still alive at %p -> %p", w, w->key));
1027       continue;
1028     }
1029     else {
1030       last_w = &(w->link);
1031       next_w = w->link;
1032       continue;
1033     }
1034   }
1035
1036   /* Now deal with the all_threads list, which behaves somewhat like
1037    * the weak ptr list.  If we discover any threads that are about to
1038    * become garbage, we wake them up and administer an exception.
1039    */
1040   {
1041     StgTSO *t, *tmp, *next, **prev;
1042
1043     prev = &old_all_threads;
1044     for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1045
1046       (StgClosure *)tmp = isAlive((StgClosure *)t);
1047
1048       if (tmp != NULL) {
1049           t = tmp;
1050       }
1051
1052       ASSERT(get_itbl(t)->type == TSO);
1053       switch (t->what_next) {
1054       case ThreadRelocated:
1055           next = t->link;
1056           *prev = next;
1057           continue;
1058       case ThreadKilled:
1059       case ThreadComplete:
1060           // finshed or died.  The thread might still be alive, but we
1061           // don't keep it on the all_threads list.  Don't forget to
1062           // stub out its global_link field.
1063           next = t->global_link;
1064           t->global_link = END_TSO_QUEUE;
1065           *prev = next;
1066           continue;
1067       default:
1068           ;
1069       }
1070
1071       if (tmp == NULL) {
1072           // not alive (yet): leave this thread on the old_all_threads list.
1073           prev = &(t->global_link);
1074           next = t->global_link;
1075       }
1076       else {
1077           // alive: move this thread onto the all_threads list.
1078           next = t->global_link;
1079           t->global_link = all_threads;
1080           all_threads  = t;
1081           *prev = next;
1082       }
1083     }
1084   }
1085
1086   /* If we didn't make any changes, then we can go round and kill all
1087    * the dead weak pointers.  The old_weak_ptr list is used as a list
1088    * of pending finalizers later on.
1089    */
1090   if (flag == rtsFalse) {
1091     for (w = old_weak_ptr_list; w; w = w->link) {
1092       w->finalizer = evacuate(w->finalizer);
1093     }
1094
1095     /* And resurrect any threads which were about to become garbage.
1096      */
1097     {
1098       StgTSO *t, *tmp, *next;
1099       for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1100         next = t->global_link;
1101         (StgClosure *)tmp = evacuate((StgClosure *)t);
1102         tmp->global_link = resurrected_threads;
1103         resurrected_threads = tmp;
1104       }
1105     }
1106
1107     weak_done = rtsTrue;
1108   }
1109
1110   return rtsTrue;
1111 }
1112
1113 /* -----------------------------------------------------------------------------
1114    After GC, the live weak pointer list may have forwarding pointers
1115    on it, because a weak pointer object was evacuated after being
1116    moved to the live weak pointer list.  We remove those forwarding
1117    pointers here.
1118
1119    Also, we don't consider weak pointer objects to be reachable, but
1120    we must nevertheless consider them to be "live" and retain them.
1121    Therefore any weak pointer objects which haven't as yet been
1122    evacuated need to be evacuated now.
1123    -------------------------------------------------------------------------- */
1124
1125
1126 static void
1127 mark_weak_ptr_list ( StgWeak **list )
1128 {
1129   StgWeak *w, **last_w;
1130
1131   last_w = list;
1132   for (w = *list; w; w = w->link) {
1133       (StgClosure *)w = evacuate((StgClosure *)w);
1134       *last_w = w;
1135       last_w = &(w->link);
1136   }
1137 }
1138
1139 /* -----------------------------------------------------------------------------
1140    isAlive determines whether the given closure is still alive (after
1141    a garbage collection) or not.  It returns the new address of the
1142    closure if it is alive, or NULL otherwise.
1143
1144    NOTE: Use it before compaction only!
1145    -------------------------------------------------------------------------- */
1146
1147
1148 StgClosure *
1149 isAlive(StgClosure *p)
1150 {
1151   const StgInfoTable *info;
1152   bdescr *bd;
1153
1154   while (1) {
1155
1156     info = get_itbl(p);
1157
1158     /* ToDo: for static closures, check the static link field.
1159      * Problem here is that we sometimes don't set the link field, eg.
1160      * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1161      */
1162
1163   loop:
1164     bd = Bdescr((P_)p);
1165     // ignore closures in generations that we're not collecting.
1166     if (LOOKS_LIKE_STATIC(p) || bd->gen_no > N) {
1167         return p;
1168     }
1169     // large objects have an evacuated flag
1170     if (bd->flags & BF_LARGE) {
1171         if (bd->flags & BF_EVACUATED) {
1172             return p;
1173         } else {
1174             return NULL;
1175         }
1176     }
1177     // check the mark bit for compacted steps
1178     if (bd->step->is_compacted && is_marked((P_)p,bd)) {
1179         return p;
1180     }
1181
1182     switch (info->type) {
1183
1184     case IND:
1185     case IND_STATIC:
1186     case IND_PERM:
1187     case IND_OLDGEN:            // rely on compatible layout with StgInd
1188     case IND_OLDGEN_PERM:
1189       // follow indirections
1190       p = ((StgInd *)p)->indirectee;
1191       continue;
1192
1193     case EVACUATED:
1194       // alive!
1195       return ((StgEvacuated *)p)->evacuee;
1196
1197     case TSO:
1198       if (((StgTSO *)p)->what_next == ThreadRelocated) {
1199         p = (StgClosure *)((StgTSO *)p)->link;
1200         goto loop;
1201       }
1202
1203     default:
1204       // dead.
1205       return NULL;
1206     }
1207   }
1208 }
1209
1210 static void
1211 mark_root(StgClosure **root)
1212 {
1213   *root = evacuate(*root);
1214 }
1215
1216 static void
1217 addBlock(step *stp)
1218 {
1219   bdescr *bd = allocBlock();
1220   bd->gen_no = stp->gen_no;
1221   bd->step = stp;
1222
1223   if (stp->gen_no <= N) {
1224     bd->flags = BF_EVACUATED;
1225   } else {
1226     bd->flags = 0;
1227   }
1228
1229   stp->hp_bd->free = stp->hp;
1230   stp->hp_bd->link = bd;
1231   stp->hp = bd->start;
1232   stp->hpLim = stp->hp + BLOCK_SIZE_W;
1233   stp->hp_bd = bd;
1234   stp->n_to_blocks++;
1235   new_blocks++;
1236 }
1237
1238
1239 static __inline__ void
1240 upd_evacuee(StgClosure *p, StgClosure *dest)
1241 {
1242   p->header.info = &stg_EVACUATED_info;
1243   ((StgEvacuated *)p)->evacuee = dest;
1244 }
1245
1246
1247 static __inline__ StgClosure *
1248 copy(StgClosure *src, nat size, step *stp)
1249 {
1250   P_ to, from, dest;
1251
1252   TICK_GC_WORDS_COPIED(size);
1253   /* Find out where we're going, using the handy "to" pointer in
1254    * the step of the source object.  If it turns out we need to
1255    * evacuate to an older generation, adjust it here (see comment
1256    * by evacuate()).
1257    */
1258   if (stp->gen_no < evac_gen) {
1259 #ifdef NO_EAGER_PROMOTION
1260     failed_to_evac = rtsTrue;
1261 #else
1262     stp = &generations[evac_gen].steps[0];
1263 #endif
1264   }
1265
1266   /* chain a new block onto the to-space for the destination step if
1267    * necessary.
1268    */
1269   if (stp->hp + size >= stp->hpLim) {
1270     addBlock(stp);
1271   }
1272
1273   for(to = stp->hp, from = (P_)src; size>0; --size) {
1274     *to++ = *from++;
1275   }
1276
1277   dest = stp->hp;
1278   stp->hp = to;
1279   upd_evacuee(src,(StgClosure *)dest);
1280   return (StgClosure *)dest;
1281 }
1282
1283 /* Special version of copy() for when we only want to copy the info
1284  * pointer of an object, but reserve some padding after it.  This is
1285  * used to optimise evacuation of BLACKHOLEs.
1286  */
1287
1288
1289 static __inline__ StgClosure *
1290 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1291 {
1292   P_ dest, to, from;
1293
1294   TICK_GC_WORDS_COPIED(size_to_copy);
1295   if (stp->gen_no < evac_gen) {
1296 #ifdef NO_EAGER_PROMOTION
1297     failed_to_evac = rtsTrue;
1298 #else
1299     stp = &generations[evac_gen].steps[0];
1300 #endif
1301   }
1302
1303   if (stp->hp + size_to_reserve >= stp->hpLim) {
1304     addBlock(stp);
1305   }
1306
1307   for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1308     *to++ = *from++;
1309   }
1310
1311   dest = stp->hp;
1312   stp->hp += size_to_reserve;
1313   upd_evacuee(src,(StgClosure *)dest);
1314   return (StgClosure *)dest;
1315 }
1316
1317
1318 /* -----------------------------------------------------------------------------
1319    Evacuate a large object
1320
1321    This just consists of removing the object from the (doubly-linked)
1322    large_alloc_list, and linking it on to the (singly-linked)
1323    new_large_objects list, from where it will be scavenged later.
1324
1325    Convention: bd->flags has BF_EVACUATED set for a large object
1326    that has been evacuated, or unset otherwise.
1327    -------------------------------------------------------------------------- */
1328
1329
1330 static inline void
1331 evacuate_large(StgPtr p)
1332 {
1333   bdescr *bd = Bdescr(p);
1334   step *stp;
1335
1336   // should point to the beginning of the block
1337   ASSERT(((W_)p & BLOCK_MASK) == 0);
1338
1339   // already evacuated?
1340   if (bd->flags & BF_EVACUATED) {
1341     /* Don't forget to set the failed_to_evac flag if we didn't get
1342      * the desired destination (see comments in evacuate()).
1343      */
1344     if (bd->gen_no < evac_gen) {
1345       failed_to_evac = rtsTrue;
1346       TICK_GC_FAILED_PROMOTION();
1347     }
1348     return;
1349   }
1350
1351   stp = bd->step;
1352   // remove from large_object list
1353   if (bd->u.back) {
1354     bd->u.back->link = bd->link;
1355   } else { // first object in the list
1356     stp->large_objects = bd->link;
1357   }
1358   if (bd->link) {
1359     bd->link->u.back = bd->u.back;
1360   }
1361
1362   /* link it on to the evacuated large object list of the destination step
1363    */
1364   stp = bd->step->to;
1365   if (stp->gen_no < evac_gen) {
1366 #ifdef NO_EAGER_PROMOTION
1367     failed_to_evac = rtsTrue;
1368 #else
1369     stp = &generations[evac_gen].steps[0];
1370 #endif
1371   }
1372
1373   bd->step = stp;
1374   bd->gen_no = stp->gen_no;
1375   bd->link = stp->new_large_objects;
1376   stp->new_large_objects = bd;
1377   bd->flags |= BF_EVACUATED;
1378 }
1379
1380 /* -----------------------------------------------------------------------------
1381    Adding a MUT_CONS to an older generation.
1382
1383    This is necessary from time to time when we end up with an
1384    old-to-new generation pointer in a non-mutable object.  We defer
1385    the promotion until the next GC.
1386    -------------------------------------------------------------------------- */
1387
1388
1389 static StgClosure *
1390 mkMutCons(StgClosure *ptr, generation *gen)
1391 {
1392   StgMutVar *q;
1393   step *stp;
1394
1395   stp = &gen->steps[0];
1396
1397   /* chain a new block onto the to-space for the destination step if
1398    * necessary.
1399    */
1400   if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
1401     addBlock(stp);
1402   }
1403
1404   q = (StgMutVar *)stp->hp;
1405   stp->hp += sizeofW(StgMutVar);
1406
1407   SET_HDR(q,&stg_MUT_CONS_info,CCS_GC);
1408   q->var = ptr;
1409   recordOldToNewPtrs((StgMutClosure *)q);
1410
1411   return (StgClosure *)q;
1412 }
1413
1414 /* -----------------------------------------------------------------------------
1415    Evacuate
1416
1417    This is called (eventually) for every live object in the system.
1418
1419    The caller to evacuate specifies a desired generation in the
1420    evac_gen global variable.  The following conditions apply to
1421    evacuating an object which resides in generation M when we're
1422    collecting up to generation N
1423
1424    if  M >= evac_gen
1425            if  M > N     do nothing
1426            else          evac to step->to
1427
1428    if  M < evac_gen      evac to evac_gen, step 0
1429
1430    if the object is already evacuated, then we check which generation
1431    it now resides in.
1432
1433    if  M >= evac_gen     do nothing
1434    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1435                          didn't manage to evacuate this object into evac_gen.
1436
1437    -------------------------------------------------------------------------- */
1438
1439 static StgClosure *
1440 evacuate(StgClosure *q)
1441 {
1442   StgClosure *to;
1443   bdescr *bd = NULL;
1444   step *stp;
1445   const StgInfoTable *info;
1446
1447 loop:
1448   if (HEAP_ALLOCED(q)) {
1449     bd = Bdescr((P_)q);
1450
1451     if (bd->gen_no > N) {
1452         /* Can't evacuate this object, because it's in a generation
1453          * older than the ones we're collecting.  Let's hope that it's
1454          * in evac_gen or older, or we will have to arrange to track
1455          * this pointer using the mutable list.
1456          */
1457         if (bd->gen_no < evac_gen) {
1458             // nope
1459             failed_to_evac = rtsTrue;
1460             TICK_GC_FAILED_PROMOTION();
1461         }
1462         return q;
1463     }
1464
1465     /* evacuate large objects by re-linking them onto a different list.
1466      */
1467     if (bd->flags & BF_LARGE) {
1468         info = get_itbl(q);
1469         if (info->type == TSO &&
1470             ((StgTSO *)q)->what_next == ThreadRelocated) {
1471             q = (StgClosure *)((StgTSO *)q)->link;
1472             goto loop;
1473         }
1474         evacuate_large((P_)q);
1475         return q;
1476     }
1477
1478     /* If the object is in a step that we're compacting, then we
1479      * need to use an alternative evacuate procedure.
1480      */
1481     if (bd->step->is_compacted) {
1482         if (!is_marked((P_)q,bd)) {
1483             mark((P_)q,bd);
1484             if (mark_stack_full()) {
1485                 mark_stack_overflowed = rtsTrue;
1486                 reset_mark_stack();
1487             }
1488             push_mark_stack((P_)q);
1489         }
1490         return q;
1491     }
1492
1493     stp = bd->step->to;
1494   }
1495 #ifdef DEBUG
1496   else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1497 #endif
1498
1499   // make sure the info pointer is into text space
1500   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1501                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1502   info = get_itbl(q);
1503
1504   switch (info -> type) {
1505
1506   case MUT_VAR:
1507   case MVAR:
1508       to = copy(q,sizeW_fromITBL(info),stp);
1509       return to;
1510
1511   case CONSTR_0_1:
1512   {
1513       StgWord w = (StgWord)q->payload[0];
1514       if (q->header.info == Czh_con_info &&
1515           // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&
1516           (StgChar)w <= MAX_CHARLIKE) {
1517           return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1518       }
1519       if (q->header.info == Izh_con_info &&
1520           (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1521           return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1522       }
1523       // else, fall through ...
1524   }
1525
1526   case FUN_1_0:
1527   case FUN_0_1:
1528   case CONSTR_1_0:
1529     return copy(q,sizeofW(StgHeader)+1,stp);
1530
1531   case THUNK_1_0:               // here because of MIN_UPD_SIZE
1532   case THUNK_0_1:
1533   case THUNK_1_1:
1534   case THUNK_0_2:
1535   case THUNK_2_0:
1536 #ifdef NO_PROMOTE_THUNKS
1537     if (bd->gen_no == 0 &&
1538         bd->step->no != 0 &&
1539         bd->step->no == generations[bd->gen_no].n_steps-1) {
1540       stp = bd->step;
1541     }
1542 #endif
1543     return copy(q,sizeofW(StgHeader)+2,stp);
1544
1545   case FUN_1_1:
1546   case FUN_0_2:
1547   case FUN_2_0:
1548   case CONSTR_1_1:
1549   case CONSTR_0_2:
1550   case CONSTR_2_0:
1551     return copy(q,sizeofW(StgHeader)+2,stp);
1552
1553   case FUN:
1554   case THUNK:
1555   case CONSTR:
1556   case IND_PERM:
1557   case IND_OLDGEN_PERM:
1558   case WEAK:
1559   case FOREIGN:
1560   case STABLE_NAME:
1561   case BCO:
1562     return copy(q,sizeW_fromITBL(info),stp);
1563
1564   case CAF_BLACKHOLE:
1565   case SE_CAF_BLACKHOLE:
1566   case SE_BLACKHOLE:
1567   case BLACKHOLE:
1568     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1569
1570   case BLACKHOLE_BQ:
1571     to = copy(q,BLACKHOLE_sizeW(),stp);
1572     return to;
1573
1574   case THUNK_SELECTOR:
1575     {
1576       const StgInfoTable* selectee_info;
1577       StgClosure* selectee = ((StgSelector*)q)->selectee;
1578
1579     selector_loop:
1580       selectee_info = get_itbl(selectee);
1581       switch (selectee_info->type) {
1582       case CONSTR:
1583       case CONSTR_1_0:
1584       case CONSTR_0_1:
1585       case CONSTR_2_0:
1586       case CONSTR_1_1:
1587       case CONSTR_0_2:
1588       case CONSTR_STATIC:
1589         {
1590           StgWord offset = info->layout.selector_offset;
1591
1592           // check that the size is in range
1593           ASSERT(offset <
1594                  (StgWord32)(selectee_info->layout.payload.ptrs +
1595                             selectee_info->layout.payload.nptrs));
1596
1597           // perform the selection!
1598           q = selectee->payload[offset];
1599
1600           /* if we're already in to-space, there's no need to continue
1601            * with the evacuation, just update the source address with
1602            * a pointer to the (evacuated) constructor field.
1603            */
1604           if (HEAP_ALLOCED(q)) {
1605             bdescr *bd = Bdescr((P_)q);
1606             if (bd->flags & BF_EVACUATED) {
1607               if (bd->gen_no < evac_gen) {
1608                 failed_to_evac = rtsTrue;
1609                 TICK_GC_FAILED_PROMOTION();
1610               }
1611               return q;
1612             }
1613           }
1614
1615           /* otherwise, carry on and evacuate this constructor field,
1616            * (but not the constructor itself)
1617            */
1618           goto loop;
1619         }
1620
1621       case IND:
1622       case IND_STATIC:
1623       case IND_PERM:
1624       case IND_OLDGEN:
1625       case IND_OLDGEN_PERM:
1626         selectee = ((StgInd *)selectee)->indirectee;
1627         goto selector_loop;
1628
1629       case EVACUATED:
1630         selectee = ((StgEvacuated *)selectee)->evacuee;
1631         goto selector_loop;
1632
1633       case THUNK_SELECTOR:
1634 #         if 0
1635           /* Disabled 03 April 2001 by JRS; it seems to cause the GC (or
1636              something) to go into an infinite loop when the nightly
1637              stage2 compiles PrelTup.lhs. */
1638
1639           /* we can't recurse indefinitely in evacuate(), so set a
1640            * limit on the number of times we can go around this
1641            * loop.
1642            */
1643           if (thunk_selector_depth < MAX_THUNK_SELECTOR_DEPTH) {
1644               bdescr *bd;
1645               bd = Bdescr((P_)selectee);
1646               if (!bd->flags & BF_EVACUATED) {
1647                   thunk_selector_depth++;
1648                   selectee = evacuate(selectee);
1649                   thunk_selector_depth--;
1650                   goto selector_loop;
1651               }
1652           }
1653           // otherwise, fall through...
1654 #         endif
1655
1656       case AP_UPD:
1657       case THUNK:
1658       case THUNK_1_0:
1659       case THUNK_0_1:
1660       case THUNK_2_0:
1661       case THUNK_1_1:
1662       case THUNK_0_2:
1663       case THUNK_STATIC:
1664       case CAF_BLACKHOLE:
1665       case SE_CAF_BLACKHOLE:
1666       case SE_BLACKHOLE:
1667       case BLACKHOLE:
1668       case BLACKHOLE_BQ:
1669         // not evaluated yet
1670         break;
1671
1672 #if defined(PAR)
1673         // a copy of the top-level cases below
1674       case RBH: // cf. BLACKHOLE_BQ
1675         {
1676           //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1677           to = copy(q,BLACKHOLE_sizeW(),stp);
1678           //ToDo: derive size etc from reverted IP
1679           //to = copy(q,size,stp);
1680           // recordMutable((StgMutClosure *)to);
1681           return to;
1682         }
1683
1684       case BLOCKED_FETCH:
1685         ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1686         to = copy(q,sizeofW(StgBlockedFetch),stp);
1687         return to;
1688
1689 # ifdef DIST
1690       case REMOTE_REF:
1691 # endif
1692       case FETCH_ME:
1693         ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1694         to = copy(q,sizeofW(StgFetchMe),stp);
1695         return to;
1696
1697       case FETCH_ME_BQ:
1698         ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1699         to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1700         return to;
1701 #endif
1702
1703       default:
1704         barf("evacuate: THUNK_SELECTOR: strange selectee %d",
1705              (int)(selectee_info->type));
1706       }
1707     }
1708     return copy(q,THUNK_SELECTOR_sizeW(),stp);
1709
1710   case IND:
1711   case IND_OLDGEN:
1712     // follow chains of indirections, don't evacuate them
1713     q = ((StgInd*)q)->indirectee;
1714     goto loop;
1715
1716   case THUNK_STATIC:
1717     if (info->srt_len > 0 && major_gc &&
1718         THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1719       THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1720       static_objects = (StgClosure *)q;
1721     }
1722     return q;
1723
1724   case FUN_STATIC:
1725     if (info->srt_len > 0 && major_gc &&
1726         FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1727       FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1728       static_objects = (StgClosure *)q;
1729     }
1730     return q;
1731
1732   case IND_STATIC:
1733     /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1734      * on the CAF list, so don't do anything with it here (we'll
1735      * scavenge it later).
1736      */
1737     if (major_gc
1738           && ((StgIndStatic *)q)->saved_info == NULL
1739           && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1740         IND_STATIC_LINK((StgClosure *)q) = static_objects;
1741         static_objects = (StgClosure *)q;
1742     }
1743     return q;
1744
1745   case CONSTR_STATIC:
1746     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1747       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1748       static_objects = (StgClosure *)q;
1749     }
1750     return q;
1751
1752   case CONSTR_INTLIKE:
1753   case CONSTR_CHARLIKE:
1754   case CONSTR_NOCAF_STATIC:
1755     /* no need to put these on the static linked list, they don't need
1756      * to be scavenged.
1757      */
1758     return q;
1759
1760   case RET_BCO:
1761   case RET_SMALL:
1762   case RET_VEC_SMALL:
1763   case RET_BIG:
1764   case RET_VEC_BIG:
1765   case RET_DYN:
1766   case UPDATE_FRAME:
1767   case STOP_FRAME:
1768   case CATCH_FRAME:
1769   case SEQ_FRAME:
1770     // shouldn't see these
1771     barf("evacuate: stack frame at %p\n", q);
1772
1773   case AP_UPD:
1774   case PAP:
1775     /* PAPs and AP_UPDs are special - the payload is a copy of a chunk
1776      * of stack, tagging and all.
1777      */
1778       return copy(q,pap_sizeW((StgPAP*)q),stp);
1779
1780   case EVACUATED:
1781     /* Already evacuated, just return the forwarding address.
1782      * HOWEVER: if the requested destination generation (evac_gen) is
1783      * older than the actual generation (because the object was
1784      * already evacuated to a younger generation) then we have to
1785      * set the failed_to_evac flag to indicate that we couldn't
1786      * manage to promote the object to the desired generation.
1787      */
1788     if (evac_gen > 0) {         // optimisation
1789       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1790       if (Bdescr((P_)p)->gen_no < evac_gen) {
1791         failed_to_evac = rtsTrue;
1792         TICK_GC_FAILED_PROMOTION();
1793       }
1794     }
1795     return ((StgEvacuated*)q)->evacuee;
1796
1797   case ARR_WORDS:
1798       // just copy the block
1799       return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1800
1801   case MUT_ARR_PTRS:
1802   case MUT_ARR_PTRS_FROZEN:
1803       // just copy the block
1804       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1805
1806   case TSO:
1807     {
1808       StgTSO *tso = (StgTSO *)q;
1809
1810       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1811        */
1812       if (tso->what_next == ThreadRelocated) {
1813         q = (StgClosure *)tso->link;
1814         goto loop;
1815       }
1816
1817       /* To evacuate a small TSO, we need to relocate the update frame
1818        * list it contains.
1819        */
1820       {
1821           StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),stp);
1822           move_TSO(tso, new_tso);
1823           return (StgClosure *)new_tso;
1824       }
1825     }
1826
1827 #if defined(PAR)
1828   case RBH: // cf. BLACKHOLE_BQ
1829     {
1830       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1831       to = copy(q,BLACKHOLE_sizeW(),stp);
1832       //ToDo: derive size etc from reverted IP
1833       //to = copy(q,size,stp);
1834       IF_DEBUG(gc,
1835                belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1836                      q, info_type(q), to, info_type(to)));
1837       return to;
1838     }
1839
1840   case BLOCKED_FETCH:
1841     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1842     to = copy(q,sizeofW(StgBlockedFetch),stp);
1843     IF_DEBUG(gc,
1844              belch("@@ evacuate: %p (%s) to %p (%s)",
1845                    q, info_type(q), to, info_type(to)));
1846     return to;
1847
1848 # ifdef DIST
1849   case REMOTE_REF:
1850 # endif
1851   case FETCH_ME:
1852     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1853     to = copy(q,sizeofW(StgFetchMe),stp);
1854     IF_DEBUG(gc,
1855              belch("@@ evacuate: %p (%s) to %p (%s)",
1856                    q, info_type(q), to, info_type(to)));
1857     return to;
1858
1859   case FETCH_ME_BQ:
1860     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1861     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1862     IF_DEBUG(gc,
1863              belch("@@ evacuate: %p (%s) to %p (%s)",
1864                    q, info_type(q), to, info_type(to)));
1865     return to;
1866 #endif
1867
1868   default:
1869     barf("evacuate: strange closure type %d", (int)(info->type));
1870   }
1871
1872   barf("evacuate");
1873 }
1874
1875 /* -----------------------------------------------------------------------------
1876    move_TSO is called to update the TSO structure after it has been
1877    moved from one place to another.
1878    -------------------------------------------------------------------------- */
1879
1880 void
1881 move_TSO(StgTSO *src, StgTSO *dest)
1882 {
1883     ptrdiff_t diff;
1884
1885     // relocate the stack pointers...
1886     diff = (StgPtr)dest - (StgPtr)src; // In *words*
1887     dest->sp = (StgPtr)dest->sp + diff;
1888     dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
1889
1890     relocate_stack(dest, diff);
1891 }
1892
1893 /* -----------------------------------------------------------------------------
1894    relocate_stack is called to update the linkage between
1895    UPDATE_FRAMEs (and SEQ_FRAMEs etc.) when a stack is moved from one
1896    place to another.
1897    -------------------------------------------------------------------------- */
1898
1899 StgTSO *
1900 relocate_stack(StgTSO *dest, ptrdiff_t diff)
1901 {
1902   StgUpdateFrame *su;
1903   StgCatchFrame  *cf;
1904   StgSeqFrame    *sf;
1905
1906   su = dest->su;
1907
1908   while ((P_)su < dest->stack + dest->stack_size) {
1909     switch (get_itbl(su)->type) {
1910
1911       // GCC actually manages to common up these three cases!
1912
1913     case UPDATE_FRAME:
1914       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1915       su = su->link;
1916       continue;
1917
1918     case CATCH_FRAME:
1919       cf = (StgCatchFrame *)su;
1920       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1921       su = cf->link;
1922       continue;
1923
1924     case SEQ_FRAME:
1925       sf = (StgSeqFrame *)su;
1926       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1927       su = sf->link;
1928       continue;
1929
1930     case STOP_FRAME:
1931       // all done!
1932       break;
1933
1934     default:
1935       barf("relocate_stack %d", (int)(get_itbl(su)->type));
1936     }
1937     break;
1938   }
1939
1940   return dest;
1941 }
1942
1943
1944
1945 static inline void
1946 scavenge_srt(const StgInfoTable *info)
1947 {
1948   StgClosure **srt, **srt_end;
1949
1950   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1951    * srt field in the info table.  That's ok, because we'll
1952    * never dereference it.
1953    */
1954   srt = (StgClosure **)(info->srt);
1955   srt_end = srt + info->srt_len;
1956   for (; srt < srt_end; srt++) {
1957     /* Special-case to handle references to closures hiding out in DLLs, since
1958        double indirections required to get at those. The code generator knows
1959        which is which when generating the SRT, so it stores the (indirect)
1960        reference to the DLL closure in the table by first adding one to it.
1961        We check for this here, and undo the addition before evacuating it.
1962
1963        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
1964        closure that's fixed at link-time, and no extra magic is required.
1965     */
1966 #ifdef ENABLE_WIN32_DLL_SUPPORT
1967     if ( (unsigned long)(*srt) & 0x1 ) {
1968        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
1969     } else {
1970        evacuate(*srt);
1971     }
1972 #else
1973        evacuate(*srt);
1974 #endif
1975   }
1976 }
1977
1978 /* -----------------------------------------------------------------------------
1979    Scavenge a TSO.
1980    -------------------------------------------------------------------------- */
1981
1982 static void
1983 scavengeTSO (StgTSO *tso)
1984 {
1985   // chase the link field for any TSOs on the same queue
1986   (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1987   if (   tso->why_blocked == BlockedOnMVar
1988          || tso->why_blocked == BlockedOnBlackHole
1989          || tso->why_blocked == BlockedOnException
1990 #if defined(PAR)
1991          || tso->why_blocked == BlockedOnGA
1992          || tso->why_blocked == BlockedOnGA_NoSend
1993 #endif
1994          ) {
1995     tso->block_info.closure = evacuate(tso->block_info.closure);
1996   }
1997   if ( tso->blocked_exceptions != NULL ) {
1998     tso->blocked_exceptions =
1999       (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2000   }
2001   // scavenge this thread's stack
2002   scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2003 }
2004
2005 /* -----------------------------------------------------------------------------
2006    Scavenge a given step until there are no more objects in this step
2007    to scavenge.
2008
2009    evac_gen is set by the caller to be either zero (for a step in a
2010    generation < N) or G where G is the generation of the step being
2011    scavenged.
2012
2013    We sometimes temporarily change evac_gen back to zero if we're
2014    scavenging a mutable object where early promotion isn't such a good
2015    idea.
2016    -------------------------------------------------------------------------- */
2017
2018 static void
2019 scavenge(step *stp)
2020 {
2021   StgPtr p, q;
2022   StgInfoTable *info;
2023   bdescr *bd;
2024   nat saved_evac_gen = evac_gen;
2025
2026   p = stp->scan;
2027   bd = stp->scan_bd;
2028
2029   failed_to_evac = rtsFalse;
2030
2031   /* scavenge phase - standard breadth-first scavenging of the
2032    * evacuated objects
2033    */
2034
2035   while (bd != stp->hp_bd || p < stp->hp) {
2036
2037     // If we're at the end of this block, move on to the next block
2038     if (bd != stp->hp_bd && p == bd->free) {
2039       bd = bd->link;
2040       p = bd->start;
2041       continue;
2042     }
2043
2044     info = get_itbl((StgClosure *)p);
2045     ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2046
2047     q = p;
2048     switch (info->type) {
2049
2050     case MVAR:
2051         /* treat MVars specially, because we don't want to evacuate the
2052          * mut_link field in the middle of the closure.
2053          */
2054     {
2055         StgMVar *mvar = ((StgMVar *)p);
2056         evac_gen = 0;
2057         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2058         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2059         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2060         evac_gen = saved_evac_gen;
2061         recordMutable((StgMutClosure *)mvar);
2062         failed_to_evac = rtsFalse; // mutable.
2063         p += sizeofW(StgMVar);
2064         break;
2065     }
2066
2067     case THUNK_2_0:
2068     case FUN_2_0:
2069         scavenge_srt(info);
2070     case CONSTR_2_0:
2071         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2072         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2073         p += sizeofW(StgHeader) + 2;
2074         break;
2075
2076     case THUNK_1_0:
2077         scavenge_srt(info);
2078         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2079         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2080         break;
2081
2082     case FUN_1_0:
2083         scavenge_srt(info);
2084     case CONSTR_1_0:
2085         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2086         p += sizeofW(StgHeader) + 1;
2087         break;
2088
2089     case THUNK_0_1:
2090         scavenge_srt(info);
2091         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2092         break;
2093
2094     case FUN_0_1:
2095         scavenge_srt(info);
2096     case CONSTR_0_1:
2097         p += sizeofW(StgHeader) + 1;
2098         break;
2099
2100     case THUNK_0_2:
2101     case FUN_0_2:
2102         scavenge_srt(info);
2103     case CONSTR_0_2:
2104         p += sizeofW(StgHeader) + 2;
2105         break;
2106
2107     case THUNK_1_1:
2108     case FUN_1_1:
2109         scavenge_srt(info);
2110     case CONSTR_1_1:
2111         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2112         p += sizeofW(StgHeader) + 2;
2113         break;
2114
2115     case FUN:
2116     case THUNK:
2117         scavenge_srt(info);
2118         // fall through
2119
2120     case CONSTR:
2121     case WEAK:
2122     case FOREIGN:
2123     case STABLE_NAME:
2124     case BCO:
2125     {
2126         StgPtr end;
2127
2128         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2129         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2130             (StgClosure *)*p = evacuate((StgClosure *)*p);
2131         }
2132         p += info->layout.payload.nptrs;
2133         break;
2134     }
2135
2136     case IND_PERM:
2137         if (stp->gen_no != 0) {
2138             SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2139         }
2140         // fall through
2141     case IND_OLDGEN_PERM:
2142         ((StgIndOldGen *)p)->indirectee =
2143             evacuate(((StgIndOldGen *)p)->indirectee);
2144         if (failed_to_evac) {
2145             failed_to_evac = rtsFalse;
2146             recordOldToNewPtrs((StgMutClosure *)p);
2147         }
2148         p += sizeofW(StgIndOldGen);
2149         break;
2150
2151     case MUT_VAR:
2152         evac_gen = 0;
2153         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2154         evac_gen = saved_evac_gen;
2155         recordMutable((StgMutClosure *)p);
2156         failed_to_evac = rtsFalse; // mutable anyhow
2157         p += sizeofW(StgMutVar);
2158         break;
2159
2160     case MUT_CONS:
2161         // ignore these
2162         failed_to_evac = rtsFalse; // mutable anyhow
2163         p += sizeofW(StgMutVar);
2164         break;
2165
2166     case CAF_BLACKHOLE:
2167     case SE_CAF_BLACKHOLE:
2168     case SE_BLACKHOLE:
2169     case BLACKHOLE:
2170         p += BLACKHOLE_sizeW();
2171         break;
2172
2173     case BLACKHOLE_BQ:
2174     {
2175         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2176         (StgClosure *)bh->blocking_queue =
2177             evacuate((StgClosure *)bh->blocking_queue);
2178         recordMutable((StgMutClosure *)bh);
2179         failed_to_evac = rtsFalse;
2180         p += BLACKHOLE_sizeW();
2181         break;
2182     }
2183
2184     case THUNK_SELECTOR:
2185     {
2186         StgSelector *s = (StgSelector *)p;
2187         s->selectee = evacuate(s->selectee);
2188         p += THUNK_SELECTOR_sizeW();
2189         break;
2190     }
2191
2192     case AP_UPD: // same as PAPs
2193     case PAP:
2194         /* Treat a PAP just like a section of stack, not forgetting to
2195          * evacuate the function pointer too...
2196          */
2197     {
2198         StgPAP* pap = (StgPAP *)p;
2199
2200         pap->fun = evacuate(pap->fun);
2201         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2202         p += pap_sizeW(pap);
2203         break;
2204     }
2205
2206     case ARR_WORDS:
2207         // nothing to follow
2208         p += arr_words_sizeW((StgArrWords *)p);
2209         break;
2210
2211     case MUT_ARR_PTRS:
2212         // follow everything
2213     {
2214         StgPtr next;
2215
2216         evac_gen = 0;           // repeatedly mutable
2217         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2218         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2219             (StgClosure *)*p = evacuate((StgClosure *)*p);
2220         }
2221         evac_gen = saved_evac_gen;
2222         recordMutable((StgMutClosure *)q);
2223         failed_to_evac = rtsFalse; // mutable anyhow.
2224         break;
2225     }
2226
2227     case MUT_ARR_PTRS_FROZEN:
2228         // follow everything
2229     {
2230         StgPtr next;
2231
2232         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2233         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2234             (StgClosure *)*p = evacuate((StgClosure *)*p);
2235         }
2236         // it's tempting to recordMutable() if failed_to_evac is
2237         // false, but that breaks some assumptions (eg. every
2238         // closure on the mutable list is supposed to have the MUT
2239         // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2240         break;
2241     }
2242
2243     case TSO:
2244     {
2245         StgTSO *tso = (StgTSO *)p;
2246         evac_gen = 0;
2247         scavengeTSO(tso);
2248         evac_gen = saved_evac_gen;
2249         recordMutable((StgMutClosure *)tso);
2250         failed_to_evac = rtsFalse; // mutable anyhow.
2251         p += tso_sizeW(tso);
2252         break;
2253     }
2254
2255 #if defined(PAR)
2256     case RBH: // cf. BLACKHOLE_BQ
2257     {
2258 #if 0
2259         nat size, ptrs, nonptrs, vhs;
2260         char str[80];
2261         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2262 #endif
2263         StgRBH *rbh = (StgRBH *)p;
2264         (StgClosure *)rbh->blocking_queue =
2265             evacuate((StgClosure *)rbh->blocking_queue);
2266         recordMutable((StgMutClosure *)to);
2267         failed_to_evac = rtsFalse;  // mutable anyhow.
2268         IF_DEBUG(gc,
2269                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2270                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2271         // ToDo: use size of reverted closure here!
2272         p += BLACKHOLE_sizeW();
2273         break;
2274     }
2275
2276     case BLOCKED_FETCH:
2277     {
2278         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2279         // follow the pointer to the node which is being demanded
2280         (StgClosure *)bf->node =
2281             evacuate((StgClosure *)bf->node);
2282         // follow the link to the rest of the blocking queue
2283         (StgClosure *)bf->link =
2284             evacuate((StgClosure *)bf->link);
2285         if (failed_to_evac) {
2286             failed_to_evac = rtsFalse;
2287             recordMutable((StgMutClosure *)bf);
2288         }
2289         IF_DEBUG(gc,
2290                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2291                        bf, info_type((StgClosure *)bf),
2292                        bf->node, info_type(bf->node)));
2293         p += sizeofW(StgBlockedFetch);
2294         break;
2295     }
2296
2297 #ifdef DIST
2298     case REMOTE_REF:
2299 #endif
2300     case FETCH_ME:
2301         p += sizeofW(StgFetchMe);
2302         break; // nothing to do in this case
2303
2304     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2305     {
2306         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2307         (StgClosure *)fmbq->blocking_queue =
2308             evacuate((StgClosure *)fmbq->blocking_queue);
2309         if (failed_to_evac) {
2310             failed_to_evac = rtsFalse;
2311             recordMutable((StgMutClosure *)fmbq);
2312         }
2313         IF_DEBUG(gc,
2314                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2315                        p, info_type((StgClosure *)p)));
2316         p += sizeofW(StgFetchMeBlockingQueue);
2317         break;
2318     }
2319 #endif
2320
2321     default:
2322         barf("scavenge: unimplemented/strange closure type %d @ %p",
2323              info->type, p);
2324     }
2325
2326     /* If we didn't manage to promote all the objects pointed to by
2327      * the current object, then we have to designate this object as
2328      * mutable (because it contains old-to-new generation pointers).
2329      */
2330     if (failed_to_evac) {
2331         failed_to_evac = rtsFalse;
2332         mkMutCons((StgClosure *)q, &generations[evac_gen]);
2333     }
2334   }
2335
2336   stp->scan_bd = bd;
2337   stp->scan = p;
2338 }
2339
2340 /* -----------------------------------------------------------------------------
2341    Scavenge everything on the mark stack.
2342
2343    This is slightly different from scavenge():
2344       - we don't walk linearly through the objects, so the scavenger
2345         doesn't need to advance the pointer on to the next object.
2346    -------------------------------------------------------------------------- */
2347
2348 static void
2349 scavenge_mark_stack(void)
2350 {
2351     StgPtr p, q;
2352     StgInfoTable *info;
2353     nat saved_evac_gen;
2354
2355     evac_gen = oldest_gen->no;
2356     saved_evac_gen = evac_gen;
2357
2358 linear_scan:
2359     while (!mark_stack_empty()) {
2360         p = pop_mark_stack();
2361
2362         info = get_itbl((StgClosure *)p);
2363         ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2364
2365         q = p;
2366         switch (info->type) {
2367
2368         case MVAR:
2369             /* treat MVars specially, because we don't want to evacuate the
2370              * mut_link field in the middle of the closure.
2371              */
2372         {
2373             StgMVar *mvar = ((StgMVar *)p);
2374             evac_gen = 0;
2375             (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2376             (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2377             (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2378             evac_gen = saved_evac_gen;
2379             failed_to_evac = rtsFalse; // mutable.
2380             break;
2381         }
2382
2383         case FUN_2_0:
2384         case THUNK_2_0:
2385             scavenge_srt(info);
2386         case CONSTR_2_0:
2387             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2388             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2389             break;
2390
2391         case FUN_1_0:
2392         case FUN_1_1:
2393         case THUNK_1_0:
2394         case THUNK_1_1:
2395             scavenge_srt(info);
2396         case CONSTR_1_0:
2397         case CONSTR_1_1:
2398             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2399             break;
2400
2401         case FUN_0_1:
2402         case FUN_0_2:
2403         case THUNK_0_1:
2404         case THUNK_0_2:
2405             scavenge_srt(info);
2406         case CONSTR_0_1:
2407         case CONSTR_0_2:
2408             break;
2409
2410         case FUN:
2411         case THUNK:
2412             scavenge_srt(info);
2413             // fall through
2414
2415         case CONSTR:
2416         case WEAK:
2417         case FOREIGN:
2418         case STABLE_NAME:
2419         case BCO:
2420         {
2421             StgPtr end;
2422
2423             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2424             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2425                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2426             }
2427             break;
2428         }
2429
2430         case IND_PERM:
2431             // don't need to do anything here: the only possible case
2432             // is that we're in a 1-space compacting collector, with
2433             // no "old" generation.
2434             break;
2435
2436         case IND_OLDGEN:
2437         case IND_OLDGEN_PERM:
2438             ((StgIndOldGen *)p)->indirectee =
2439                 evacuate(((StgIndOldGen *)p)->indirectee);
2440             if (failed_to_evac) {
2441                 recordOldToNewPtrs((StgMutClosure *)p);
2442             }
2443             failed_to_evac = rtsFalse;
2444             break;
2445
2446         case MUT_VAR:
2447             evac_gen = 0;
2448             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2449             evac_gen = saved_evac_gen;
2450             failed_to_evac = rtsFalse;
2451             break;
2452
2453         case MUT_CONS:
2454             // ignore these
2455             failed_to_evac = rtsFalse;
2456             break;
2457
2458         case CAF_BLACKHOLE:
2459         case SE_CAF_BLACKHOLE:
2460         case SE_BLACKHOLE:
2461         case BLACKHOLE:
2462         case ARR_WORDS:
2463             break;
2464
2465         case BLACKHOLE_BQ:
2466         {
2467             StgBlockingQueue *bh = (StgBlockingQueue *)p;
2468             (StgClosure *)bh->blocking_queue =
2469                 evacuate((StgClosure *)bh->blocking_queue);
2470             failed_to_evac = rtsFalse;
2471             break;
2472         }
2473
2474         case THUNK_SELECTOR:
2475         {
2476             StgSelector *s = (StgSelector *)p;
2477             s->selectee = evacuate(s->selectee);
2478             break;
2479         }
2480
2481         case AP_UPD: // same as PAPs
2482         case PAP:
2483             /* Treat a PAP just like a section of stack, not forgetting to
2484              * evacuate the function pointer too...
2485              */
2486         {
2487             StgPAP* pap = (StgPAP *)p;
2488
2489             pap->fun = evacuate(pap->fun);
2490             scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2491             break;
2492         }
2493
2494         case MUT_ARR_PTRS:
2495             // follow everything
2496         {
2497             StgPtr next;
2498
2499             evac_gen = 0;               // repeatedly mutable
2500             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2501             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2502                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2503             }
2504             evac_gen = saved_evac_gen;
2505             failed_to_evac = rtsFalse; // mutable anyhow.
2506             break;
2507         }
2508
2509         case MUT_ARR_PTRS_FROZEN:
2510             // follow everything
2511         {
2512             StgPtr next;
2513
2514             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2515             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2516                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2517             }
2518             break;
2519         }
2520
2521         case TSO:
2522         {
2523             StgTSO *tso = (StgTSO *)p;
2524             evac_gen = 0;
2525             scavengeTSO(tso);
2526             evac_gen = saved_evac_gen;
2527             failed_to_evac = rtsFalse;
2528             break;
2529         }
2530
2531 #if defined(PAR)
2532         case RBH: // cf. BLACKHOLE_BQ
2533         {
2534 #if 0
2535             nat size, ptrs, nonptrs, vhs;
2536             char str[80];
2537             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2538 #endif
2539             StgRBH *rbh = (StgRBH *)p;
2540             (StgClosure *)rbh->blocking_queue =
2541                 evacuate((StgClosure *)rbh->blocking_queue);
2542             recordMutable((StgMutClosure *)rbh);
2543             failed_to_evac = rtsFalse;  // mutable anyhow.
2544             IF_DEBUG(gc,
2545                      belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2546                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
2547             break;
2548         }
2549
2550         case BLOCKED_FETCH:
2551         {
2552             StgBlockedFetch *bf = (StgBlockedFetch *)p;
2553             // follow the pointer to the node which is being demanded
2554             (StgClosure *)bf->node =
2555                 evacuate((StgClosure *)bf->node);
2556             // follow the link to the rest of the blocking queue
2557             (StgClosure *)bf->link =
2558                 evacuate((StgClosure *)bf->link);
2559             if (failed_to_evac) {
2560                 failed_to_evac = rtsFalse;
2561                 recordMutable((StgMutClosure *)bf);
2562             }
2563             IF_DEBUG(gc,
2564                      belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2565                            bf, info_type((StgClosure *)bf),
2566                            bf->node, info_type(bf->node)));
2567             break;
2568         }
2569
2570 #ifdef DIST
2571         case REMOTE_REF:
2572 #endif
2573         case FETCH_ME:
2574             break; // nothing to do in this case
2575
2576         case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2577         {
2578             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2579             (StgClosure *)fmbq->blocking_queue =
2580                 evacuate((StgClosure *)fmbq->blocking_queue);
2581             if (failed_to_evac) {
2582                 failed_to_evac = rtsFalse;
2583                 recordMutable((StgMutClosure *)fmbq);
2584             }
2585             IF_DEBUG(gc,
2586                      belch("@@ scavenge: %p (%s) exciting, isn't it",
2587                            p, info_type((StgClosure *)p)));
2588             break;
2589         }
2590 #endif // PAR
2591
2592         default:
2593             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
2594                  info->type, p);
2595         }
2596
2597         if (failed_to_evac) {
2598             failed_to_evac = rtsFalse;
2599             mkMutCons((StgClosure *)q, &generations[evac_gen]);
2600         }
2601
2602         // mark the next bit to indicate "scavenged"
2603         mark(q+1, Bdescr(q));
2604
2605     } // while (!mark_stack_empty())
2606
2607     // start a new linear scan if the mark stack overflowed at some point
2608     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
2609         IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
2610         mark_stack_overflowed = rtsFalse;
2611         oldgen_scan_bd = oldest_gen->steps[0].blocks;
2612         oldgen_scan = oldgen_scan_bd->start;
2613     }
2614
2615     if (oldgen_scan_bd) {
2616         // push a new thing on the mark stack
2617     loop:
2618         // find a closure that is marked but not scavenged, and start
2619         // from there.
2620         while (oldgen_scan < oldgen_scan_bd->free
2621                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
2622             oldgen_scan++;
2623         }
2624
2625         if (oldgen_scan < oldgen_scan_bd->free) {
2626
2627             // already scavenged?
2628             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
2629                 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2630                 goto loop;
2631             }
2632             push_mark_stack(oldgen_scan);
2633             // ToDo: bump the linear scan by the actual size of the object
2634             oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2635             goto linear_scan;
2636         }
2637
2638         oldgen_scan_bd = oldgen_scan_bd->link;
2639         if (oldgen_scan_bd != NULL) {
2640             oldgen_scan = oldgen_scan_bd->start;
2641             goto loop;
2642         }
2643     }
2644 }
2645
2646 /* -----------------------------------------------------------------------------
2647    Scavenge one object.
2648
2649    This is used for objects that are temporarily marked as mutable
2650    because they contain old-to-new generation pointers.  Only certain
2651    objects can have this property.
2652    -------------------------------------------------------------------------- */
2653
2654 static rtsBool
2655 scavenge_one(StgPtr p)
2656 {
2657     const StgInfoTable *info;
2658     nat saved_evac_gen = evac_gen;
2659     rtsBool no_luck;
2660
2661     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
2662                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
2663
2664     info = get_itbl((StgClosure *)p);
2665
2666     switch (info->type) {
2667
2668     case FUN:
2669     case FUN_1_0:                       // hardly worth specialising these guys
2670     case FUN_0_1:
2671     case FUN_1_1:
2672     case FUN_0_2:
2673     case FUN_2_0:
2674     case THUNK:
2675     case THUNK_1_0:
2676     case THUNK_0_1:
2677     case THUNK_1_1:
2678     case THUNK_0_2:
2679     case THUNK_2_0:
2680     case CONSTR:
2681     case CONSTR_1_0:
2682     case CONSTR_0_1:
2683     case CONSTR_1_1:
2684     case CONSTR_0_2:
2685     case CONSTR_2_0:
2686     case WEAK:
2687     case FOREIGN:
2688     case IND_PERM:
2689     case IND_OLDGEN_PERM:
2690     {
2691         StgPtr q, end;
2692
2693         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2694         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
2695             (StgClosure *)*q = evacuate((StgClosure *)*q);
2696         }
2697         break;
2698     }
2699
2700     case CAF_BLACKHOLE:
2701     case SE_CAF_BLACKHOLE:
2702     case SE_BLACKHOLE:
2703     case BLACKHOLE:
2704         break;
2705
2706     case THUNK_SELECTOR:
2707     {
2708         StgSelector *s = (StgSelector *)p;
2709         s->selectee = evacuate(s->selectee);
2710         break;
2711     }
2712
2713     case ARR_WORDS:
2714         // nothing to follow
2715         break;
2716
2717     case MUT_ARR_PTRS:
2718     {
2719         // follow everything
2720         StgPtr next;
2721
2722         evac_gen = 0;           // repeatedly mutable
2723         recordMutable((StgMutClosure *)p);
2724         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2725         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2726             (StgClosure *)*p = evacuate((StgClosure *)*p);
2727         }
2728         evac_gen = saved_evac_gen;
2729         failed_to_evac = rtsFalse;
2730         break;
2731     }
2732
2733     case MUT_ARR_PTRS_FROZEN:
2734     {
2735         // follow everything
2736         StgPtr next;
2737
2738         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2739         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2740             (StgClosure *)*p = evacuate((StgClosure *)*p);
2741         }
2742         break;
2743     }
2744
2745     case TSO:
2746     {
2747         StgTSO *tso = (StgTSO *)p;
2748
2749         evac_gen = 0;           // repeatedly mutable
2750         scavengeTSO(tso);
2751         recordMutable((StgMutClosure *)tso);
2752         evac_gen = saved_evac_gen;
2753         failed_to_evac = rtsFalse;
2754         break;
2755     }
2756
2757     case AP_UPD:
2758     case PAP:
2759     {
2760         StgPAP* pap = (StgPAP *)p;
2761         pap->fun = evacuate(pap->fun);
2762         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2763         break;
2764     }
2765
2766     case IND_OLDGEN:
2767         // This might happen if for instance a MUT_CONS was pointing to a
2768         // THUNK which has since been updated.  The IND_OLDGEN will
2769         // be on the mutable list anyway, so we don't need to do anything
2770         // here.
2771         break;
2772
2773     default:
2774         barf("scavenge_one: strange object %d", (int)(info->type));
2775     }
2776
2777     no_luck = failed_to_evac;
2778     failed_to_evac = rtsFalse;
2779     return (no_luck);
2780 }
2781
2782 /* -----------------------------------------------------------------------------
2783    Scavenging mutable lists.
2784
2785    We treat the mutable list of each generation > N (i.e. all the
2786    generations older than the one being collected) as roots.  We also
2787    remove non-mutable objects from the mutable list at this point.
2788    -------------------------------------------------------------------------- */
2789
2790 static void
2791 scavenge_mut_once_list(generation *gen)
2792 {
2793   const StgInfoTable *info;
2794   StgMutClosure *p, *next, *new_list;
2795
2796   p = gen->mut_once_list;
2797   new_list = END_MUT_LIST;
2798   next = p->mut_link;
2799
2800   evac_gen = gen->no;
2801   failed_to_evac = rtsFalse;
2802
2803   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2804
2805     // make sure the info pointer is into text space
2806     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2807                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2808
2809     info = get_itbl(p);
2810     /*
2811     if (info->type==RBH)
2812       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2813     */
2814     switch(info->type) {
2815
2816     case IND_OLDGEN:
2817     case IND_OLDGEN_PERM:
2818     case IND_STATIC:
2819       /* Try to pull the indirectee into this generation, so we can
2820        * remove the indirection from the mutable list.
2821        */
2822       ((StgIndOldGen *)p)->indirectee =
2823         evacuate(((StgIndOldGen *)p)->indirectee);
2824
2825 #if 0 && defined(DEBUG)
2826       if (RtsFlags.DebugFlags.gc)
2827       /* Debugging code to print out the size of the thing we just
2828        * promoted
2829        */
2830       {
2831         StgPtr start = gen->steps[0].scan;
2832         bdescr *start_bd = gen->steps[0].scan_bd;
2833         nat size = 0;
2834         scavenge(&gen->steps[0]);
2835         if (start_bd != gen->steps[0].scan_bd) {
2836           size += (P_)BLOCK_ROUND_UP(start) - start;
2837           start_bd = start_bd->link;
2838           while (start_bd != gen->steps[0].scan_bd) {
2839             size += BLOCK_SIZE_W;
2840             start_bd = start_bd->link;
2841           }
2842           size += gen->steps[0].scan -
2843             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
2844         } else {
2845           size = gen->steps[0].scan - start;
2846         }
2847         belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
2848       }
2849 #endif
2850
2851       /* failed_to_evac might happen if we've got more than two
2852        * generations, we're collecting only generation 0, the
2853        * indirection resides in generation 2 and the indirectee is
2854        * in generation 1.
2855        */
2856       if (failed_to_evac) {
2857         failed_to_evac = rtsFalse;
2858         p->mut_link = new_list;
2859         new_list = p;
2860       } else {
2861         /* the mut_link field of an IND_STATIC is overloaded as the
2862          * static link field too (it just so happens that we don't need
2863          * both at the same time), so we need to NULL it out when
2864          * removing this object from the mutable list because the static
2865          * link fields are all assumed to be NULL before doing a major
2866          * collection.
2867          */
2868         p->mut_link = NULL;
2869       }
2870       continue;
2871
2872     case MUT_CONS:
2873         /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
2874          * it from the mutable list if possible by promoting whatever it
2875          * points to.
2876          */
2877         if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
2878             /* didn't manage to promote everything, so put the
2879              * MUT_CONS back on the list.
2880              */
2881             p->mut_link = new_list;
2882             new_list = p;
2883         }
2884         continue;
2885
2886     default:
2887       // shouldn't have anything else on the mutables list
2888       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
2889     }
2890   }
2891
2892   gen->mut_once_list = new_list;
2893 }
2894
2895
2896 static void
2897 scavenge_mutable_list(generation *gen)
2898 {
2899   const StgInfoTable *info;
2900   StgMutClosure *p, *next;
2901
2902   p = gen->saved_mut_list;
2903   next = p->mut_link;
2904
2905   evac_gen = 0;
2906   failed_to_evac = rtsFalse;
2907
2908   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2909
2910     // make sure the info pointer is into text space
2911     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2912                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2913
2914     info = get_itbl(p);
2915     /*
2916     if (info->type==RBH)
2917       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2918     */
2919     switch(info->type) {
2920
2921     case MUT_ARR_PTRS:
2922       // follow everything
2923       p->mut_link = gen->mut_list;
2924       gen->mut_list = p;
2925       {
2926         StgPtr end, q;
2927
2928         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2929         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2930           (StgClosure *)*q = evacuate((StgClosure *)*q);
2931         }
2932         continue;
2933       }
2934
2935       // Happens if a MUT_ARR_PTRS in the old generation is frozen
2936     case MUT_ARR_PTRS_FROZEN:
2937       {
2938         StgPtr end, q;
2939
2940         evac_gen = gen->no;
2941         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2942         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
2943           (StgClosure *)*q = evacuate((StgClosure *)*q);
2944         }
2945         evac_gen = 0;
2946         p->mut_link = NULL;
2947         if (failed_to_evac) {
2948             failed_to_evac = rtsFalse;
2949             mkMutCons((StgClosure *)p, gen);
2950         }
2951         continue;
2952       }
2953
2954     case MUT_VAR:
2955         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2956         p->mut_link = gen->mut_list;
2957         gen->mut_list = p;
2958         continue;
2959
2960     case MVAR:
2961       {
2962         StgMVar *mvar = (StgMVar *)p;
2963         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2964         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2965         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2966         p->mut_link = gen->mut_list;
2967         gen->mut_list = p;
2968         continue;
2969       }
2970
2971     case TSO:
2972       {
2973         StgTSO *tso = (StgTSO *)p;
2974
2975         scavengeTSO(tso);
2976
2977         /* Don't take this TSO off the mutable list - it might still
2978          * point to some younger objects (because we set evac_gen to 0
2979          * above).
2980          */
2981         tso->mut_link = gen->mut_list;
2982         gen->mut_list = (StgMutClosure *)tso;
2983         continue;
2984       }
2985
2986     case BLACKHOLE_BQ:
2987       {
2988         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2989         (StgClosure *)bh->blocking_queue =
2990           evacuate((StgClosure *)bh->blocking_queue);
2991         p->mut_link = gen->mut_list;
2992         gen->mut_list = p;
2993         continue;
2994       }
2995
2996       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
2997        */
2998     case IND_OLDGEN:
2999     case IND_OLDGEN_PERM:
3000       /* Try to pull the indirectee into this generation, so we can
3001        * remove the indirection from the mutable list.
3002        */
3003       evac_gen = gen->no;
3004       ((StgIndOldGen *)p)->indirectee =
3005         evacuate(((StgIndOldGen *)p)->indirectee);
3006       evac_gen = 0;
3007
3008       if (failed_to_evac) {
3009         failed_to_evac = rtsFalse;
3010         p->mut_link = gen->mut_once_list;
3011         gen->mut_once_list = p;
3012       } else {
3013         p->mut_link = NULL;
3014       }
3015       continue;
3016
3017 #if defined(PAR)
3018     // HWL: check whether all of these are necessary
3019
3020     case RBH: // cf. BLACKHOLE_BQ
3021       {
3022         // nat size, ptrs, nonptrs, vhs;
3023         // char str[80];
3024         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3025         StgRBH *rbh = (StgRBH *)p;
3026         (StgClosure *)rbh->blocking_queue =
3027           evacuate((StgClosure *)rbh->blocking_queue);
3028         if (failed_to_evac) {
3029           failed_to_evac = rtsFalse;
3030           recordMutable((StgMutClosure *)rbh);
3031         }
3032         // ToDo: use size of reverted closure here!
3033         p += BLACKHOLE_sizeW();
3034         break;
3035       }
3036
3037     case BLOCKED_FETCH:
3038       {
3039         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3040         // follow the pointer to the node which is being demanded
3041         (StgClosure *)bf->node =
3042           evacuate((StgClosure *)bf->node);
3043         // follow the link to the rest of the blocking queue
3044         (StgClosure *)bf->link =
3045           evacuate((StgClosure *)bf->link);
3046         if (failed_to_evac) {
3047           failed_to_evac = rtsFalse;
3048           recordMutable((StgMutClosure *)bf);
3049         }
3050         p += sizeofW(StgBlockedFetch);
3051         break;
3052       }
3053
3054 #ifdef DIST
3055     case REMOTE_REF:
3056       barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3057 #endif
3058     case FETCH_ME:
3059       p += sizeofW(StgFetchMe);
3060       break; // nothing to do in this case
3061
3062     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3063       {
3064         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3065         (StgClosure *)fmbq->blocking_queue =
3066           evacuate((StgClosure *)fmbq->blocking_queue);
3067         if (failed_to_evac) {
3068           failed_to_evac = rtsFalse;
3069           recordMutable((StgMutClosure *)fmbq);
3070         }
3071         p += sizeofW(StgFetchMeBlockingQueue);
3072         break;
3073       }
3074 #endif
3075
3076     default:
3077       // shouldn't have anything else on the mutables list
3078       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3079     }
3080   }
3081 }
3082
3083
3084 static void
3085 scavenge_static(void)
3086 {
3087   StgClosure* p = static_objects;
3088   const StgInfoTable *info;
3089
3090   /* Always evacuate straight to the oldest generation for static
3091    * objects */
3092   evac_gen = oldest_gen->no;
3093
3094   /* keep going until we've scavenged all the objects on the linked
3095      list... */
3096   while (p != END_OF_STATIC_LIST) {
3097
3098     info = get_itbl(p);
3099     /*
3100     if (info->type==RBH)
3101       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3102     */
3103     // make sure the info pointer is into text space
3104     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3105                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3106
3107     /* Take this object *off* the static_objects list,
3108      * and put it on the scavenged_static_objects list.
3109      */
3110     static_objects = STATIC_LINK(info,p);
3111     STATIC_LINK(info,p) = scavenged_static_objects;
3112     scavenged_static_objects = p;
3113
3114     switch (info -> type) {
3115
3116     case IND_STATIC:
3117       {
3118         StgInd *ind = (StgInd *)p;
3119         ind->indirectee = evacuate(ind->indirectee);
3120
3121         /* might fail to evacuate it, in which case we have to pop it
3122          * back on the mutable list (and take it off the
3123          * scavenged_static list because the static link and mut link
3124          * pointers are one and the same).
3125          */
3126         if (failed_to_evac) {
3127           failed_to_evac = rtsFalse;
3128           scavenged_static_objects = IND_STATIC_LINK(p);
3129           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3130           oldest_gen->mut_once_list = (StgMutClosure *)ind;
3131         }
3132         break;
3133       }
3134
3135     case THUNK_STATIC:
3136     case FUN_STATIC:
3137       scavenge_srt(info);
3138       break;
3139
3140     case CONSTR_STATIC:
3141       {
3142         StgPtr q, next;
3143
3144         next = (P_)p->payload + info->layout.payload.ptrs;
3145         // evacuate the pointers
3146         for (q = (P_)p->payload; q < next; q++) {
3147           (StgClosure *)*q = evacuate((StgClosure *)*q);
3148         }
3149         break;
3150       }
3151
3152     default:
3153       barf("scavenge_static: strange closure %d", (int)(info->type));
3154     }
3155
3156     ASSERT(failed_to_evac == rtsFalse);
3157
3158     /* get the next static object from the list.  Remember, there might
3159      * be more stuff on this list now that we've done some evacuating!
3160      * (static_objects is a global)
3161      */
3162     p = static_objects;
3163   }
3164 }
3165
3166 /* -----------------------------------------------------------------------------
3167    scavenge_stack walks over a section of stack and evacuates all the
3168    objects pointed to by it.  We can use the same code for walking
3169    PAPs, since these are just sections of copied stack.
3170    -------------------------------------------------------------------------- */
3171
3172 static void
3173 scavenge_stack(StgPtr p, StgPtr stack_end)
3174 {
3175   StgPtr q;
3176   const StgInfoTable* info;
3177   StgWord bitmap;
3178
3179   //IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
3180
3181   /*
3182    * Each time around this loop, we are looking at a chunk of stack
3183    * that starts with either a pending argument section or an
3184    * activation record.
3185    */
3186
3187   while (p < stack_end) {
3188     q = *(P_ *)p;
3189
3190     // If we've got a tag, skip over that many words on the stack
3191     if (IS_ARG_TAG((W_)q)) {
3192       p += ARG_SIZE(q);
3193       p++; continue;
3194     }
3195
3196     /* Is q a pointer to a closure?
3197      */
3198     if (! LOOKS_LIKE_GHC_INFO(q) ) {
3199 #ifdef DEBUG
3200       if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  // Is it a static closure?
3201         ASSERT(closure_STATIC((StgClosure *)q));
3202       }
3203       // otherwise, must be a pointer into the allocation space.
3204 #endif
3205
3206       (StgClosure *)*p = evacuate((StgClosure *)q);
3207       p++;
3208       continue;
3209     }
3210
3211     /*
3212      * Otherwise, q must be the info pointer of an activation
3213      * record.  All activation records have 'bitmap' style layout
3214      * info.
3215      */
3216     info  = get_itbl((StgClosure *)p);
3217
3218     switch (info->type) {
3219
3220       // Dynamic bitmap: the mask is stored on the stack
3221     case RET_DYN:
3222       bitmap = ((StgRetDyn *)p)->liveness;
3223       p      = (P_)&((StgRetDyn *)p)->payload[0];
3224       goto small_bitmap;
3225
3226       // probably a slow-entry point return address:
3227     case FUN:
3228     case FUN_STATIC:
3229       {
3230 #if 0
3231         StgPtr old_p = p;
3232         p++; p++;
3233         IF_DEBUG(sanity,
3234                  belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
3235                        old_p, p, old_p+1));
3236 #else
3237       p++; // what if FHS!=1 !? -- HWL
3238 #endif
3239       goto follow_srt;
3240       }
3241
3242       /* Specialised code for update frames, since they're so common.
3243        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
3244        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
3245        */
3246     case UPDATE_FRAME:
3247       {
3248         StgUpdateFrame *frame = (StgUpdateFrame *)p;
3249
3250         p += sizeofW(StgUpdateFrame);
3251
3252 #ifndef not_yet
3253         frame->updatee = evacuate(frame->updatee);
3254         continue;
3255 #else // specialised code for update frames, not sure if it's worth it.
3256         StgClosure *to;
3257         nat type = get_itbl(frame->updatee)->type;
3258
3259         if (type == EVACUATED) {
3260           frame->updatee = evacuate(frame->updatee);
3261           continue;
3262         } else {
3263           bdescr *bd = Bdescr((P_)frame->updatee);
3264           step *stp;
3265           if (bd->gen_no > N) {
3266             if (bd->gen_no < evac_gen) {
3267               failed_to_evac = rtsTrue;
3268             }
3269             continue;
3270           }
3271
3272           // Don't promote blackholes
3273           stp = bd->step;
3274           if (!(stp->gen_no == 0 &&
3275                 stp->no != 0 &&
3276                 stp->no == stp->gen->n_steps-1)) {
3277             stp = stp->to;
3278           }
3279
3280           switch (type) {
3281           case BLACKHOLE:
3282           case CAF_BLACKHOLE:
3283             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
3284                           sizeofW(StgHeader), stp);
3285             frame->updatee = to;
3286             continue;
3287           case BLACKHOLE_BQ:
3288             to = copy(frame->updatee, BLACKHOLE_sizeW(), stp);
3289             frame->updatee = to;
3290             recordMutable((StgMutClosure *)to);
3291             continue;
3292           default:
3293             /* will never be SE_{,CAF_}BLACKHOLE, since we
3294                don't push an update frame for single-entry thunks.  KSW 1999-01. */
3295             barf("scavenge_stack: UPDATE_FRAME updatee");
3296           }
3297         }
3298 #endif
3299       }
3300
3301       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3302     case STOP_FRAME:
3303     case CATCH_FRAME:
3304     case SEQ_FRAME:
3305     case RET_BCO:
3306     case RET_SMALL:
3307     case RET_VEC_SMALL:
3308       bitmap = info->layout.bitmap;
3309       p++;
3310       // this assumes that the payload starts immediately after the info-ptr
3311     small_bitmap:
3312       while (bitmap != 0) {
3313         if ((bitmap & 1) == 0) {
3314           (StgClosure *)*p = evacuate((StgClosure *)*p);
3315         }
3316         p++;
3317         bitmap = bitmap >> 1;
3318       }
3319
3320     follow_srt:
3321       scavenge_srt(info);
3322       continue;
3323
3324       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3325     case RET_BIG:
3326     case RET_VEC_BIG:
3327       {
3328         StgPtr q;
3329         StgLargeBitmap *large_bitmap;
3330         nat i;
3331
3332         large_bitmap = info->layout.large_bitmap;
3333         p++;
3334
3335         for (i=0; i<large_bitmap->size; i++) {
3336           bitmap = large_bitmap->bitmap[i];
3337           q = p + BITS_IN(W_);
3338           while (bitmap != 0) {
3339             if ((bitmap & 1) == 0) {
3340               (StgClosure *)*p = evacuate((StgClosure *)*p);
3341             }
3342             p++;
3343             bitmap = bitmap >> 1;
3344           }
3345           if (i+1 < large_bitmap->size) {
3346             while (p < q) {
3347               (StgClosure *)*p = evacuate((StgClosure *)*p);
3348               p++;
3349             }
3350           }
3351         }
3352
3353         // and don't forget to follow the SRT
3354         goto follow_srt;
3355       }
3356
3357     default:
3358       barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->type));
3359     }
3360   }
3361 }
3362
3363 /*-----------------------------------------------------------------------------
3364   scavenge the large object list.
3365
3366   evac_gen set by caller; similar games played with evac_gen as with
3367   scavenge() - see comment at the top of scavenge().  Most large
3368   objects are (repeatedly) mutable, so most of the time evac_gen will
3369   be zero.
3370   --------------------------------------------------------------------------- */
3371
3372 static void
3373 scavenge_large(step *stp)
3374 {
3375   bdescr *bd;
3376   StgPtr p;
3377
3378   bd = stp->new_large_objects;
3379
3380   for (; bd != NULL; bd = stp->new_large_objects) {
3381
3382     /* take this object *off* the large objects list and put it on
3383      * the scavenged large objects list.  This is so that we can
3384      * treat new_large_objects as a stack and push new objects on
3385      * the front when evacuating.
3386      */
3387     stp->new_large_objects = bd->link;
3388     dbl_link_onto(bd, &stp->scavenged_large_objects);
3389
3390     // update the block count in this step.
3391     stp->n_scavenged_large_blocks += bd->blocks;
3392
3393     p = bd->start;
3394     if (scavenge_one(p)) {
3395         mkMutCons((StgClosure *)p, stp->gen);
3396     }
3397   }
3398 }
3399
3400 /* -----------------------------------------------------------------------------
3401    Initialising the static object & mutable lists
3402    -------------------------------------------------------------------------- */
3403
3404 static void
3405 zero_static_object_list(StgClosure* first_static)
3406 {
3407   StgClosure* p;
3408   StgClosure* link;
3409   const StgInfoTable *info;
3410
3411   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3412     info = get_itbl(p);
3413     link = STATIC_LINK(info, p);
3414     STATIC_LINK(info,p) = NULL;
3415   }
3416 }
3417
3418 /* This function is only needed because we share the mutable link
3419  * field with the static link field in an IND_STATIC, so we have to
3420  * zero the mut_link field before doing a major GC, which needs the
3421  * static link field.
3422  *
3423  * It doesn't do any harm to zero all the mutable link fields on the
3424  * mutable list.
3425  */
3426
3427 static void
3428 zero_mutable_list( StgMutClosure *first )
3429 {
3430   StgMutClosure *next, *c;
3431
3432   for (c = first; c != END_MUT_LIST; c = next) {
3433     next = c->mut_link;
3434     c->mut_link = NULL;
3435   }
3436 }
3437
3438 /* -----------------------------------------------------------------------------
3439    Reverting CAFs
3440    -------------------------------------------------------------------------- */
3441
3442 void
3443 revertCAFs( void )
3444 {
3445     StgIndStatic *c;
3446
3447     for (c = (StgIndStatic *)caf_list; c != NULL;
3448          c = (StgIndStatic *)c->static_link)
3449     {
3450         c->header.info = c->saved_info;
3451         c->saved_info = NULL;
3452         // could, but not necessary: c->static_link = NULL;
3453     }
3454     caf_list = NULL;
3455 }
3456
3457 void
3458 scavengeCAFs( void )
3459 {
3460     StgIndStatic *c;
3461
3462     evac_gen = 0;
3463     for (c = (StgIndStatic *)caf_list; c != NULL;
3464          c = (StgIndStatic *)c->static_link)
3465     {
3466         c->indirectee = evacuate(c->indirectee);
3467     }
3468 }
3469
3470 /* -----------------------------------------------------------------------------
3471    Sanity code for CAF garbage collection.
3472
3473    With DEBUG turned on, we manage a CAF list in addition to the SRT
3474    mechanism.  After GC, we run down the CAF list and blackhole any
3475    CAFs which have been garbage collected.  This means we get an error
3476    whenever the program tries to enter a garbage collected CAF.
3477
3478    Any garbage collected CAFs are taken off the CAF list at the same
3479    time.
3480    -------------------------------------------------------------------------- */
3481
3482 #if 0 && defined(DEBUG)
3483
3484 static void
3485 gcCAFs(void)
3486 {
3487   StgClosure*  p;
3488   StgClosure** pp;
3489   const StgInfoTable *info;
3490   nat i;
3491
3492   i = 0;
3493   p = caf_list;
3494   pp = &caf_list;
3495
3496   while (p != NULL) {
3497
3498     info = get_itbl(p);
3499
3500     ASSERT(info->type == IND_STATIC);
3501
3502     if (STATIC_LINK(info,p) == NULL) {
3503       IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3504       // black hole it
3505       SET_INFO(p,&stg_BLACKHOLE_info);
3506       p = STATIC_LINK2(info,p);
3507       *pp = p;
3508     }
3509     else {
3510       pp = &STATIC_LINK2(info,p);
3511       p = *pp;
3512       i++;
3513     }
3514
3515   }
3516
3517   //  belch("%d CAFs live", i);
3518 }
3519 #endif
3520
3521
3522 /* -----------------------------------------------------------------------------
3523    Lazy black holing.
3524
3525    Whenever a thread returns to the scheduler after possibly doing
3526    some work, we have to run down the stack and black-hole all the
3527    closures referred to by update frames.
3528    -------------------------------------------------------------------------- */
3529
3530 static void
3531 threadLazyBlackHole(StgTSO *tso)
3532 {
3533   StgUpdateFrame *update_frame;
3534   StgBlockingQueue *bh;
3535   StgPtr stack_end;
3536
3537   stack_end = &tso->stack[tso->stack_size];
3538   update_frame = tso->su;
3539
3540   while (1) {
3541     switch (get_itbl(update_frame)->type) {
3542
3543     case CATCH_FRAME:
3544       update_frame = ((StgCatchFrame *)update_frame)->link;
3545       break;
3546
3547     case UPDATE_FRAME:
3548       bh = (StgBlockingQueue *)update_frame->updatee;
3549
3550       /* if the thunk is already blackholed, it means we've also
3551        * already blackholed the rest of the thunks on this stack,
3552        * so we can stop early.
3553        *
3554        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3555        * don't interfere with this optimisation.
3556        */
3557       if (bh->header.info == &stg_BLACKHOLE_info) {
3558         return;
3559       }
3560
3561       if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
3562           bh->header.info != &stg_CAF_BLACKHOLE_info) {
3563 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3564         belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3565 #endif
3566         SET_INFO(bh,&stg_BLACKHOLE_info);
3567       }
3568
3569       update_frame = update_frame->link;
3570       break;
3571
3572     case SEQ_FRAME:
3573       update_frame = ((StgSeqFrame *)update_frame)->link;
3574       break;
3575
3576     case STOP_FRAME:
3577       return;
3578     default:
3579       barf("threadPaused");
3580     }
3581   }
3582 }
3583
3584
3585 /* -----------------------------------------------------------------------------
3586  * Stack squeezing
3587  *
3588  * Code largely pinched from old RTS, then hacked to bits.  We also do
3589  * lazy black holing here.
3590  *
3591  * -------------------------------------------------------------------------- */
3592
3593 static void
3594 threadSqueezeStack(StgTSO *tso)
3595 {
3596   lnat displacement = 0;
3597   StgUpdateFrame *frame;
3598   StgUpdateFrame *next_frame;                   // Temporally next
3599   StgUpdateFrame *prev_frame;                   // Temporally previous
3600   StgPtr bottom;
3601   rtsBool prev_was_update_frame;
3602 #if DEBUG
3603   StgUpdateFrame *top_frame;
3604   nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
3605       bhs=0, squeezes=0;
3606   void printObj( StgClosure *obj ); // from Printer.c
3607
3608   top_frame  = tso->su;
3609 #endif
3610
3611   bottom = &(tso->stack[tso->stack_size]);
3612   frame  = tso->su;
3613
3614   /* There must be at least one frame, namely the STOP_FRAME.
3615    */
3616   ASSERT((P_)frame < bottom);
3617
3618   /* Walk down the stack, reversing the links between frames so that
3619    * we can walk back up as we squeeze from the bottom.  Note that
3620    * next_frame and prev_frame refer to next and previous as they were
3621    * added to the stack, rather than the way we see them in this
3622    * walk. (It makes the next loop less confusing.)
3623    *
3624    * Stop if we find an update frame pointing to a black hole
3625    * (see comment in threadLazyBlackHole()).
3626    */
3627
3628   next_frame = NULL;
3629   // bottom - sizeof(StgStopFrame) is the STOP_FRAME
3630   while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
3631     prev_frame = frame->link;
3632     frame->link = next_frame;
3633     next_frame = frame;
3634     frame = prev_frame;
3635 #if DEBUG
3636     IF_DEBUG(sanity,
3637              if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
3638                printObj((StgClosure *)prev_frame);
3639                barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
3640                     frame, prev_frame);
3641              })
3642     switch (get_itbl(frame)->type) {
3643     case UPDATE_FRAME:
3644         upd_frames++;
3645         if (frame->updatee->header.info == &stg_BLACKHOLE_info)
3646             bhs++;
3647         break;
3648     case STOP_FRAME:
3649         stop_frames++;
3650         break;
3651     case CATCH_FRAME:
3652         catch_frames++;
3653         break;
3654     case SEQ_FRAME:
3655         seq_frames++;
3656         break;
3657     default:
3658       barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
3659            frame, prev_frame);
3660       printObj((StgClosure *)prev_frame);
3661     }
3662 #endif
3663     if (get_itbl(frame)->type == UPDATE_FRAME
3664         && frame->updatee->header.info == &stg_BLACKHOLE_info) {
3665         break;
3666     }
3667   }
3668
3669   /* Now, we're at the bottom.  Frame points to the lowest update
3670    * frame on the stack, and its link actually points to the frame
3671    * above. We have to walk back up the stack, squeezing out empty
3672    * update frames and turning the pointers back around on the way
3673    * back up.
3674    *
3675    * The bottom-most frame (the STOP_FRAME) has not been altered, and
3676    * we never want to eliminate it anyway.  Just walk one step up
3677    * before starting to squeeze. When you get to the topmost frame,
3678    * remember that there are still some words above it that might have
3679    * to be moved.
3680    */
3681
3682   prev_frame = frame;
3683   frame = next_frame;
3684
3685   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
3686
3687   /*
3688    * Loop through all of the frames (everything except the very
3689    * bottom).  Things are complicated by the fact that we have
3690    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
3691    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
3692    */
3693   while (frame != NULL) {
3694     StgPtr sp;
3695     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
3696     rtsBool is_update_frame;
3697
3698     next_frame = frame->link;
3699     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
3700
3701     /* Check to see if
3702      *   1. both the previous and current frame are update frames
3703      *   2. the current frame is empty
3704      */
3705     if (prev_was_update_frame && is_update_frame &&
3706         (P_)prev_frame == frame_bottom + displacement) {
3707
3708       // Now squeeze out the current frame
3709       StgClosure *updatee_keep   = prev_frame->updatee;
3710       StgClosure *updatee_bypass = frame->updatee;
3711
3712 #if DEBUG
3713       IF_DEBUG(gc, belch("@@ squeezing frame at %p", frame));
3714       squeezes++;
3715 #endif
3716
3717       /* Deal with blocking queues.  If both updatees have blocked
3718        * threads, then we should merge the queues into the update
3719        * frame that we're keeping.
3720        *
3721        * Alternatively, we could just wake them up: they'll just go
3722        * straight to sleep on the proper blackhole!  This is less code
3723        * and probably less bug prone, although it's probably much
3724        * slower --SDM
3725        */
3726 #if 0 // do it properly...
3727 #  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3728 #    error Unimplemented lazy BH warning.  (KSW 1999-01)
3729 #  endif
3730       if (GET_INFO(updatee_bypass) == stg_BLACKHOLE_BQ_info
3731           || GET_INFO(updatee_bypass) == stg_CAF_BLACKHOLE_info
3732           ) {
3733         // Sigh.  It has one.  Don't lose those threads!
3734           if (GET_INFO(updatee_keep) == stg_BLACKHOLE_BQ_info) {
3735           // Urgh.  Two queues.  Merge them.
3736           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
3737
3738           while (keep_tso->link != END_TSO_QUEUE) {
3739             keep_tso = keep_tso->link;
3740           }
3741           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
3742
3743         } else {
3744           // For simplicity, just swap the BQ for the BH
3745           P_ temp = updatee_keep;
3746
3747           updatee_keep = updatee_bypass;
3748           updatee_bypass = temp;
3749
3750           // Record the swap in the kept frame (below)
3751           prev_frame->updatee = updatee_keep;
3752         }
3753       }
3754 #endif
3755
3756       TICK_UPD_SQUEEZED();
3757       /* wasn't there something about update squeezing and ticky to be
3758        * sorted out?  oh yes: we aren't counting each enter properly
3759        * in this case.  See the log somewhere.  KSW 1999-04-21
3760        *
3761        * Check two things: that the two update frames don't point to
3762        * the same object, and that the updatee_bypass isn't already an
3763        * indirection.  Both of these cases only happen when we're in a
3764        * block hole-style loop (and there are multiple update frames
3765        * on the stack pointing to the same closure), but they can both
3766        * screw us up if we don't check.
3767        */
3768       if (updatee_bypass != updatee_keep && !closure_IND(updatee_bypass)) {
3769           // this wakes the threads up
3770           UPD_IND_NOLOCK(updatee_bypass, updatee_keep);
3771       }
3772
3773       sp = (P_)frame - 1;       // sp = stuff to slide
3774       displacement += sizeofW(StgUpdateFrame);
3775
3776     } else {
3777       // No squeeze for this frame
3778       sp = frame_bottom - 1;    // Keep the current frame
3779
3780       /* Do lazy black-holing.
3781        */
3782       if (is_update_frame) {
3783         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
3784         if (bh->header.info != &stg_BLACKHOLE_info &&
3785             bh->header.info != &stg_BLACKHOLE_BQ_info &&
3786             bh->header.info != &stg_CAF_BLACKHOLE_info) {
3787 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3788           belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3789 #endif
3790 #ifdef DEBUG
3791           /* zero out the slop so that the sanity checker can tell
3792            * where the next closure is.
3793            */
3794           {
3795               StgInfoTable *info = get_itbl(bh);
3796               nat np = info->layout.payload.ptrs, nw = info->layout.payload.nptrs, i;
3797               /* don't zero out slop for a THUNK_SELECTOR, because its layout
3798                * info is used for a different purpose, and it's exactly the
3799                * same size as a BLACKHOLE in any case.
3800                */
3801               if (info->type != THUNK_SELECTOR) {
3802                 for (i = np; i < np + nw; i++) {
3803                   ((StgClosure *)bh)->payload[i] = 0;
3804                 }
3805               }
3806           }
3807 #endif
3808           SET_INFO(bh,&stg_BLACKHOLE_info);
3809         }
3810       }
3811
3812       // Fix the link in the current frame (should point to the frame below)
3813       frame->link = prev_frame;
3814       prev_was_update_frame = is_update_frame;
3815     }
3816
3817     // Now slide all words from sp up to the next frame
3818
3819     if (displacement > 0) {
3820       P_ next_frame_bottom;
3821
3822       if (next_frame != NULL)
3823         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
3824       else
3825         next_frame_bottom = tso->sp - 1;
3826
3827 #if 0
3828       IF_DEBUG(gc,
3829                belch("sliding [%p, %p] by %ld", sp, next_frame_bottom,
3830                      displacement))
3831 #endif
3832
3833       while (sp >= next_frame_bottom) {
3834         sp[displacement] = *sp;
3835         sp -= 1;
3836       }
3837     }
3838     (P_)prev_frame = (P_)frame + displacement;
3839     frame = next_frame;
3840   }
3841
3842   tso->sp += displacement;
3843   tso->su = prev_frame;
3844 #if 0
3845   IF_DEBUG(gc,
3846            belch("@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames",
3847                    squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
3848 #endif
3849 }
3850
3851
3852 /* -----------------------------------------------------------------------------
3853  * Pausing a thread
3854  *
3855  * We have to prepare for GC - this means doing lazy black holing
3856  * here.  We also take the opportunity to do stack squeezing if it's
3857  * turned on.
3858  * -------------------------------------------------------------------------- */
3859 void
3860 threadPaused(StgTSO *tso)
3861 {
3862   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
3863     threadSqueezeStack(tso);    // does black holing too
3864   else
3865     threadLazyBlackHole(tso);
3866 }
3867
3868 /* -----------------------------------------------------------------------------
3869  * Debugging
3870  * -------------------------------------------------------------------------- */
3871
3872 #if DEBUG
3873 void
3874 printMutOnceList(generation *gen)
3875 {
3876   StgMutClosure *p, *next;
3877
3878   p = gen->mut_once_list;
3879   next = p->mut_link;
3880
3881   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
3882   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3883     fprintf(stderr, "%p (%s), ",
3884             p, info_type((StgClosure *)p));
3885   }
3886   fputc('\n', stderr);
3887 }
3888
3889 void
3890 printMutableList(generation *gen)
3891 {
3892   StgMutClosure *p, *next;
3893
3894   p = gen->mut_list;
3895   next = p->mut_link;
3896
3897   fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
3898   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3899     fprintf(stderr, "%p (%s), ",
3900             p, info_type((StgClosure *)p));
3901   }
3902   fputc('\n', stderr);
3903 }
3904
3905 static inline rtsBool
3906 maybeLarge(StgClosure *closure)
3907 {
3908   StgInfoTable *info = get_itbl(closure);
3909
3910   /* closure types that may be found on the new_large_objects list;
3911      see scavenge_large */
3912   return (info->type == MUT_ARR_PTRS ||
3913           info->type == MUT_ARR_PTRS_FROZEN ||
3914           info->type == TSO ||
3915           info->type == ARR_WORDS);
3916 }
3917
3918
3919 #endif // DEBUG