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