ghc/rts/GC.c

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