ghc/rts/GC.c

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