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