ghc/rts/GC.c

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