ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.133 2002/04/13 05:16:25 sof 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   RELEASE_LOCK(&sched_mutex);
 989
 990   // start any pending finalizers
 991   scheduleFinalizers(old_weak_ptr_list);
 992
 993   ACQUIRE_LOCK(&sched_mutex);
 994
 995   // send exceptions to any threads which were about to die
 996   resurrectThreads(resurrected_threads);
 997
 998   // Update the stable pointer hash table.
 999   updateStablePtrTable(major_gc);
1000
1001   // check sanity after GC
1002   IF_DEBUG(sanity, checkSanity());
1003
1004   // extra GC trace info
1005   IF_DEBUG(gc, statDescribeGens());
1006
1007 #ifdef DEBUG
1008   // symbol-table based profiling
1009   /*  heapCensus(to_blocks); */ /* ToDo */
1010 #endif
1011
1012   // restore enclosing cost centre
1013 #ifdef PROFILING
1014   CCCS = prev_CCS;
1015 #endif
1016
1017   // check for memory leaks if sanity checking is on
1018   IF_DEBUG(sanity, memInventory());
1019
1020 #ifdef RTS_GTK_FRONTPANEL
1021   if (RtsFlags.GcFlags.frontpanel) {
1022       updateFrontPanelAfterGC( N, live );
1023   }
1024 #endif
1025
1026   // ok, GC over: tell the stats department what happened.
1027   stat_endGC(allocated, collected, live, copied, N);
1028
1029   //PAR_TICKY_TP();
1030 }
1031
1032
1033 /* -----------------------------------------------------------------------------
1034    Weak Pointers
1035
1036    traverse_weak_ptr_list is called possibly many times during garbage
1037    collection.  It returns a flag indicating whether it did any work
1038    (i.e. called evacuate on any live pointers).
1039
1040    Invariant: traverse_weak_ptr_list is called when the heap is in an
1041    idempotent state.  That means that there are no pending
1042    evacuate/scavenge operations.  This invariant helps the weak
1043    pointer code decide which weak pointers are dead - if there are no
1044    new live weak pointers, then all the currently unreachable ones are
1045    dead.
1046
1047    For generational GC: we just don't try to finalize weak pointers in
1048    older generations than the one we're collecting.  This could
1049    probably be optimised by keeping per-generation lists of weak
1050    pointers, but for a few weak pointers this scheme will work.
1051
1052    There are three distinct stages to processing weak pointers:
1053
1054    - weak_stage == WeakPtrs
1055
1056      We process all the weak pointers whos keys are alive (evacuate
1057      their values and finalizers), and repeat until we can find no new
1058      live keys.  If no live keys are found in this pass, then we
1059      evacuate the finalizers of all the dead weak pointers in order to
1060      run them.
1061
1062    - weak_stage == WeakThreads
1063
1064      Now, we discover which *threads* are still alive.  Pointers to
1065      threads from the all_threads and main thread lists are the
1066      weakest of all: a pointers from the finalizer of a dead weak
1067      pointer can keep a thread alive.  Any threads found to be unreachable
1068      are evacuated and placed on the resurrected_threads list so we
1069      can send them a signal later.
1070
1071    - weak_stage == WeakDone
1072
1073      No more evacuation is done.
1074
1075    -------------------------------------------------------------------------- */
1076
1077 static rtsBool
1078 traverse_weak_ptr_list(void)
1079 {
1080   StgWeak *w, **last_w, *next_w;
1081   StgClosure *new;
1082   rtsBool flag = rtsFalse;
1083
1084   switch (weak_stage) {
1085
1086   case WeakDone:
1087       return rtsFalse;
1088
1089   case WeakPtrs:
1090       /* doesn't matter where we evacuate values/finalizers to, since
1091        * these pointers are treated as roots (iff the keys are alive).
1092        */
1093       evac_gen = 0;
1094
1095       last_w = &old_weak_ptr_list;
1096       for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1097
1098           /* There might be a DEAD_WEAK on the list if finalizeWeak# was
1099            * called on a live weak pointer object.  Just remove it.
1100            */
1101           if (w->header.info == &stg_DEAD_WEAK_info) {
1102               next_w = ((StgDeadWeak *)w)->link;
1103               *last_w = next_w;
1104               continue;
1105           }
1106
1107           ASSERT(get_itbl(w)->type == WEAK);
1108
1109           /* Now, check whether the key is reachable.
1110            */
1111           new = isAlive(w->key);
1112           if (new != NULL) {
1113               w->key = new;
1114               // evacuate the value and finalizer
1115               w->value = evacuate(w->value);
1116               w->finalizer = evacuate(w->finalizer);
1117               // remove this weak ptr from the old_weak_ptr list
1118               *last_w = w->link;
1119               // and put it on the new weak ptr list
1120               next_w  = w->link;
1121               w->link = weak_ptr_list;
1122               weak_ptr_list = w;
1123               flag = rtsTrue;
1124               IF_DEBUG(weak, belch("Weak pointer still alive at %p -> %p",
1125                                    w, w->key));
1126               continue;
1127           }
1128           else {
1129               last_w = &(w->link);
1130               next_w = w->link;
1131               continue;
1132           }
1133       }
1134
1135       /* If we didn't make any changes, then we can go round and kill all
1136        * the dead weak pointers.  The old_weak_ptr list is used as a list
1137        * of pending finalizers later on.
1138        */
1139       if (flag == rtsFalse) {
1140           for (w = old_weak_ptr_list; w; w = w->link) {
1141               w->finalizer = evacuate(w->finalizer);
1142           }
1143
1144           // Next, move to the WeakThreads stage after fully
1145           // scavenging the finalizers we've just evacuated.
1146           weak_stage = WeakThreads;
1147       }
1148
1149       return rtsTrue;
1150
1151   case WeakThreads:
1152       /* Now deal with the all_threads list, which behaves somewhat like
1153        * the weak ptr list.  If we discover any threads that are about to
1154        * become garbage, we wake them up and administer an exception.
1155        */
1156       {
1157           StgTSO *t, *tmp, *next, **prev;
1158
1159           prev = &old_all_threads;
1160           for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1161
1162               (StgClosure *)tmp = isAlive((StgClosure *)t);
1163
1164               if (tmp != NULL) {
1165                   t = tmp;
1166               }
1167
1168               ASSERT(get_itbl(t)->type == TSO);
1169               switch (t->what_next) {
1170               case ThreadRelocated:
1171                   next = t->link;
1172                   *prev = next;
1173                   continue;
1174               case ThreadKilled:
1175               case ThreadComplete:
1176                   // finshed or died.  The thread might still be alive, but we
1177                   // don't keep it on the all_threads list.  Don't forget to
1178                   // stub out its global_link field.
1179                   next = t->global_link;
1180                   t->global_link = END_TSO_QUEUE;
1181                   *prev = next;
1182                   continue;
1183               default:
1184                   ;
1185               }
1186
1187               if (tmp == NULL) {
1188                   // not alive (yet): leave this thread on the
1189                   // old_all_threads list.
1190                   prev = &(t->global_link);
1191                   next = t->global_link;
1192               }
1193               else {
1194                   // alive: move this thread onto the all_threads list.
1195                   next = t->global_link;
1196                   t->global_link = all_threads;
1197                   all_threads  = t;
1198                   *prev = next;
1199               }
1200           }
1201       }
1202
1203       /* And resurrect any threads which were about to become garbage.
1204        */
1205       {
1206           StgTSO *t, *tmp, *next;
1207           for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
1208               next = t->global_link;
1209               (StgClosure *)tmp = evacuate((StgClosure *)t);
1210               tmp->global_link = resurrected_threads;
1211               resurrected_threads = tmp;
1212           }
1213       }
1214
1215       weak_stage = WeakDone;  // *now* we're done,
1216       return rtsTrue;         // but one more round of scavenging, please
1217
1218   default:
1219       barf("traverse_weak_ptr_list");
1220   }
1221
1222 }
1223
1224 /* -----------------------------------------------------------------------------
1225    After GC, the live weak pointer list may have forwarding pointers
1226    on it, because a weak pointer object was evacuated after being
1227    moved to the live weak pointer list.  We remove those forwarding
1228    pointers here.
1229
1230    Also, we don't consider weak pointer objects to be reachable, but
1231    we must nevertheless consider them to be "live" and retain them.
1232    Therefore any weak pointer objects which haven't as yet been
1233    evacuated need to be evacuated now.
1234    -------------------------------------------------------------------------- */
1235
1236
1237 static void
1238 mark_weak_ptr_list ( StgWeak **list )
1239 {
1240   StgWeak *w, **last_w;
1241
1242   last_w = list;
1243   for (w = *list; w; w = w->link) {
1244       (StgClosure *)w = evacuate((StgClosure *)w);
1245       *last_w = w;
1246       last_w = &(w->link);
1247   }
1248 }
1249
1250 /* -----------------------------------------------------------------------------
1251    isAlive determines whether the given closure is still alive (after
1252    a garbage collection) or not.  It returns the new address of the
1253    closure if it is alive, or NULL otherwise.
1254
1255    NOTE: Use it before compaction only!
1256    -------------------------------------------------------------------------- */
1257
1258
1259 StgClosure *
1260 isAlive(StgClosure *p)
1261 {
1262   const StgInfoTable *info;
1263   bdescr *bd;
1264
1265   while (1) {
1266
1267     info = get_itbl(p);
1268
1269     /* ToDo: for static closures, check the static link field.
1270      * Problem here is that we sometimes don't set the link field, eg.
1271      * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
1272      */
1273
1274   loop:
1275     bd = Bdescr((P_)p);
1276     // ignore closures in generations that we're not collecting.
1277     if (LOOKS_LIKE_STATIC(p) || bd->gen_no > N) {
1278         return p;
1279     }
1280     // large objects have an evacuated flag
1281     if (bd->flags & BF_LARGE) {
1282         if (bd->flags & BF_EVACUATED) {
1283             return p;
1284         } else {
1285             return NULL;
1286         }
1287     }
1288     // check the mark bit for compacted steps
1289     if (bd->step->is_compacted && is_marked((P_)p,bd)) {
1290         return p;
1291     }
1292
1293     switch (info->type) {
1294
1295     case IND:
1296     case IND_STATIC:
1297     case IND_PERM:
1298     case IND_OLDGEN:            // rely on compatible layout with StgInd
1299     case IND_OLDGEN_PERM:
1300       // follow indirections
1301       p = ((StgInd *)p)->indirectee;
1302       continue;
1303
1304     case EVACUATED:
1305       // alive!
1306       return ((StgEvacuated *)p)->evacuee;
1307
1308     case TSO:
1309       if (((StgTSO *)p)->what_next == ThreadRelocated) {
1310         p = (StgClosure *)((StgTSO *)p)->link;
1311         goto loop;
1312       }
1313
1314     default:
1315       // dead.
1316       return NULL;
1317     }
1318   }
1319 }
1320
1321 static void
1322 mark_root(StgClosure **root)
1323 {
1324   *root = evacuate(*root);
1325 }
1326
1327 static void
1328 addBlock(step *stp)
1329 {
1330   bdescr *bd = allocBlock();
1331   bd->gen_no = stp->gen_no;
1332   bd->step = stp;
1333
1334   if (stp->gen_no <= N) {
1335     bd->flags = BF_EVACUATED;
1336   } else {
1337     bd->flags = 0;
1338   }
1339
1340   stp->hp_bd->free = stp->hp;
1341   stp->hp_bd->link = bd;
1342   stp->hp = bd->start;
1343   stp->hpLim = stp->hp + BLOCK_SIZE_W;
1344   stp->hp_bd = bd;
1345   stp->n_to_blocks++;
1346   new_blocks++;
1347 }
1348
1349
1350 static __inline__ void
1351 upd_evacuee(StgClosure *p, StgClosure *dest)
1352 {
1353   p->header.info = &stg_EVACUATED_info;
1354   ((StgEvacuated *)p)->evacuee = dest;
1355 }
1356
1357
1358 static __inline__ StgClosure *
1359 copy(StgClosure *src, nat size, step *stp)
1360 {
1361   P_ to, from, dest;
1362 #ifdef PROFILING
1363   // @LDV profiling
1364   nat size_org = size;
1365 #endif
1366
1367   TICK_GC_WORDS_COPIED(size);
1368   /* Find out where we're going, using the handy "to" pointer in
1369    * the step of the source object.  If it turns out we need to
1370    * evacuate to an older generation, adjust it here (see comment
1371    * by evacuate()).
1372    */
1373   if (stp->gen_no < evac_gen) {
1374 #ifdef NO_EAGER_PROMOTION
1375     failed_to_evac = rtsTrue;
1376 #else
1377     stp = &generations[evac_gen].steps[0];
1378 #endif
1379   }
1380
1381   /* chain a new block onto the to-space for the destination step if
1382    * necessary.
1383    */
1384   if (stp->hp + size >= stp->hpLim) {
1385     addBlock(stp);
1386   }
1387
1388   for(to = stp->hp, from = (P_)src; size>0; --size) {
1389     *to++ = *from++;
1390   }
1391
1392   dest = stp->hp;
1393   stp->hp = to;
1394   upd_evacuee(src,(StgClosure *)dest);
1395 #ifdef PROFILING
1396   // We store the size of the just evacuated object in the LDV word so that
1397   // the profiler can guess the position of the next object later.
1398   SET_EVACUAEE_FOR_LDV(src, size_org);
1399 #endif
1400   return (StgClosure *)dest;
1401 }
1402
1403 /* Special version of copy() for when we only want to copy the info
1404  * pointer of an object, but reserve some padding after it.  This is
1405  * used to optimise evacuation of BLACKHOLEs.
1406  */
1407
1408
1409 static StgClosure *
1410 copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
1411 {
1412   P_ dest, to, from;
1413 #ifdef PROFILING
1414   // @LDV profiling
1415   nat size_to_copy_org = size_to_copy;
1416 #endif
1417
1418   TICK_GC_WORDS_COPIED(size_to_copy);
1419   if (stp->gen_no < evac_gen) {
1420 #ifdef NO_EAGER_PROMOTION
1421     failed_to_evac = rtsTrue;
1422 #else
1423     stp = &generations[evac_gen].steps[0];
1424 #endif
1425   }
1426
1427   if (stp->hp + size_to_reserve >= stp->hpLim) {
1428     addBlock(stp);
1429   }
1430
1431   for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
1432     *to++ = *from++;
1433   }
1434
1435   dest = stp->hp;
1436   stp->hp += size_to_reserve;
1437   upd_evacuee(src,(StgClosure *)dest);
1438 #ifdef PROFILING
1439   // We store the size of the just evacuated object in the LDV word so that
1440   // the profiler can guess the position of the next object later.
1441   // size_to_copy_org is wrong because the closure already occupies size_to_reserve
1442   // words.
1443   SET_EVACUAEE_FOR_LDV(src, size_to_reserve);
1444   // fill the slop
1445   if (size_to_reserve - size_to_copy_org > 0)
1446     FILL_SLOP(stp->hp - 1, (int)(size_to_reserve - size_to_copy_org));
1447 #endif
1448   return (StgClosure *)dest;
1449 }
1450
1451
1452 /* -----------------------------------------------------------------------------
1453    Evacuate a large object
1454
1455    This just consists of removing the object from the (doubly-linked)
1456    large_alloc_list, and linking it on to the (singly-linked)
1457    new_large_objects list, from where it will be scavenged later.
1458
1459    Convention: bd->flags has BF_EVACUATED set for a large object
1460    that has been evacuated, or unset otherwise.
1461    -------------------------------------------------------------------------- */
1462
1463
1464 static inline void
1465 evacuate_large(StgPtr p)
1466 {
1467   bdescr *bd = Bdescr(p);
1468   step *stp;
1469
1470   // object must be at the beginning of the block (or be a ByteArray)
1471   ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
1472          (((W_)p & BLOCK_MASK) == 0));
1473
1474   // already evacuated?
1475   if (bd->flags & BF_EVACUATED) {
1476     /* Don't forget to set the failed_to_evac flag if we didn't get
1477      * the desired destination (see comments in evacuate()).
1478      */
1479     if (bd->gen_no < evac_gen) {
1480       failed_to_evac = rtsTrue;
1481       TICK_GC_FAILED_PROMOTION();
1482     }
1483     return;
1484   }
1485
1486   stp = bd->step;
1487   // remove from large_object list
1488   if (bd->u.back) {
1489     bd->u.back->link = bd->link;
1490   } else { // first object in the list
1491     stp->large_objects = bd->link;
1492   }
1493   if (bd->link) {
1494     bd->link->u.back = bd->u.back;
1495   }
1496
1497   /* link it on to the evacuated large object list of the destination step
1498    */
1499   stp = bd->step->to;
1500   if (stp->gen_no < evac_gen) {
1501 #ifdef NO_EAGER_PROMOTION
1502     failed_to_evac = rtsTrue;
1503 #else
1504     stp = &generations[evac_gen].steps[0];
1505 #endif
1506   }
1507
1508   bd->step = stp;
1509   bd->gen_no = stp->gen_no;
1510   bd->link = stp->new_large_objects;
1511   stp->new_large_objects = bd;
1512   bd->flags |= BF_EVACUATED;
1513 }
1514
1515 /* -----------------------------------------------------------------------------
1516    Adding a MUT_CONS to an older generation.
1517
1518    This is necessary from time to time when we end up with an
1519    old-to-new generation pointer in a non-mutable object.  We defer
1520    the promotion until the next GC.
1521    -------------------------------------------------------------------------- */
1522
1523
1524 static StgClosure *
1525 mkMutCons(StgClosure *ptr, generation *gen)
1526 {
1527   StgMutVar *q;
1528   step *stp;
1529
1530   stp = &gen->steps[0];
1531
1532   /* chain a new block onto the to-space for the destination step if
1533    * necessary.
1534    */
1535   if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
1536     addBlock(stp);
1537   }
1538
1539   q = (StgMutVar *)stp->hp;
1540   stp->hp += sizeofW(StgMutVar);
1541
1542   SET_HDR(q,&stg_MUT_CONS_info,CCS_GC);
1543   q->var = ptr;
1544   recordOldToNewPtrs((StgMutClosure *)q);
1545
1546   return (StgClosure *)q;
1547 }
1548
1549 /* -----------------------------------------------------------------------------
1550    Evacuate
1551
1552    This is called (eventually) for every live object in the system.
1553
1554    The caller to evacuate specifies a desired generation in the
1555    evac_gen global variable.  The following conditions apply to
1556    evacuating an object which resides in generation M when we're
1557    collecting up to generation N
1558
1559    if  M >= evac_gen
1560            if  M > N     do nothing
1561            else          evac to step->to
1562
1563    if  M < evac_gen      evac to evac_gen, step 0
1564
1565    if the object is already evacuated, then we check which generation
1566    it now resides in.
1567
1568    if  M >= evac_gen     do nothing
1569    if  M <  evac_gen     set failed_to_evac flag to indicate that we
1570                          didn't manage to evacuate this object into evac_gen.
1571
1572    -------------------------------------------------------------------------- */
1573
1574 static StgClosure *
1575 evacuate(StgClosure *q)
1576 {
1577   StgClosure *to;
1578   bdescr *bd = NULL;
1579   step *stp;
1580   const StgInfoTable *info;
1581
1582 loop:
1583   if (HEAP_ALLOCED(q)) {
1584     bd = Bdescr((P_)q);
1585
1586     // not a group head: find the group head
1587     if (bd->blocks == 0) { bd = bd->link; }
1588
1589     if (bd->gen_no > N) {
1590         /* Can't evacuate this object, because it's in a generation
1591          * older than the ones we're collecting.  Let's hope that it's
1592          * in evac_gen or older, or we will have to arrange to track
1593          * this pointer using the mutable list.
1594          */
1595         if (bd->gen_no < evac_gen) {
1596             // nope
1597             failed_to_evac = rtsTrue;
1598             TICK_GC_FAILED_PROMOTION();
1599         }
1600         return q;
1601     }
1602
1603     /* evacuate large objects by re-linking them onto a different list.
1604      */
1605     if (bd->flags & BF_LARGE) {
1606         info = get_itbl(q);
1607         if (info->type == TSO &&
1608             ((StgTSO *)q)->what_next == ThreadRelocated) {
1609             q = (StgClosure *)((StgTSO *)q)->link;
1610             goto loop;
1611         }
1612         evacuate_large((P_)q);
1613         return q;
1614     }
1615
1616     /* If the object is in a step that we're compacting, then we
1617      * need to use an alternative evacuate procedure.
1618      */
1619     if (bd->step->is_compacted) {
1620         if (!is_marked((P_)q,bd)) {
1621             mark((P_)q,bd);
1622             if (mark_stack_full()) {
1623                 mark_stack_overflowed = rtsTrue;
1624                 reset_mark_stack();
1625             }
1626             push_mark_stack((P_)q);
1627         }
1628         return q;
1629     }
1630
1631     stp = bd->step->to;
1632   }
1633 #ifdef DEBUG
1634   else stp = NULL; // make sure copy() will crash if HEAP_ALLOCED is wrong
1635 #endif
1636
1637   // make sure the info pointer is into text space
1638   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
1639                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
1640   info = get_itbl(q);
1641
1642   switch (info -> type) {
1643
1644   case MUT_VAR:
1645   case MVAR:
1646       to = copy(q,sizeW_fromITBL(info),stp);
1647       return to;
1648
1649   case CONSTR_0_1:
1650   {
1651       StgWord w = (StgWord)q->payload[0];
1652       if (q->header.info == Czh_con_info &&
1653           // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&
1654           (StgChar)w <= MAX_CHARLIKE) {
1655           return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1656       }
1657       if (q->header.info == Izh_con_info &&
1658           (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1659           return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1660       }
1661       // else, fall through ...
1662   }
1663
1664   case FUN_1_0:
1665   case FUN_0_1:
1666   case CONSTR_1_0:
1667     return copy(q,sizeofW(StgHeader)+1,stp);
1668
1669   case THUNK_1_0:               // here because of MIN_UPD_SIZE
1670   case THUNK_0_1:
1671   case THUNK_1_1:
1672   case THUNK_0_2:
1673   case THUNK_2_0:
1674 #ifdef NO_PROMOTE_THUNKS
1675     if (bd->gen_no == 0 &&
1676         bd->step->no != 0 &&
1677         bd->step->no == generations[bd->gen_no].n_steps-1) {
1678       stp = bd->step;
1679     }
1680 #endif
1681     return copy(q,sizeofW(StgHeader)+2,stp);
1682
1683   case FUN_1_1:
1684   case FUN_0_2:
1685   case FUN_2_0:
1686   case CONSTR_1_1:
1687   case CONSTR_0_2:
1688   case CONSTR_2_0:
1689     return copy(q,sizeofW(StgHeader)+2,stp);
1690
1691   case FUN:
1692   case THUNK:
1693   case CONSTR:
1694   case IND_PERM:
1695   case IND_OLDGEN_PERM:
1696   case WEAK:
1697   case FOREIGN:
1698   case STABLE_NAME:
1699   case BCO:
1700     return copy(q,sizeW_fromITBL(info),stp);
1701
1702   case CAF_BLACKHOLE:
1703   case SE_CAF_BLACKHOLE:
1704   case SE_BLACKHOLE:
1705   case BLACKHOLE:
1706     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
1707
1708   case BLACKHOLE_BQ:
1709     to = copy(q,BLACKHOLE_sizeW(),stp);
1710     return to;
1711
1712   case THUNK_SELECTOR:
1713     {
1714       const StgInfoTable* selectee_info;
1715       StgClosure* selectee = ((StgSelector*)q)->selectee;
1716
1717     selector_loop:
1718       selectee_info = get_itbl(selectee);
1719       switch (selectee_info->type) {
1720       case CONSTR:
1721       case CONSTR_1_0:
1722       case CONSTR_0_1:
1723       case CONSTR_2_0:
1724       case CONSTR_1_1:
1725       case CONSTR_0_2:
1726       case CONSTR_STATIC:
1727       case CONSTR_NOCAF_STATIC:
1728         {
1729           StgWord offset = info->layout.selector_offset;
1730
1731           // check that the size is in range
1732           ASSERT(offset <
1733                  (StgWord32)(selectee_info->layout.payload.ptrs +
1734                             selectee_info->layout.payload.nptrs));
1735
1736           // perform the selection!
1737           q = selectee->payload[offset];
1738           if (major_gc==rtsTrue) {TICK_GC_SEL_MAJOR();} else {TICK_GC_SEL_MINOR();}
1739
1740           /* if we're already in to-space, there's no need to continue
1741            * with the evacuation, just update the source address with
1742            * a pointer to the (evacuated) constructor field.
1743            */
1744           if (HEAP_ALLOCED(q)) {
1745             bdescr *bd = Bdescr((P_)q);
1746             if (bd->flags & BF_EVACUATED) {
1747               if (bd->gen_no < evac_gen) {
1748                 failed_to_evac = rtsTrue;
1749                 TICK_GC_FAILED_PROMOTION();
1750               }
1751               return q;
1752             }
1753           }
1754
1755           /* otherwise, carry on and evacuate this constructor field,
1756            * (but not the constructor itself)
1757            */
1758           goto loop;
1759         }
1760
1761       case IND:
1762       case IND_STATIC:
1763       case IND_PERM:
1764       case IND_OLDGEN:
1765       case IND_OLDGEN_PERM:
1766         selectee = ((StgInd *)selectee)->indirectee;
1767         goto selector_loop;
1768
1769       case EVACUATED:
1770         selectee = ((StgEvacuated *)selectee)->evacuee;
1771         goto selector_loop;
1772
1773       case THUNK_SELECTOR:
1774 #         if 0
1775           /* Disabled 03 April 2001 by JRS; it seems to cause the GC (or
1776              something) to go into an infinite loop when the nightly
1777              stage2 compiles PrelTup.lhs. */
1778
1779           /* we can't recurse indefinitely in evacuate(), so set a
1780            * limit on the number of times we can go around this
1781            * loop.
1782            */
1783           if (thunk_selector_depth < MAX_THUNK_SELECTOR_DEPTH) {
1784               bdescr *bd;
1785               bd = Bdescr((P_)selectee);
1786               if (!bd->flags & BF_EVACUATED) {
1787                   thunk_selector_depth++;
1788                   selectee = evacuate(selectee);
1789                   thunk_selector_depth--;
1790                   goto selector_loop;
1791               }
1792           } else {
1793               TICK_GC_SEL_ABANDONED();
1794               // and fall through...
1795           }
1796 #         endif
1797
1798       case AP_UPD:
1799       case THUNK:
1800       case THUNK_1_0:
1801       case THUNK_0_1:
1802       case THUNK_2_0:
1803       case THUNK_1_1:
1804       case THUNK_0_2:
1805       case THUNK_STATIC:
1806       case CAF_BLACKHOLE:
1807       case SE_CAF_BLACKHOLE:
1808       case SE_BLACKHOLE:
1809       case BLACKHOLE:
1810       case BLACKHOLE_BQ:
1811         // not evaluated yet
1812         break;
1813
1814 #if defined(PAR)
1815         // a copy of the top-level cases below
1816       case RBH: // cf. BLACKHOLE_BQ
1817         {
1818           //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1819           to = copy(q,BLACKHOLE_sizeW(),stp);
1820           //ToDo: derive size etc from reverted IP
1821           //to = copy(q,size,stp);
1822           // recordMutable((StgMutClosure *)to);
1823           return to;
1824         }
1825
1826       case BLOCKED_FETCH:
1827         ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1828         to = copy(q,sizeofW(StgBlockedFetch),stp);
1829         return to;
1830
1831 # ifdef DIST
1832       case REMOTE_REF:
1833 # endif
1834       case FETCH_ME:
1835         ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1836         to = copy(q,sizeofW(StgFetchMe),stp);
1837         return to;
1838
1839       case FETCH_ME_BQ:
1840         ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1841         to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
1842         return to;
1843 #endif
1844
1845       default:
1846         barf("evacuate: THUNK_SELECTOR: strange selectee %d",
1847              (int)(selectee_info->type));
1848       }
1849     }
1850     return copy(q,THUNK_SELECTOR_sizeW(),stp);
1851
1852   case IND:
1853   case IND_OLDGEN:
1854     // follow chains of indirections, don't evacuate them
1855     q = ((StgInd*)q)->indirectee;
1856     goto loop;
1857
1858   case THUNK_STATIC:
1859     if (info->srt_len > 0 && major_gc &&
1860         THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
1861       THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
1862       static_objects = (StgClosure *)q;
1863     }
1864     return q;
1865
1866   case FUN_STATIC:
1867     if (info->srt_len > 0 && major_gc &&
1868         FUN_STATIC_LINK((StgClosure *)q) == NULL) {
1869       FUN_STATIC_LINK((StgClosure *)q) = static_objects;
1870       static_objects = (StgClosure *)q;
1871     }
1872     return q;
1873
1874   case IND_STATIC:
1875     /* If q->saved_info != NULL, then it's a revertible CAF - it'll be
1876      * on the CAF list, so don't do anything with it here (we'll
1877      * scavenge it later).
1878      */
1879     if (major_gc
1880           && ((StgIndStatic *)q)->saved_info == NULL
1881           && IND_STATIC_LINK((StgClosure *)q) == NULL) {
1882         IND_STATIC_LINK((StgClosure *)q) = static_objects;
1883         static_objects = (StgClosure *)q;
1884     }
1885     return q;
1886
1887   case CONSTR_STATIC:
1888     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1889       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1890       static_objects = (StgClosure *)q;
1891     }
1892     return q;
1893
1894   case CONSTR_INTLIKE:
1895   case CONSTR_CHARLIKE:
1896   case CONSTR_NOCAF_STATIC:
1897     /* no need to put these on the static linked list, they don't need
1898      * to be scavenged.
1899      */
1900     return q;
1901
1902   case RET_BCO:
1903   case RET_SMALL:
1904   case RET_VEC_SMALL:
1905   case RET_BIG:
1906   case RET_VEC_BIG:
1907   case RET_DYN:
1908   case UPDATE_FRAME:
1909   case STOP_FRAME:
1910   case CATCH_FRAME:
1911   case SEQ_FRAME:
1912     // shouldn't see these
1913     barf("evacuate: stack frame at %p\n", q);
1914
1915   case AP_UPD:
1916   case PAP:
1917     /* PAPs and AP_UPDs are special - the payload is a copy of a chunk
1918      * of stack, tagging and all.
1919      */
1920       return copy(q,pap_sizeW((StgPAP*)q),stp);
1921
1922   case EVACUATED:
1923     /* Already evacuated, just return the forwarding address.
1924      * HOWEVER: if the requested destination generation (evac_gen) is
1925      * older than the actual generation (because the object was
1926      * already evacuated to a younger generation) then we have to
1927      * set the failed_to_evac flag to indicate that we couldn't
1928      * manage to promote the object to the desired generation.
1929      */
1930     if (evac_gen > 0) {         // optimisation
1931       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1932       if (Bdescr((P_)p)->gen_no < evac_gen) {
1933         failed_to_evac = rtsTrue;
1934         TICK_GC_FAILED_PROMOTION();
1935       }
1936     }
1937     return ((StgEvacuated*)q)->evacuee;
1938
1939   case ARR_WORDS:
1940       // just copy the block
1941       return copy(q,arr_words_sizeW((StgArrWords *)q),stp);
1942
1943   case MUT_ARR_PTRS:
1944   case MUT_ARR_PTRS_FROZEN:
1945       // just copy the block
1946       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
1947
1948   case TSO:
1949     {
1950       StgTSO *tso = (StgTSO *)q;
1951
1952       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
1953        */
1954       if (tso->what_next == ThreadRelocated) {
1955         q = (StgClosure *)tso->link;
1956         goto loop;
1957       }
1958
1959       /* To evacuate a small TSO, we need to relocate the update frame
1960        * list it contains.
1961        */
1962       {
1963           StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),stp);
1964           move_TSO(tso, new_tso);
1965           return (StgClosure *)new_tso;
1966       }
1967     }
1968
1969 #if defined(PAR)
1970   case RBH: // cf. BLACKHOLE_BQ
1971     {
1972       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
1973       to = copy(q,BLACKHOLE_sizeW(),stp);
1974       //ToDo: derive size etc from reverted IP
1975       //to = copy(q,size,stp);
1976       IF_DEBUG(gc,
1977                belch("@@ evacuate: RBH %p (%s) to %p (%s)",
1978                      q, info_type(q), to, info_type(to)));
1979       return to;
1980     }
1981
1982   case BLOCKED_FETCH:
1983     ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
1984     to = copy(q,sizeofW(StgBlockedFetch),stp);
1985     IF_DEBUG(gc,
1986              belch("@@ evacuate: %p (%s) to %p (%s)",
1987                    q, info_type(q), to, info_type(to)));
1988     return to;
1989
1990 # ifdef DIST
1991   case REMOTE_REF:
1992 # endif
1993   case FETCH_ME:
1994     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
1995     to = copy(q,sizeofW(StgFetchMe),stp);
1996     IF_DEBUG(gc,
1997              belch("@@ evacuate: %p (%s) to %p (%s)",
1998                    q, info_type(q), to, info_type(to)));
1999     return to;
2000
2001   case FETCH_ME_BQ:
2002     ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
2003     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2004     IF_DEBUG(gc,
2005              belch("@@ evacuate: %p (%s) to %p (%s)",
2006                    q, info_type(q), to, info_type(to)));
2007     return to;
2008 #endif
2009
2010   default:
2011     barf("evacuate: strange closure type %d", (int)(info->type));
2012   }
2013
2014   barf("evacuate");
2015 }
2016
2017 /* -----------------------------------------------------------------------------
2018    move_TSO is called to update the TSO structure after it has been
2019    moved from one place to another.
2020    -------------------------------------------------------------------------- */
2021
2022 void
2023 move_TSO(StgTSO *src, StgTSO *dest)
2024 {
2025     ptrdiff_t diff;
2026
2027     // relocate the stack pointers...
2028     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2029     dest->sp = (StgPtr)dest->sp + diff;
2030     dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
2031
2032     relocate_stack(dest, diff);
2033 }
2034
2035 /* -----------------------------------------------------------------------------
2036    relocate_stack is called to update the linkage between
2037    UPDATE_FRAMEs (and SEQ_FRAMEs etc.) when a stack is moved from one
2038    place to another.
2039    -------------------------------------------------------------------------- */
2040
2041 StgTSO *
2042 relocate_stack(StgTSO *dest, ptrdiff_t diff)
2043 {
2044   StgUpdateFrame *su;
2045   StgCatchFrame  *cf;
2046   StgSeqFrame    *sf;
2047
2048   su = dest->su;
2049
2050   while ((P_)su < dest->stack + dest->stack_size) {
2051     switch (get_itbl(su)->type) {
2052
2053       // GCC actually manages to common up these three cases!
2054
2055     case UPDATE_FRAME:
2056       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
2057       su = su->link;
2058       continue;
2059
2060     case CATCH_FRAME:
2061       cf = (StgCatchFrame *)su;
2062       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
2063       su = cf->link;
2064       continue;
2065
2066     case SEQ_FRAME:
2067       sf = (StgSeqFrame *)su;
2068       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
2069       su = sf->link;
2070       continue;
2071
2072     case STOP_FRAME:
2073       // all done!
2074       break;
2075
2076     default:
2077       barf("relocate_stack %d", (int)(get_itbl(su)->type));
2078     }
2079     break;
2080   }
2081
2082   return dest;
2083 }
2084
2085
2086
2087 static inline void
2088 scavenge_srt(const StgInfoTable *info)
2089 {
2090   StgClosure **srt, **srt_end;
2091
2092   /* evacuate the SRT.  If srt_len is zero, then there isn't an
2093    * srt field in the info table.  That's ok, because we'll
2094    * never dereference it.
2095    */
2096   srt = (StgClosure **)(info->srt);
2097   srt_end = srt + info->srt_len;
2098   for (; srt < srt_end; srt++) {
2099     /* Special-case to handle references to closures hiding out in DLLs, since
2100        double indirections required to get at those. The code generator knows
2101        which is which when generating the SRT, so it stores the (indirect)
2102        reference to the DLL closure in the table by first adding one to it.
2103        We check for this here, and undo the addition before evacuating it.
2104
2105        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2106        closure that's fixed at link-time, and no extra magic is required.
2107     */
2108 #ifdef ENABLE_WIN32_DLL_SUPPORT
2109     if ( (unsigned long)(*srt) & 0x1 ) {
2110        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2111     } else {
2112        evacuate(*srt);
2113     }
2114 #else
2115        evacuate(*srt);
2116 #endif
2117   }
2118 }
2119
2120 /* -----------------------------------------------------------------------------
2121    Scavenge a TSO.
2122    -------------------------------------------------------------------------- */
2123
2124 static void
2125 scavengeTSO (StgTSO *tso)
2126 {
2127   // chase the link field for any TSOs on the same queue
2128   (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2129   if (   tso->why_blocked == BlockedOnMVar
2130          || tso->why_blocked == BlockedOnBlackHole
2131          || tso->why_blocked == BlockedOnException
2132 #if defined(PAR)
2133          || tso->why_blocked == BlockedOnGA
2134          || tso->why_blocked == BlockedOnGA_NoSend
2135 #endif
2136          ) {
2137     tso->block_info.closure = evacuate(tso->block_info.closure);
2138   }
2139   if ( tso->blocked_exceptions != NULL ) {
2140     tso->blocked_exceptions =
2141       (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2142   }
2143   // scavenge this thread's stack
2144   scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2145 }
2146
2147 /* -----------------------------------------------------------------------------
2148    Scavenge a given step until there are no more objects in this step
2149    to scavenge.
2150
2151    evac_gen is set by the caller to be either zero (for a step in a
2152    generation < N) or G where G is the generation of the step being
2153    scavenged.
2154
2155    We sometimes temporarily change evac_gen back to zero if we're
2156    scavenging a mutable object where early promotion isn't such a good
2157    idea.
2158    -------------------------------------------------------------------------- */
2159
2160 static void
2161 scavenge(step *stp)
2162 {
2163   StgPtr p, q;
2164   StgInfoTable *info;
2165   bdescr *bd;
2166   nat saved_evac_gen = evac_gen;
2167
2168   p = stp->scan;
2169   bd = stp->scan_bd;
2170
2171   failed_to_evac = rtsFalse;
2172
2173   /* scavenge phase - standard breadth-first scavenging of the
2174    * evacuated objects
2175    */
2176
2177   while (bd != stp->hp_bd || p < stp->hp) {
2178
2179     // If we're at the end of this block, move on to the next block
2180     if (bd != stp->hp_bd && p == bd->free) {
2181       bd = bd->link;
2182       p = bd->start;
2183       continue;
2184     }
2185
2186     info = get_itbl((StgClosure *)p);
2187     ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2188
2189     q = p;
2190     switch (info->type) {
2191
2192     case MVAR:
2193         /* treat MVars specially, because we don't want to evacuate the
2194          * mut_link field in the middle of the closure.
2195          */
2196     {
2197         StgMVar *mvar = ((StgMVar *)p);
2198         evac_gen = 0;
2199         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2200         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2201         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2202         evac_gen = saved_evac_gen;
2203         recordMutable((StgMutClosure *)mvar);
2204         failed_to_evac = rtsFalse; // mutable.
2205         p += sizeofW(StgMVar);
2206         break;
2207     }
2208
2209     case THUNK_2_0:
2210     case FUN_2_0:
2211         scavenge_srt(info);
2212     case CONSTR_2_0:
2213         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2214         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2215         p += sizeofW(StgHeader) + 2;
2216         break;
2217
2218     case THUNK_1_0:
2219         scavenge_srt(info);
2220         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2221         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2222         break;
2223
2224     case FUN_1_0:
2225         scavenge_srt(info);
2226     case CONSTR_1_0:
2227         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2228         p += sizeofW(StgHeader) + 1;
2229         break;
2230
2231     case THUNK_0_1:
2232         scavenge_srt(info);
2233         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2234         break;
2235
2236     case FUN_0_1:
2237         scavenge_srt(info);
2238     case CONSTR_0_1:
2239         p += sizeofW(StgHeader) + 1;
2240         break;
2241
2242     case THUNK_0_2:
2243     case FUN_0_2:
2244         scavenge_srt(info);
2245     case CONSTR_0_2:
2246         p += sizeofW(StgHeader) + 2;
2247         break;
2248
2249     case THUNK_1_1:
2250     case FUN_1_1:
2251         scavenge_srt(info);
2252     case CONSTR_1_1:
2253         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2254         p += sizeofW(StgHeader) + 2;
2255         break;
2256
2257     case FUN:
2258     case THUNK:
2259         scavenge_srt(info);
2260         // fall through
2261
2262     case CONSTR:
2263     case WEAK:
2264     case FOREIGN:
2265     case STABLE_NAME:
2266     case BCO:
2267     {
2268         StgPtr end;
2269
2270         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2271         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2272             (StgClosure *)*p = evacuate((StgClosure *)*p);
2273         }
2274         p += info->layout.payload.nptrs;
2275         break;
2276     }
2277
2278     case IND_PERM:
2279       if (stp->gen->no != 0) {
2280 #ifdef PROFILING
2281         // @LDV profiling
2282         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2283         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2284         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2285 #endif
2286         //
2287         // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
2288         //
2289         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2290 #ifdef PROFILING
2291         // @LDV profiling
2292         // We pretend that p has just been created.
2293         LDV_recordCreate((StgClosure *)p);
2294 #endif
2295       }
2296         // fall through
2297     case IND_OLDGEN_PERM:
2298         ((StgIndOldGen *)p)->indirectee =
2299             evacuate(((StgIndOldGen *)p)->indirectee);
2300         if (failed_to_evac) {
2301             failed_to_evac = rtsFalse;
2302             recordOldToNewPtrs((StgMutClosure *)p);
2303         }
2304         p += sizeofW(StgIndOldGen);
2305         break;
2306
2307     case MUT_VAR:
2308         evac_gen = 0;
2309         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2310         evac_gen = saved_evac_gen;
2311         recordMutable((StgMutClosure *)p);
2312         failed_to_evac = rtsFalse; // mutable anyhow
2313         p += sizeofW(StgMutVar);
2314         break;
2315
2316     case MUT_CONS:
2317         // ignore these
2318         failed_to_evac = rtsFalse; // mutable anyhow
2319         p += sizeofW(StgMutVar);
2320         break;
2321
2322     case CAF_BLACKHOLE:
2323     case SE_CAF_BLACKHOLE:
2324     case SE_BLACKHOLE:
2325     case BLACKHOLE:
2326         p += BLACKHOLE_sizeW();
2327         break;
2328
2329     case BLACKHOLE_BQ:
2330     {
2331         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2332         (StgClosure *)bh->blocking_queue =
2333             evacuate((StgClosure *)bh->blocking_queue);
2334         recordMutable((StgMutClosure *)bh);
2335         failed_to_evac = rtsFalse;
2336         p += BLACKHOLE_sizeW();
2337         break;
2338     }
2339
2340     case THUNK_SELECTOR:
2341     {
2342         StgSelector *s = (StgSelector *)p;
2343         s->selectee = evacuate(s->selectee);
2344         p += THUNK_SELECTOR_sizeW();
2345         break;
2346     }
2347
2348     case AP_UPD: // same as PAPs
2349     case PAP:
2350         /* Treat a PAP just like a section of stack, not forgetting to
2351          * evacuate the function pointer too...
2352          */
2353     {
2354         StgPAP* pap = (StgPAP *)p;
2355
2356         pap->fun = evacuate(pap->fun);
2357         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2358         p += pap_sizeW(pap);
2359         break;
2360     }
2361
2362     case ARR_WORDS:
2363         // nothing to follow
2364         p += arr_words_sizeW((StgArrWords *)p);
2365         break;
2366
2367     case MUT_ARR_PTRS:
2368         // follow everything
2369     {
2370         StgPtr next;
2371
2372         evac_gen = 0;           // repeatedly mutable
2373         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2374         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2375             (StgClosure *)*p = evacuate((StgClosure *)*p);
2376         }
2377         evac_gen = saved_evac_gen;
2378         recordMutable((StgMutClosure *)q);
2379         failed_to_evac = rtsFalse; // mutable anyhow.
2380         break;
2381     }
2382
2383     case MUT_ARR_PTRS_FROZEN:
2384         // follow everything
2385     {
2386         StgPtr next;
2387
2388         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2389         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2390             (StgClosure *)*p = evacuate((StgClosure *)*p);
2391         }
2392         // it's tempting to recordMutable() if failed_to_evac is
2393         // false, but that breaks some assumptions (eg. every
2394         // closure on the mutable list is supposed to have the MUT
2395         // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2396         break;
2397     }
2398
2399     case TSO:
2400     {
2401         StgTSO *tso = (StgTSO *)p;
2402         evac_gen = 0;
2403         scavengeTSO(tso);
2404         evac_gen = saved_evac_gen;
2405         recordMutable((StgMutClosure *)tso);
2406         failed_to_evac = rtsFalse; // mutable anyhow.
2407         p += tso_sizeW(tso);
2408         break;
2409     }
2410
2411 #if defined(PAR)
2412     case RBH: // cf. BLACKHOLE_BQ
2413     {
2414 #if 0
2415         nat size, ptrs, nonptrs, vhs;
2416         char str[80];
2417         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2418 #endif
2419         StgRBH *rbh = (StgRBH *)p;
2420         (StgClosure *)rbh->blocking_queue =
2421             evacuate((StgClosure *)rbh->blocking_queue);
2422         recordMutable((StgMutClosure *)to);
2423         failed_to_evac = rtsFalse;  // mutable anyhow.
2424         IF_DEBUG(gc,
2425                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2426                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2427         // ToDo: use size of reverted closure here!
2428         p += BLACKHOLE_sizeW();
2429         break;
2430     }
2431
2432     case BLOCKED_FETCH:
2433     {
2434         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2435         // follow the pointer to the node which is being demanded
2436         (StgClosure *)bf->node =
2437             evacuate((StgClosure *)bf->node);
2438         // follow the link to the rest of the blocking queue
2439         (StgClosure *)bf->link =
2440             evacuate((StgClosure *)bf->link);
2441         if (failed_to_evac) {
2442             failed_to_evac = rtsFalse;
2443             recordMutable((StgMutClosure *)bf);
2444         }
2445         IF_DEBUG(gc,
2446                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2447                        bf, info_type((StgClosure *)bf),
2448                        bf->node, info_type(bf->node)));
2449         p += sizeofW(StgBlockedFetch);
2450         break;
2451     }
2452
2453 #ifdef DIST
2454     case REMOTE_REF:
2455 #endif
2456     case FETCH_ME:
2457         p += sizeofW(StgFetchMe);
2458         break; // nothing to do in this case
2459
2460     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2461     {
2462         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2463         (StgClosure *)fmbq->blocking_queue =
2464             evacuate((StgClosure *)fmbq->blocking_queue);
2465         if (failed_to_evac) {
2466             failed_to_evac = rtsFalse;
2467             recordMutable((StgMutClosure *)fmbq);
2468         }
2469         IF_DEBUG(gc,
2470                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2471                        p, info_type((StgClosure *)p)));
2472         p += sizeofW(StgFetchMeBlockingQueue);
2473         break;
2474     }
2475 #endif
2476
2477     default:
2478         barf("scavenge: unimplemented/strange closure type %d @ %p",
2479              info->type, p);
2480     }
2481
2482     /* If we didn't manage to promote all the objects pointed to by
2483      * the current object, then we have to designate this object as
2484      * mutable (because it contains old-to-new generation pointers).
2485      */
2486     if (failed_to_evac) {
2487         failed_to_evac = rtsFalse;
2488         mkMutCons((StgClosure *)q, &generations[evac_gen]);
2489     }
2490   }
2491
2492   stp->scan_bd = bd;
2493   stp->scan = p;
2494 }
2495
2496 /* -----------------------------------------------------------------------------
2497    Scavenge everything on the mark stack.
2498
2499    This is slightly different from scavenge():
2500       - we don't walk linearly through the objects, so the scavenger
2501         doesn't need to advance the pointer on to the next object.
2502    -------------------------------------------------------------------------- */
2503
2504 static void
2505 scavenge_mark_stack(void)
2506 {
2507     StgPtr p, q;
2508     StgInfoTable *info;
2509     nat saved_evac_gen;
2510
2511     evac_gen = oldest_gen->no;
2512     saved_evac_gen = evac_gen;
2513
2514 linear_scan:
2515     while (!mark_stack_empty()) {
2516         p = pop_mark_stack();
2517
2518         info = get_itbl((StgClosure *)p);
2519         ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
2520
2521         q = p;
2522         switch (info->type) {
2523
2524         case MVAR:
2525             /* treat MVars specially, because we don't want to evacuate the
2526              * mut_link field in the middle of the closure.
2527              */
2528         {
2529             StgMVar *mvar = ((StgMVar *)p);
2530             evac_gen = 0;
2531             (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2532             (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2533             (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2534             evac_gen = saved_evac_gen;
2535             failed_to_evac = rtsFalse; // mutable.
2536             break;
2537         }
2538
2539         case FUN_2_0:
2540         case THUNK_2_0:
2541             scavenge_srt(info);
2542         case CONSTR_2_0:
2543             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2544             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2545             break;
2546
2547         case FUN_1_0:
2548         case FUN_1_1:
2549         case THUNK_1_0:
2550         case THUNK_1_1:
2551             scavenge_srt(info);
2552         case CONSTR_1_0:
2553         case CONSTR_1_1:
2554             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2555             break;
2556
2557         case FUN_0_1:
2558         case FUN_0_2:
2559         case THUNK_0_1:
2560         case THUNK_0_2:
2561             scavenge_srt(info);
2562         case CONSTR_0_1:
2563         case CONSTR_0_2:
2564             break;
2565
2566         case FUN:
2567         case THUNK:
2568             scavenge_srt(info);
2569             // fall through
2570
2571         case CONSTR:
2572         case WEAK:
2573         case FOREIGN:
2574         case STABLE_NAME:
2575         case BCO:
2576         {
2577             StgPtr end;
2578
2579             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2580             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2581                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2582             }
2583             break;
2584         }
2585
2586         case IND_PERM:
2587             // don't need to do anything here: the only possible case
2588             // is that we're in a 1-space compacting collector, with
2589             // no "old" generation.
2590             break;
2591
2592         case IND_OLDGEN:
2593         case IND_OLDGEN_PERM:
2594             ((StgIndOldGen *)p)->indirectee =
2595                 evacuate(((StgIndOldGen *)p)->indirectee);
2596             if (failed_to_evac) {
2597                 recordOldToNewPtrs((StgMutClosure *)p);
2598             }
2599             failed_to_evac = rtsFalse;
2600             break;
2601
2602         case MUT_VAR:
2603             evac_gen = 0;
2604             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2605             evac_gen = saved_evac_gen;
2606             failed_to_evac = rtsFalse;
2607             break;
2608
2609         case MUT_CONS:
2610             // ignore these
2611             failed_to_evac = rtsFalse;
2612             break;
2613
2614         case CAF_BLACKHOLE:
2615         case SE_CAF_BLACKHOLE:
2616         case SE_BLACKHOLE:
2617         case BLACKHOLE:
2618         case ARR_WORDS:
2619             break;
2620
2621         case BLACKHOLE_BQ:
2622         {
2623             StgBlockingQueue *bh = (StgBlockingQueue *)p;
2624             (StgClosure *)bh->blocking_queue =
2625                 evacuate((StgClosure *)bh->blocking_queue);
2626             failed_to_evac = rtsFalse;
2627             break;
2628         }
2629
2630         case THUNK_SELECTOR:
2631         {
2632             StgSelector *s = (StgSelector *)p;
2633             s->selectee = evacuate(s->selectee);
2634             break;
2635         }
2636
2637         case AP_UPD: // same as PAPs
2638         case PAP:
2639             /* Treat a PAP just like a section of stack, not forgetting to
2640              * evacuate the function pointer too...
2641              */
2642         {
2643             StgPAP* pap = (StgPAP *)p;
2644
2645             pap->fun = evacuate(pap->fun);
2646             scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2647             break;
2648         }
2649
2650         case MUT_ARR_PTRS:
2651             // follow everything
2652         {
2653             StgPtr next;
2654
2655             evac_gen = 0;               // repeatedly mutable
2656             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2657             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2658                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2659             }
2660             evac_gen = saved_evac_gen;
2661             failed_to_evac = rtsFalse; // mutable anyhow.
2662             break;
2663         }
2664
2665         case MUT_ARR_PTRS_FROZEN:
2666             // follow everything
2667         {
2668             StgPtr next;
2669
2670             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2671             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2672                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2673             }
2674             break;
2675         }
2676
2677         case TSO:
2678         {
2679             StgTSO *tso = (StgTSO *)p;
2680             evac_gen = 0;
2681             scavengeTSO(tso);
2682             evac_gen = saved_evac_gen;
2683             failed_to_evac = rtsFalse;
2684             break;
2685         }
2686
2687 #if defined(PAR)
2688         case RBH: // cf. BLACKHOLE_BQ
2689         {
2690 #if 0
2691             nat size, ptrs, nonptrs, vhs;
2692             char str[80];
2693             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2694 #endif
2695             StgRBH *rbh = (StgRBH *)p;
2696             (StgClosure *)rbh->blocking_queue =
2697                 evacuate((StgClosure *)rbh->blocking_queue);
2698             recordMutable((StgMutClosure *)rbh);
2699             failed_to_evac = rtsFalse;  // mutable anyhow.
2700             IF_DEBUG(gc,
2701                      belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2702                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
2703             break;
2704         }
2705
2706         case BLOCKED_FETCH:
2707         {
2708             StgBlockedFetch *bf = (StgBlockedFetch *)p;
2709             // follow the pointer to the node which is being demanded
2710             (StgClosure *)bf->node =
2711                 evacuate((StgClosure *)bf->node);
2712             // follow the link to the rest of the blocking queue
2713             (StgClosure *)bf->link =
2714                 evacuate((StgClosure *)bf->link);
2715             if (failed_to_evac) {
2716                 failed_to_evac = rtsFalse;
2717                 recordMutable((StgMutClosure *)bf);
2718             }
2719             IF_DEBUG(gc,
2720                      belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2721                            bf, info_type((StgClosure *)bf),
2722                            bf->node, info_type(bf->node)));
2723             break;
2724         }
2725
2726 #ifdef DIST
2727         case REMOTE_REF:
2728 #endif
2729         case FETCH_ME:
2730             break; // nothing to do in this case
2731
2732         case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2733         {
2734             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2735             (StgClosure *)fmbq->blocking_queue =
2736                 evacuate((StgClosure *)fmbq->blocking_queue);
2737             if (failed_to_evac) {
2738                 failed_to_evac = rtsFalse;
2739                 recordMutable((StgMutClosure *)fmbq);
2740             }
2741             IF_DEBUG(gc,
2742                      belch("@@ scavenge: %p (%s) exciting, isn't it",
2743                            p, info_type((StgClosure *)p)));
2744             break;
2745         }
2746 #endif // PAR
2747
2748         default:
2749             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
2750                  info->type, p);
2751         }
2752
2753         if (failed_to_evac) {
2754             failed_to_evac = rtsFalse;
2755             mkMutCons((StgClosure *)q, &generations[evac_gen]);
2756         }
2757
2758         // mark the next bit to indicate "scavenged"
2759         mark(q+1, Bdescr(q));
2760
2761     } // while (!mark_stack_empty())
2762
2763     // start a new linear scan if the mark stack overflowed at some point
2764     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
2765         IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
2766         mark_stack_overflowed = rtsFalse;
2767         oldgen_scan_bd = oldest_gen->steps[0].blocks;
2768         oldgen_scan = oldgen_scan_bd->start;
2769     }
2770
2771     if (oldgen_scan_bd) {
2772         // push a new thing on the mark stack
2773     loop:
2774         // find a closure that is marked but not scavenged, and start
2775         // from there.
2776         while (oldgen_scan < oldgen_scan_bd->free
2777                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
2778             oldgen_scan++;
2779         }
2780
2781         if (oldgen_scan < oldgen_scan_bd->free) {
2782
2783             // already scavenged?
2784             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
2785                 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2786                 goto loop;
2787             }
2788             push_mark_stack(oldgen_scan);
2789             // ToDo: bump the linear scan by the actual size of the object
2790             oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
2791             goto linear_scan;
2792         }
2793
2794         oldgen_scan_bd = oldgen_scan_bd->link;
2795         if (oldgen_scan_bd != NULL) {
2796             oldgen_scan = oldgen_scan_bd->start;
2797             goto loop;
2798         }
2799     }
2800 }
2801
2802 /* -----------------------------------------------------------------------------
2803    Scavenge one object.
2804
2805    This is used for objects that are temporarily marked as mutable
2806    because they contain old-to-new generation pointers.  Only certain
2807    objects can have this property.
2808    -------------------------------------------------------------------------- */
2809
2810 static rtsBool
2811 scavenge_one(StgPtr p)
2812 {
2813     const StgInfoTable *info;
2814     nat saved_evac_gen = evac_gen;
2815     rtsBool no_luck;
2816
2817     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
2818                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
2819
2820     info = get_itbl((StgClosure *)p);
2821
2822     switch (info->type) {
2823
2824     case FUN:
2825     case FUN_1_0:                       // hardly worth specialising these guys
2826     case FUN_0_1:
2827     case FUN_1_1:
2828     case FUN_0_2:
2829     case FUN_2_0:
2830     case THUNK:
2831     case THUNK_1_0:
2832     case THUNK_0_1:
2833     case THUNK_1_1:
2834     case THUNK_0_2:
2835     case THUNK_2_0:
2836     case CONSTR:
2837     case CONSTR_1_0:
2838     case CONSTR_0_1:
2839     case CONSTR_1_1:
2840     case CONSTR_0_2:
2841     case CONSTR_2_0:
2842     case WEAK:
2843     case FOREIGN:
2844     case IND_PERM:
2845     case IND_OLDGEN_PERM:
2846     {
2847         StgPtr q, end;
2848
2849         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2850         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
2851             (StgClosure *)*q = evacuate((StgClosure *)*q);
2852         }
2853         break;
2854     }
2855
2856     case CAF_BLACKHOLE:
2857     case SE_CAF_BLACKHOLE:
2858     case SE_BLACKHOLE:
2859     case BLACKHOLE:
2860         break;
2861
2862     case THUNK_SELECTOR:
2863     {
2864         StgSelector *s = (StgSelector *)p;
2865         s->selectee = evacuate(s->selectee);
2866         break;
2867     }
2868
2869     case ARR_WORDS:
2870         // nothing to follow
2871         break;
2872
2873     case MUT_ARR_PTRS:
2874     {
2875         // follow everything
2876         StgPtr next;
2877
2878         evac_gen = 0;           // repeatedly mutable
2879         recordMutable((StgMutClosure *)p);
2880         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2881         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2882             (StgClosure *)*p = evacuate((StgClosure *)*p);
2883         }
2884         evac_gen = saved_evac_gen;
2885         failed_to_evac = rtsFalse;
2886         break;
2887     }
2888
2889     case MUT_ARR_PTRS_FROZEN:
2890     {
2891         // follow everything
2892         StgPtr next;
2893
2894         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2895         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2896             (StgClosure *)*p = evacuate((StgClosure *)*p);
2897         }
2898         break;
2899     }
2900
2901     case TSO:
2902     {
2903         StgTSO *tso = (StgTSO *)p;
2904
2905         evac_gen = 0;           // repeatedly mutable
2906         scavengeTSO(tso);
2907         recordMutable((StgMutClosure *)tso);
2908         evac_gen = saved_evac_gen;
2909         failed_to_evac = rtsFalse;
2910         break;
2911     }
2912
2913     case AP_UPD:
2914     case PAP:
2915     {
2916         StgPAP* pap = (StgPAP *)p;
2917         pap->fun = evacuate(pap->fun);
2918         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
2919         break;
2920     }
2921
2922     case IND_OLDGEN:
2923         // This might happen if for instance a MUT_CONS was pointing to a
2924         // THUNK which has since been updated.  The IND_OLDGEN will
2925         // be on the mutable list anyway, so we don't need to do anything
2926         // here.
2927         break;
2928
2929     default:
2930         barf("scavenge_one: strange object %d", (int)(info->type));
2931     }
2932
2933     no_luck = failed_to_evac;
2934     failed_to_evac = rtsFalse;
2935     return (no_luck);
2936 }
2937
2938 /* -----------------------------------------------------------------------------
2939    Scavenging mutable lists.
2940
2941    We treat the mutable list of each generation > N (i.e. all the
2942    generations older than the one being collected) as roots.  We also
2943    remove non-mutable objects from the mutable list at this point.
2944    -------------------------------------------------------------------------- */
2945
2946 static void
2947 scavenge_mut_once_list(generation *gen)
2948 {
2949   const StgInfoTable *info;
2950   StgMutClosure *p, *next, *new_list;
2951
2952   p = gen->mut_once_list;
2953   new_list = END_MUT_LIST;
2954   next = p->mut_link;
2955
2956   evac_gen = gen->no;
2957   failed_to_evac = rtsFalse;
2958
2959   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
2960
2961     // make sure the info pointer is into text space
2962     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
2963                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
2964
2965     info = get_itbl(p);
2966     /*
2967     if (info->type==RBH)
2968       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
2969     */
2970     switch(info->type) {
2971
2972     case IND_OLDGEN:
2973     case IND_OLDGEN_PERM:
2974     case IND_STATIC:
2975       /* Try to pull the indirectee into this generation, so we can
2976        * remove the indirection from the mutable list.
2977        */
2978       ((StgIndOldGen *)p)->indirectee =
2979         evacuate(((StgIndOldGen *)p)->indirectee);
2980
2981 #if 0 && defined(DEBUG)
2982       if (RtsFlags.DebugFlags.gc)
2983       /* Debugging code to print out the size of the thing we just
2984        * promoted
2985        */
2986       {
2987         StgPtr start = gen->steps[0].scan;
2988         bdescr *start_bd = gen->steps[0].scan_bd;
2989         nat size = 0;
2990         scavenge(&gen->steps[0]);
2991         if (start_bd != gen->steps[0].scan_bd) {
2992           size += (P_)BLOCK_ROUND_UP(start) - start;
2993           start_bd = start_bd->link;
2994           while (start_bd != gen->steps[0].scan_bd) {
2995             size += BLOCK_SIZE_W;
2996             start_bd = start_bd->link;
2997           }
2998           size += gen->steps[0].scan -
2999             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3000         } else {
3001           size = gen->steps[0].scan - start;
3002         }
3003         belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3004       }
3005 #endif
3006
3007       /* failed_to_evac might happen if we've got more than two
3008        * generations, we're collecting only generation 0, the
3009        * indirection resides in generation 2 and the indirectee is
3010        * in generation 1.
3011        */
3012       if (failed_to_evac) {
3013         failed_to_evac = rtsFalse;
3014         p->mut_link = new_list;
3015         new_list = p;
3016       } else {
3017         /* the mut_link field of an IND_STATIC is overloaded as the
3018          * static link field too (it just so happens that we don't need
3019          * both at the same time), so we need to NULL it out when
3020          * removing this object from the mutable list because the static
3021          * link fields are all assumed to be NULL before doing a major
3022          * collection.
3023          */
3024         p->mut_link = NULL;
3025       }
3026       continue;
3027
3028     case MUT_CONS:
3029         /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3030          * it from the mutable list if possible by promoting whatever it
3031          * points to.
3032          */
3033         if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3034             /* didn't manage to promote everything, so put the
3035              * MUT_CONS back on the list.
3036              */
3037             p->mut_link = new_list;
3038             new_list = p;
3039         }
3040         continue;
3041
3042     default:
3043       // shouldn't have anything else on the mutables list
3044       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3045     }
3046   }
3047
3048   gen->mut_once_list = new_list;
3049 }
3050
3051
3052 static void
3053 scavenge_mutable_list(generation *gen)
3054 {
3055   const StgInfoTable *info;
3056   StgMutClosure *p, *next;
3057
3058   p = gen->saved_mut_list;
3059   next = p->mut_link;
3060
3061   evac_gen = 0;
3062   failed_to_evac = rtsFalse;
3063
3064   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3065
3066     // make sure the info pointer is into text space
3067     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3068                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3069
3070     info = get_itbl(p);
3071     /*
3072     if (info->type==RBH)
3073       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3074     */
3075     switch(info->type) {
3076
3077     case MUT_ARR_PTRS:
3078       // follow everything
3079       p->mut_link = gen->mut_list;
3080       gen->mut_list = p;
3081       {
3082         StgPtr end, q;
3083
3084         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3085         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3086           (StgClosure *)*q = evacuate((StgClosure *)*q);
3087         }
3088         continue;
3089       }
3090
3091       // Happens if a MUT_ARR_PTRS in the old generation is frozen
3092     case MUT_ARR_PTRS_FROZEN:
3093       {
3094         StgPtr end, q;
3095
3096         evac_gen = gen->no;
3097         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3098         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3099           (StgClosure *)*q = evacuate((StgClosure *)*q);
3100         }
3101         evac_gen = 0;
3102         p->mut_link = NULL;
3103         if (failed_to_evac) {
3104             failed_to_evac = rtsFalse;
3105             mkMutCons((StgClosure *)p, gen);
3106         }
3107         continue;
3108       }
3109
3110     case MUT_VAR:
3111         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3112         p->mut_link = gen->mut_list;
3113         gen->mut_list = p;
3114         continue;
3115
3116     case MVAR:
3117       {
3118         StgMVar *mvar = (StgMVar *)p;
3119         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3120         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3121         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3122         p->mut_link = gen->mut_list;
3123         gen->mut_list = p;
3124         continue;
3125       }
3126
3127     case TSO:
3128       {
3129         StgTSO *tso = (StgTSO *)p;
3130
3131         scavengeTSO(tso);
3132
3133         /* Don't take this TSO off the mutable list - it might still
3134          * point to some younger objects (because we set evac_gen to 0
3135          * above).
3136          */
3137         tso->mut_link = gen->mut_list;
3138         gen->mut_list = (StgMutClosure *)tso;
3139         continue;
3140       }
3141
3142     case BLACKHOLE_BQ:
3143       {
3144         StgBlockingQueue *bh = (StgBlockingQueue *)p;
3145         (StgClosure *)bh->blocking_queue =
3146           evacuate((StgClosure *)bh->blocking_queue);
3147         p->mut_link = gen->mut_list;
3148         gen->mut_list = p;
3149         continue;
3150       }
3151
3152       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3153        */
3154     case IND_OLDGEN:
3155     case IND_OLDGEN_PERM:
3156       /* Try to pull the indirectee into this generation, so we can
3157        * remove the indirection from the mutable list.
3158        */
3159       evac_gen = gen->no;
3160       ((StgIndOldGen *)p)->indirectee =
3161         evacuate(((StgIndOldGen *)p)->indirectee);
3162       evac_gen = 0;
3163
3164       if (failed_to_evac) {
3165         failed_to_evac = rtsFalse;
3166         p->mut_link = gen->mut_once_list;
3167         gen->mut_once_list = p;
3168       } else {
3169         p->mut_link = NULL;
3170       }
3171       continue;
3172
3173 #if defined(PAR)
3174     // HWL: check whether all of these are necessary
3175
3176     case RBH: // cf. BLACKHOLE_BQ
3177       {
3178         // nat size, ptrs, nonptrs, vhs;
3179         // char str[80];
3180         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3181         StgRBH *rbh = (StgRBH *)p;
3182         (StgClosure *)rbh->blocking_queue =
3183           evacuate((StgClosure *)rbh->blocking_queue);
3184         if (failed_to_evac) {
3185           failed_to_evac = rtsFalse;
3186           recordMutable((StgMutClosure *)rbh);
3187         }
3188         // ToDo: use size of reverted closure here!
3189         p += BLACKHOLE_sizeW();
3190         break;
3191       }
3192
3193     case BLOCKED_FETCH:
3194       {
3195         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3196         // follow the pointer to the node which is being demanded
3197         (StgClosure *)bf->node =
3198           evacuate((StgClosure *)bf->node);
3199         // follow the link to the rest of the blocking queue
3200         (StgClosure *)bf->link =
3201           evacuate((StgClosure *)bf->link);
3202         if (failed_to_evac) {
3203           failed_to_evac = rtsFalse;
3204           recordMutable((StgMutClosure *)bf);
3205         }
3206         p += sizeofW(StgBlockedFetch);
3207         break;
3208       }
3209
3210 #ifdef DIST
3211     case REMOTE_REF:
3212       barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3213 #endif
3214     case FETCH_ME:
3215       p += sizeofW(StgFetchMe);
3216       break; // nothing to do in this case
3217
3218     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3219       {
3220         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3221         (StgClosure *)fmbq->blocking_queue =
3222           evacuate((StgClosure *)fmbq->blocking_queue);
3223         if (failed_to_evac) {
3224           failed_to_evac = rtsFalse;
3225           recordMutable((StgMutClosure *)fmbq);
3226         }
3227         p += sizeofW(StgFetchMeBlockingQueue);
3228         break;
3229       }
3230 #endif
3231
3232     default:
3233       // shouldn't have anything else on the mutables list
3234       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3235     }
3236   }
3237 }
3238
3239
3240 static void
3241 scavenge_static(void)
3242 {
3243   StgClosure* p = static_objects;
3244   const StgInfoTable *info;
3245
3246   /* Always evacuate straight to the oldest generation for static
3247    * objects */
3248   evac_gen = oldest_gen->no;
3249
3250   /* keep going until we've scavenged all the objects on the linked
3251      list... */
3252   while (p != END_OF_STATIC_LIST) {
3253
3254     info = get_itbl(p);
3255     /*
3256     if (info->type==RBH)
3257       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3258     */
3259     // make sure the info pointer is into text space
3260     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
3261                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
3262
3263     /* Take this object *off* the static_objects list,
3264      * and put it on the scavenged_static_objects list.
3265      */
3266     static_objects = STATIC_LINK(info,p);
3267     STATIC_LINK(info,p) = scavenged_static_objects;
3268     scavenged_static_objects = p;
3269
3270     switch (info -> type) {
3271
3272     case IND_STATIC:
3273       {
3274         StgInd *ind = (StgInd *)p;
3275         ind->indirectee = evacuate(ind->indirectee);
3276
3277         /* might fail to evacuate it, in which case we have to pop it
3278          * back on the mutable list (and take it off the
3279          * scavenged_static list because the static link and mut link
3280          * pointers are one and the same).
3281          */
3282         if (failed_to_evac) {
3283           failed_to_evac = rtsFalse;
3284           scavenged_static_objects = IND_STATIC_LINK(p);
3285           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3286           oldest_gen->mut_once_list = (StgMutClosure *)ind;
3287         }
3288         break;
3289       }
3290
3291     case THUNK_STATIC:
3292     case FUN_STATIC:
3293       scavenge_srt(info);
3294       break;
3295
3296     case CONSTR_STATIC:
3297       {
3298         StgPtr q, next;
3299
3300         next = (P_)p->payload + info->layout.payload.ptrs;
3301         // evacuate the pointers
3302         for (q = (P_)p->payload; q < next; q++) {
3303           (StgClosure *)*q = evacuate((StgClosure *)*q);
3304         }
3305         break;
3306       }
3307
3308     default:
3309       barf("scavenge_static: strange closure %d", (int)(info->type));
3310     }
3311
3312     ASSERT(failed_to_evac == rtsFalse);
3313
3314     /* get the next static object from the list.  Remember, there might
3315      * be more stuff on this list now that we've done some evacuating!
3316      * (static_objects is a global)
3317      */
3318     p = static_objects;
3319   }
3320 }
3321
3322 /* -----------------------------------------------------------------------------
3323    scavenge_stack walks over a section of stack and evacuates all the
3324    objects pointed to by it.  We can use the same code for walking
3325    PAPs, since these are just sections of copied stack.
3326    -------------------------------------------------------------------------- */
3327
3328 static void
3329 scavenge_stack(StgPtr p, StgPtr stack_end)
3330 {
3331   StgPtr q;
3332   const StgInfoTable* info;
3333   StgWord bitmap;
3334
3335   //IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
3336
3337   /*
3338    * Each time around this loop, we are looking at a chunk of stack
3339    * that starts with either a pending argument section or an
3340    * activation record.
3341    */
3342
3343   while (p < stack_end) {
3344     q = *(P_ *)p;
3345
3346     // If we've got a tag, skip over that many words on the stack
3347     if (IS_ARG_TAG((W_)q)) {
3348       p += ARG_SIZE(q);
3349       p++; continue;
3350     }
3351
3352     /* Is q a pointer to a closure?
3353      */
3354     if (! LOOKS_LIKE_GHC_INFO(q) ) {
3355 #ifdef DEBUG
3356       if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) {  // Is it a static closure?
3357         ASSERT(closure_STATIC((StgClosure *)q));
3358       }
3359       // otherwise, must be a pointer into the allocation space.
3360 #endif
3361
3362       (StgClosure *)*p = evacuate((StgClosure *)q);
3363       p++;
3364       continue;
3365     }
3366
3367     /*
3368      * Otherwise, q must be the info pointer of an activation
3369      * record.  All activation records have 'bitmap' style layout
3370      * info.
3371      */
3372     info  = get_itbl((StgClosure *)p);
3373
3374     switch (info->type) {
3375
3376       // Dynamic bitmap: the mask is stored on the stack
3377     case RET_DYN:
3378       bitmap = ((StgRetDyn *)p)->liveness;
3379       p      = (P_)&((StgRetDyn *)p)->payload[0];
3380       goto small_bitmap;
3381
3382       // probably a slow-entry point return address:
3383     case FUN:
3384     case FUN_STATIC:
3385       {
3386 #if 0
3387         StgPtr old_p = p;
3388         p++; p++;
3389         IF_DEBUG(sanity,
3390                  belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
3391                        old_p, p, old_p+1));
3392 #else
3393       p++; // what if FHS!=1 !? -- HWL
3394 #endif
3395       goto follow_srt;
3396       }
3397
3398       /* Specialised code for update frames, since they're so common.
3399        * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
3400        * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
3401        */
3402     case UPDATE_FRAME:
3403       {
3404         StgUpdateFrame *frame = (StgUpdateFrame *)p;
3405
3406         p += sizeofW(StgUpdateFrame);
3407
3408 #ifndef not_yet
3409         frame->updatee = evacuate(frame->updatee);
3410         continue;
3411 #else // specialised code for update frames, not sure if it's worth it.
3412         StgClosure *to;
3413         nat type = get_itbl(frame->updatee)->type;
3414
3415         if (type == EVACUATED) {
3416           frame->updatee = evacuate(frame->updatee);
3417           continue;
3418         } else {
3419           bdescr *bd = Bdescr((P_)frame->updatee);
3420           step *stp;
3421           if (bd->gen_no > N) {
3422             if (bd->gen_no < evac_gen) {
3423               failed_to_evac = rtsTrue;
3424             }
3425             continue;
3426           }
3427
3428           // Don't promote blackholes
3429           stp = bd->step;
3430           if (!(stp->gen_no == 0 &&
3431                 stp->no != 0 &&
3432                 stp->no == stp->gen->n_steps-1)) {
3433             stp = stp->to;
3434           }
3435
3436           switch (type) {
3437           case BLACKHOLE:
3438           case CAF_BLACKHOLE:
3439             to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
3440                           sizeofW(StgHeader), stp);
3441             frame->updatee = to;
3442             continue;
3443           case BLACKHOLE_BQ:
3444             to = copy(frame->updatee, BLACKHOLE_sizeW(), stp);
3445             frame->updatee = to;
3446             recordMutable((StgMutClosure *)to);
3447             continue;
3448           default:
3449             /* will never be SE_{,CAF_}BLACKHOLE, since we
3450                don't push an update frame for single-entry thunks.  KSW 1999-01. */
3451             barf("scavenge_stack: UPDATE_FRAME updatee");
3452           }
3453         }
3454 #endif
3455       }
3456
3457       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3458     case STOP_FRAME:
3459     case CATCH_FRAME:
3460     case SEQ_FRAME:
3461     case RET_BCO:
3462     case RET_SMALL:
3463     case RET_VEC_SMALL:
3464       bitmap = info->layout.bitmap;
3465       p++;
3466       // this assumes that the payload starts immediately after the info-ptr
3467     small_bitmap:
3468       while (bitmap != 0) {
3469         if ((bitmap & 1) == 0) {
3470           (StgClosure *)*p = evacuate((StgClosure *)*p);
3471         }
3472         p++;
3473         bitmap = bitmap >> 1;
3474       }
3475
3476     follow_srt:
3477       scavenge_srt(info);
3478       continue;
3479
3480       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3481     case RET_BIG:
3482     case RET_VEC_BIG:
3483       {
3484         StgPtr q;
3485         StgLargeBitmap *large_bitmap;
3486         nat i;
3487
3488         large_bitmap = info->layout.large_bitmap;
3489         p++;
3490
3491         for (i=0; i<large_bitmap->size; i++) {
3492           bitmap = large_bitmap->bitmap[i];
3493           q = p + BITS_IN(W_);
3494           while (bitmap != 0) {
3495             if ((bitmap & 1) == 0) {
3496               (StgClosure *)*p = evacuate((StgClosure *)*p);
3497             }
3498             p++;
3499             bitmap = bitmap >> 1;
3500           }
3501           if (i+1 < large_bitmap->size) {
3502             while (p < q) {
3503               (StgClosure *)*p = evacuate((StgClosure *)*p);
3504               p++;
3505             }
3506           }
3507         }
3508
3509         // and don't forget to follow the SRT
3510         goto follow_srt;
3511       }
3512
3513     default:
3514       barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->type));
3515     }
3516   }
3517 }
3518
3519 /*-----------------------------------------------------------------------------
3520   scavenge the large object list.
3521
3522   evac_gen set by caller; similar games played with evac_gen as with
3523   scavenge() - see comment at the top of scavenge().  Most large
3524   objects are (repeatedly) mutable, so most of the time evac_gen will
3525   be zero.
3526   --------------------------------------------------------------------------- */
3527
3528 static void
3529 scavenge_large(step *stp)
3530 {
3531   bdescr *bd;
3532   StgPtr p;
3533
3534   bd = stp->new_large_objects;
3535
3536   for (; bd != NULL; bd = stp->new_large_objects) {
3537
3538     /* take this object *off* the large objects list and put it on
3539      * the scavenged large objects list.  This is so that we can
3540      * treat new_large_objects as a stack and push new objects on
3541      * the front when evacuating.
3542      */
3543     stp->new_large_objects = bd->link;
3544     dbl_link_onto(bd, &stp->scavenged_large_objects);
3545
3546     // update the block count in this step.
3547     stp->n_scavenged_large_blocks += bd->blocks;
3548
3549     p = bd->start;
3550     if (scavenge_one(p)) {
3551         mkMutCons((StgClosure *)p, stp->gen);
3552     }
3553   }
3554 }
3555
3556 /* -----------------------------------------------------------------------------
3557    Initialising the static object & mutable lists
3558    -------------------------------------------------------------------------- */
3559
3560 static void
3561 zero_static_object_list(StgClosure* first_static)
3562 {
3563   StgClosure* p;
3564   StgClosure* link;
3565   const StgInfoTable *info;
3566
3567   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3568     info = get_itbl(p);
3569     link = STATIC_LINK(info, p);
3570     STATIC_LINK(info,p) = NULL;
3571   }
3572 }
3573
3574 /* This function is only needed because we share the mutable link
3575  * field with the static link field in an IND_STATIC, so we have to
3576  * zero the mut_link field before doing a major GC, which needs the
3577  * static link field.
3578  *
3579  * It doesn't do any harm to zero all the mutable link fields on the
3580  * mutable list.
3581  */
3582
3583 static void
3584 zero_mutable_list( StgMutClosure *first )
3585 {
3586   StgMutClosure *next, *c;
3587
3588   for (c = first; c != END_MUT_LIST; c = next) {
3589     next = c->mut_link;
3590     c->mut_link = NULL;
3591   }
3592 }
3593
3594 /* -----------------------------------------------------------------------------
3595    Reverting CAFs
3596    -------------------------------------------------------------------------- */
3597
3598 void
3599 revertCAFs( void )
3600 {
3601     StgIndStatic *c;
3602
3603     for (c = (StgIndStatic *)caf_list; c != NULL;
3604          c = (StgIndStatic *)c->static_link)
3605     {
3606         c->header.info = c->saved_info;
3607         c->saved_info = NULL;
3608         // could, but not necessary: c->static_link = NULL;
3609     }
3610     caf_list = NULL;
3611 }
3612
3613 void
3614 markCAFs( evac_fn evac )
3615 {
3616     StgIndStatic *c;
3617
3618     for (c = (StgIndStatic *)caf_list; c != NULL;
3619          c = (StgIndStatic *)c->static_link)
3620     {
3621         evac(&c->indirectee);
3622     }
3623 }
3624
3625 /* -----------------------------------------------------------------------------
3626    Sanity code for CAF garbage collection.
3627
3628    With DEBUG turned on, we manage a CAF list in addition to the SRT
3629    mechanism.  After GC, we run down the CAF list and blackhole any
3630    CAFs which have been garbage collected.  This means we get an error
3631    whenever the program tries to enter a garbage collected CAF.
3632
3633    Any garbage collected CAFs are taken off the CAF list at the same
3634    time.
3635    -------------------------------------------------------------------------- */
3636
3637 #if 0 && defined(DEBUG)
3638
3639 static void
3640 gcCAFs(void)
3641 {
3642   StgClosure*  p;
3643   StgClosure** pp;
3644   const StgInfoTable *info;
3645   nat i;
3646
3647   i = 0;
3648   p = caf_list;
3649   pp = &caf_list;
3650
3651   while (p != NULL) {
3652
3653     info = get_itbl(p);
3654
3655     ASSERT(info->type == IND_STATIC);
3656
3657     if (STATIC_LINK(info,p) == NULL) {
3658       IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3659       // black hole it
3660       SET_INFO(p,&stg_BLACKHOLE_info);
3661       p = STATIC_LINK2(info,p);
3662       *pp = p;
3663     }
3664     else {
3665       pp = &STATIC_LINK2(info,p);
3666       p = *pp;
3667       i++;
3668     }
3669
3670   }
3671
3672   //  belch("%d CAFs live", i);
3673 }
3674 #endif
3675
3676
3677 /* -----------------------------------------------------------------------------
3678    Lazy black holing.
3679
3680    Whenever a thread returns to the scheduler after possibly doing
3681    some work, we have to run down the stack and black-hole all the
3682    closures referred to by update frames.
3683    -------------------------------------------------------------------------- */
3684
3685 static void
3686 threadLazyBlackHole(StgTSO *tso)
3687 {
3688   StgUpdateFrame *update_frame;
3689   StgBlockingQueue *bh;
3690   StgPtr stack_end;
3691
3692   stack_end = &tso->stack[tso->stack_size];
3693   update_frame = tso->su;
3694
3695   while (1) {
3696     switch (get_itbl(update_frame)->type) {
3697
3698     case CATCH_FRAME:
3699       update_frame = ((StgCatchFrame *)update_frame)->link;
3700       break;
3701
3702     case UPDATE_FRAME:
3703       bh = (StgBlockingQueue *)update_frame->updatee;
3704
3705       /* if the thunk is already blackholed, it means we've also
3706        * already blackholed the rest of the thunks on this stack,
3707        * so we can stop early.
3708        *
3709        * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3710        * don't interfere with this optimisation.
3711        */
3712       if (bh->header.info == &stg_BLACKHOLE_info) {
3713         return;
3714       }
3715
3716       if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
3717           bh->header.info != &stg_CAF_BLACKHOLE_info) {
3718 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3719         belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3720 #endif
3721 #ifdef PROFILING
3722         // @LDV profiling
3723         // We pretend that bh is now dead.
3724         LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
3725 #endif
3726         SET_INFO(bh,&stg_BLACKHOLE_info);
3727 #ifdef PROFILING
3728         // @LDV profiling
3729         // We pretend that bh has just been created.
3730         LDV_recordCreate(bh);
3731 #endif
3732       }
3733
3734       update_frame = update_frame->link;
3735       break;
3736
3737     case SEQ_FRAME:
3738       update_frame = ((StgSeqFrame *)update_frame)->link;
3739       break;
3740
3741     case STOP_FRAME:
3742       return;
3743     default:
3744       barf("threadPaused");
3745     }
3746   }
3747 }
3748
3749
3750 /* -----------------------------------------------------------------------------
3751  * Stack squeezing
3752  *
3753  * Code largely pinched from old RTS, then hacked to bits.  We also do
3754  * lazy black holing here.
3755  *
3756  * -------------------------------------------------------------------------- */
3757
3758 static void
3759 threadSqueezeStack(StgTSO *tso)
3760 {
3761   lnat displacement = 0;
3762   StgUpdateFrame *frame;
3763   StgUpdateFrame *next_frame;                   // Temporally next
3764   StgUpdateFrame *prev_frame;                   // Temporally previous
3765   StgPtr bottom;
3766   rtsBool prev_was_update_frame;
3767 #if DEBUG
3768   StgUpdateFrame *top_frame;
3769   nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
3770       bhs=0, squeezes=0;
3771   void printObj( StgClosure *obj ); // from Printer.c
3772
3773   top_frame  = tso->su;
3774 #endif
3775
3776   bottom = &(tso->stack[tso->stack_size]);
3777   frame  = tso->su;
3778
3779   /* There must be at least one frame, namely the STOP_FRAME.
3780    */
3781   ASSERT((P_)frame < bottom);
3782
3783   /* Walk down the stack, reversing the links between frames so that
3784    * we can walk back up as we squeeze from the bottom.  Note that
3785    * next_frame and prev_frame refer to next and previous as they were
3786    * added to the stack, rather than the way we see them in this
3787    * walk. (It makes the next loop less confusing.)
3788    *
3789    * Stop if we find an update frame pointing to a black hole
3790    * (see comment in threadLazyBlackHole()).
3791    */
3792
3793   next_frame = NULL;
3794   // bottom - sizeof(StgStopFrame) is the STOP_FRAME
3795   while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
3796     prev_frame = frame->link;
3797     frame->link = next_frame;
3798     next_frame = frame;
3799     frame = prev_frame;
3800 #if DEBUG
3801     IF_DEBUG(sanity,
3802              if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
3803                printObj((StgClosure *)prev_frame);
3804                barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
3805                     frame, prev_frame);
3806              })
3807     switch (get_itbl(frame)->type) {
3808     case UPDATE_FRAME:
3809         upd_frames++;
3810         if (frame->updatee->header.info == &stg_BLACKHOLE_info)
3811             bhs++;
3812         break;
3813     case STOP_FRAME:
3814         stop_frames++;
3815         break;
3816     case CATCH_FRAME:
3817         catch_frames++;
3818         break;
3819     case SEQ_FRAME:
3820         seq_frames++;
3821         break;
3822     default:
3823       barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
3824            frame, prev_frame);
3825       printObj((StgClosure *)prev_frame);
3826     }
3827 #endif
3828     if (get_itbl(frame)->type == UPDATE_FRAME
3829         && frame->updatee->header.info == &stg_BLACKHOLE_info) {
3830         break;
3831     }
3832   }
3833
3834   /* Now, we're at the bottom.  Frame points to the lowest update
3835    * frame on the stack, and its link actually points to the frame
3836    * above. We have to walk back up the stack, squeezing out empty
3837    * update frames and turning the pointers back around on the way
3838    * back up.
3839    *
3840    * The bottom-most frame (the STOP_FRAME) has not been altered, and
3841    * we never want to eliminate it anyway.  Just walk one step up
3842    * before starting to squeeze. When you get to the topmost frame,
3843    * remember that there are still some words above it that might have
3844    * to be moved.
3845    */
3846
3847   prev_frame = frame;
3848   frame = next_frame;
3849
3850   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
3851
3852   /*
3853    * Loop through all of the frames (everything except the very
3854    * bottom).  Things are complicated by the fact that we have
3855    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
3856    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
3857    */
3858   while (frame != NULL) {
3859     StgPtr sp;
3860     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
3861     rtsBool is_update_frame;
3862
3863     next_frame = frame->link;
3864     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
3865
3866     /* Check to see if
3867      *   1. both the previous and current frame are update frames
3868      *   2. the current frame is empty
3869      */
3870     if (prev_was_update_frame && is_update_frame &&
3871         (P_)prev_frame == frame_bottom + displacement) {
3872
3873       // Now squeeze out the current frame
3874       StgClosure *updatee_keep   = prev_frame->updatee;
3875       StgClosure *updatee_bypass = frame->updatee;
3876
3877 #if DEBUG
3878       IF_DEBUG(gc, belch("@@ squeezing frame at %p", frame));
3879       squeezes++;
3880 #endif
3881
3882       /* Deal with blocking queues.  If both updatees have blocked
3883        * threads, then we should merge the queues into the update
3884        * frame that we're keeping.
3885        *
3886        * Alternatively, we could just wake them up: they'll just go
3887        * straight to sleep on the proper blackhole!  This is less code
3888        * and probably less bug prone, although it's probably much
3889        * slower --SDM
3890        */
3891 #if 0 // do it properly...
3892 #  if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3893 #    error Unimplemented lazy BH warning.  (KSW 1999-01)
3894 #  endif
3895       if (GET_INFO(updatee_bypass) == stg_BLACKHOLE_BQ_info
3896           || GET_INFO(updatee_bypass) == stg_CAF_BLACKHOLE_info
3897           ) {
3898         // Sigh.  It has one.  Don't lose those threads!
3899           if (GET_INFO(updatee_keep) == stg_BLACKHOLE_BQ_info) {
3900           // Urgh.  Two queues.  Merge them.
3901           P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
3902
3903           while (keep_tso->link != END_TSO_QUEUE) {
3904             keep_tso = keep_tso->link;
3905           }
3906           keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
3907
3908         } else {
3909           // For simplicity, just swap the BQ for the BH
3910           P_ temp = updatee_keep;
3911
3912           updatee_keep = updatee_bypass;
3913           updatee_bypass = temp;
3914
3915           // Record the swap in the kept frame (below)
3916           prev_frame->updatee = updatee_keep;
3917         }
3918       }
3919 #endif
3920
3921       TICK_UPD_SQUEEZED();
3922       /* wasn't there something about update squeezing and ticky to be
3923        * sorted out?  oh yes: we aren't counting each enter properly
3924        * in this case.  See the log somewhere.  KSW 1999-04-21
3925        *
3926        * Check two things: that the two update frames don't point to
3927        * the same object, and that the updatee_bypass isn't already an
3928        * indirection.  Both of these cases only happen when we're in a
3929        * block hole-style loop (and there are multiple update frames
3930        * on the stack pointing to the same closure), but they can both
3931        * screw us up if we don't check.
3932        */
3933       if (updatee_bypass != updatee_keep && !closure_IND(updatee_bypass)) {
3934           // this wakes the threads up
3935           UPD_IND_NOLOCK(updatee_bypass, updatee_keep);
3936       }
3937
3938       sp = (P_)frame - 1;       // sp = stuff to slide
3939       displacement += sizeofW(StgUpdateFrame);
3940
3941     } else {
3942       // No squeeze for this frame
3943       sp = frame_bottom - 1;    // Keep the current frame
3944
3945       /* Do lazy black-holing.
3946        */
3947       if (is_update_frame) {
3948         StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
3949         if (bh->header.info != &stg_BLACKHOLE_info &&
3950             bh->header.info != &stg_BLACKHOLE_BQ_info &&
3951             bh->header.info != &stg_CAF_BLACKHOLE_info) {
3952 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3953           belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3954 #endif
3955 #ifdef DEBUG
3956           /* zero out the slop so that the sanity checker can tell
3957            * where the next closure is.
3958            */
3959           {
3960               StgInfoTable *info = get_itbl(bh);
3961               nat np = info->layout.payload.ptrs, nw = info->layout.payload.nptrs, i;
3962               /* don't zero out slop for a THUNK_SELECTOR, because its layout
3963                * info is used for a different purpose, and it's exactly the
3964                * same size as a BLACKHOLE in any case.
3965                */
3966               if (info->type != THUNK_SELECTOR) {
3967                 for (i = np; i < np + nw; i++) {
3968                   ((StgClosure *)bh)->payload[i] = 0;
3969                 }
3970               }
3971           }
3972 #endif
3973 #ifdef PROFILING
3974           // @LDV profiling
3975           // We pretend that bh is now dead.
3976           LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
3977 #endif
3978           //
3979           // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
3980           //
3981           SET_INFO(bh,&stg_BLACKHOLE_info);
3982 #ifdef PROFILING
3983           // @LDV profiling
3984           // We pretend that bh has just been created.
3985           LDV_recordCreate(bh);
3986 #endif
3987         }
3988       }
3989
3990       // Fix the link in the current frame (should point to the frame below)
3991       frame->link = prev_frame;
3992       prev_was_update_frame = is_update_frame;
3993     }
3994
3995     // Now slide all words from sp up to the next frame
3996
3997     if (displacement > 0) {
3998       P_ next_frame_bottom;
3999
4000       if (next_frame != NULL)
4001         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
4002       else
4003         next_frame_bottom = tso->sp - 1;
4004
4005 #if 0
4006       IF_DEBUG(gc,
4007                belch("sliding [%p, %p] by %ld", sp, next_frame_bottom,
4008                      displacement))
4009 #endif
4010
4011       while (sp >= next_frame_bottom) {
4012         sp[displacement] = *sp;
4013         sp -= 1;
4014       }
4015     }
4016     (P_)prev_frame = (P_)frame + displacement;
4017     frame = next_frame;
4018   }
4019
4020   tso->sp += displacement;
4021   tso->su = prev_frame;
4022 #if 0
4023   IF_DEBUG(gc,
4024            belch("@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames",
4025                    squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
4026 #endif
4027 }
4028
4029
4030 /* -----------------------------------------------------------------------------
4031  * Pausing a thread
4032  *
4033  * We have to prepare for GC - this means doing lazy black holing
4034  * here.  We also take the opportunity to do stack squeezing if it's
4035  * turned on.
4036  * -------------------------------------------------------------------------- */
4037 void
4038 threadPaused(StgTSO *tso)
4039 {
4040   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4041     threadSqueezeStack(tso);    // does black holing too
4042   else
4043     threadLazyBlackHole(tso);
4044 }
4045
4046 /* -----------------------------------------------------------------------------
4047  * Debugging
4048  * -------------------------------------------------------------------------- */
4049
4050 #if DEBUG
4051 void
4052 printMutOnceList(generation *gen)
4053 {
4054   StgMutClosure *p, *next;
4055
4056   p = gen->mut_once_list;
4057   next = p->mut_link;
4058
4059   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4060   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4061     fprintf(stderr, "%p (%s), ",
4062             p, info_type((StgClosure *)p));
4063   }
4064   fputc('\n', stderr);
4065 }
4066
4067 void
4068 printMutableList(generation *gen)
4069 {
4070   StgMutClosure *p, *next;
4071
4072   p = gen->mut_list;
4073   next = p->mut_link;
4074
4075   fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4076   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4077     fprintf(stderr, "%p (%s), ",
4078             p, info_type((StgClosure *)p));
4079   }
4080   fputc('\n', stderr);
4081 }
4082
4083 static inline rtsBool
4084 maybeLarge(StgClosure *closure)
4085 {
4086   StgInfoTable *info = get_itbl(closure);
4087
4088   /* closure types that may be found on the new_large_objects list;
4089      see scavenge_large */
4090   return (info->type == MUT_ARR_PTRS ||
4091           info->type == MUT_ARR_PTRS_FROZEN ||
4092           info->type == TSO ||
4093           info->type == ARR_WORDS);
4094 }
4095
4096
4097 #endif // DEBUG