ghc/rts/GC.c

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