ghc/rts/GC.c

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