ghc/rts/GC.c

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