ghc/rts/GC.c

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