ghc/rts/GC.c

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