ghc/rts/GC.c

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