ghc/rts/GC.c

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