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