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