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_NOCAF_STATIC:
1902           /* no need to put these on the static linked list, they don't need
1903            * to be scavenged.
1904            */
1905           return q;
1906
1907       default:
1908           barf("evacuate(static): strange closure type %d", (int)(info->type));
1909       }
1910   }
1911
1912   bd = Bdescr((P_)q);
1913
1914   if (bd->gen_no > N) {
1915       /* Can't evacuate this object, because it's in a generation
1916        * older than the ones we're collecting.  Let's hope that it's
1917        * in evac_gen or older, or we will have to arrange to track
1918        * this pointer using the mutable list.
1919        */
1920       if (bd->gen_no < evac_gen) {
1921           // nope
1922           failed_to_evac = rtsTrue;
1923           TICK_GC_FAILED_PROMOTION();
1924       }
1925       return q;
1926   }
1927
1928   if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
1929
1930       /* pointer into to-space: just return it.  This normally
1931        * shouldn't happen, but alllowing it makes certain things
1932        * slightly easier (eg. the mutable list can contain the same
1933        * object twice, for example).
1934        */
1935       if (bd->flags & BF_EVACUATED) {
1936           if (bd->gen_no < evac_gen) {
1937               failed_to_evac = rtsTrue;
1938               TICK_GC_FAILED_PROMOTION();
1939           }
1940           return q;
1941       }
1942
1943       /* evacuate large objects by re-linking them onto a different list.
1944        */
1945       if (bd->flags & BF_LARGE) {
1946           info = get_itbl(q);
1947           if (info->type == TSO &&
1948               ((StgTSO *)q)->what_next == ThreadRelocated) {
1949               q = (StgClosure *)((StgTSO *)q)->link;
1950               goto loop;
1951           }
1952           evacuate_large((P_)q);
1953           return q;
1954       }
1955
1956       /* If the object is in a step that we're compacting, then we
1957        * need to use an alternative evacuate procedure.
1958        */
1959       if (bd->flags & BF_COMPACTED) {
1960           if (!is_marked((P_)q,bd)) {
1961               mark((P_)q,bd);
1962               if (mark_stack_full()) {
1963                   mark_stack_overflowed = rtsTrue;
1964                   reset_mark_stack();
1965               }
1966               push_mark_stack((P_)q);
1967           }
1968           return q;
1969       }
1970   }
1971
1972   stp = bd->step->to;
1973
1974   info = get_itbl(q);
1975
1976   switch (info->type) {
1977
1978   case MUT_VAR_CLEAN:
1979   case MUT_VAR_DIRTY:
1980   case MVAR:
1981       return copy(q,sizeW_fromITBL(info),stp);
1982
1983   case CONSTR_0_1:
1984   {
1985       StgWord w = (StgWord)q->payload[0];
1986       if (q->header.info == Czh_con_info &&
1987           // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&
1988           (StgChar)w <= MAX_CHARLIKE) {
1989           return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
1990       }
1991       if (q->header.info == Izh_con_info &&
1992           (StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
1993           return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
1994       }
1995       // else
1996       return copy_noscav(q,sizeofW(StgHeader)+1,stp);
1997   }
1998
1999   case FUN_0_1:
2000   case FUN_1_0:
2001   case CONSTR_1_0:
2002     return copy(q,sizeofW(StgHeader)+1,stp);
2003
2004   case THUNK_1_0:
2005   case THUNK_0_1:
2006     return copy(q,sizeofW(StgThunk)+1,stp);
2007
2008   case THUNK_1_1:
2009   case THUNK_2_0:
2010   case THUNK_0_2:
2011 #ifdef NO_PROMOTE_THUNKS
2012     if (bd->gen_no == 0 &&
2013         bd->step->no != 0 &&
2014         bd->step->no == generations[bd->gen_no].n_steps-1) {
2015       stp = bd->step;
2016     }
2017 #endif
2018     return copy(q,sizeofW(StgThunk)+2,stp);
2019
2020   case FUN_1_1:
2021   case FUN_2_0:
2022   case CONSTR_1_1:
2023   case CONSTR_2_0:
2024   case FUN_0_2:
2025     return copy(q,sizeofW(StgHeader)+2,stp);
2026
2027   case CONSTR_0_2:
2028     return copy_noscav(q,sizeofW(StgHeader)+2,stp);
2029
2030   case THUNK:
2031     return copy(q,thunk_sizeW_fromITBL(info),stp);
2032
2033   case FUN:
2034   case CONSTR:
2035   case IND_PERM:
2036   case IND_OLDGEN_PERM:
2037   case WEAK:
2038   case STABLE_NAME:
2039     return copy(q,sizeW_fromITBL(info),stp);
2040
2041   case BCO:
2042       return copy(q,bco_sizeW((StgBCO *)q),stp);
2043
2044   case CAF_BLACKHOLE:
2045   case SE_CAF_BLACKHOLE:
2046   case SE_BLACKHOLE:
2047   case BLACKHOLE:
2048     return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
2049
2050   case THUNK_SELECTOR:
2051     {
2052         StgClosure *p;
2053         const StgInfoTable *info_ptr;
2054
2055         if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2056             return copy(q,THUNK_SELECTOR_sizeW(),stp);
2057         }
2058
2059         // stashed away for LDV profiling, see below
2060         info_ptr = q->header.info;
2061
2062         p = eval_thunk_selector(info->layout.selector_offset,
2063                                 (StgSelector *)q);
2064
2065         if (p == NULL) {
2066             return copy(q,THUNK_SELECTOR_sizeW(),stp);
2067         } else {
2068             StgClosure *val;
2069             // q is still BLACKHOLE'd.
2070             thunk_selector_depth++;
2071             val = evacuate(p);
2072             thunk_selector_depth--;
2073
2074 #ifdef PROFILING
2075             // For the purposes of LDV profiling, we have destroyed
2076             // the original selector thunk.
2077             SET_INFO(q, info_ptr);
2078             LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(q);
2079 #endif
2080
2081             // Update the THUNK_SELECTOR with an indirection to the
2082             // EVACUATED closure now at p.  Why do this rather than
2083             // upd_evacuee(q,p)?  Because we have an invariant that an
2084             // EVACUATED closure always points to an object in the
2085             // same or an older generation (required by the short-cut
2086             // test in the EVACUATED case, below).
2087             SET_INFO(q, &stg_IND_info);
2088             ((StgInd *)q)->indirectee = p;
2089
2090             // For the purposes of LDV profiling, we have created an
2091             // indirection.
2092             LDV_RECORD_CREATE(q);
2093
2094             return val;
2095         }
2096     }
2097
2098   case IND:
2099   case IND_OLDGEN:
2100     // follow chains of indirections, don't evacuate them
2101     q = ((StgInd*)q)->indirectee;
2102     goto loop;
2103
2104   case RET_BCO:
2105   case RET_SMALL:
2106   case RET_VEC_SMALL:
2107   case RET_BIG:
2108   case RET_VEC_BIG:
2109   case RET_DYN:
2110   case UPDATE_FRAME:
2111   case STOP_FRAME:
2112   case CATCH_FRAME:
2113   case CATCH_STM_FRAME:
2114   case CATCH_RETRY_FRAME:
2115   case ATOMICALLY_FRAME:
2116     // shouldn't see these
2117     barf("evacuate: stack frame at %p\n", q);
2118
2119   case PAP:
2120       return copy(q,pap_sizeW((StgPAP*)q),stp);
2121
2122   case AP:
2123       return copy(q,ap_sizeW((StgAP*)q),stp);
2124
2125   case AP_STACK:
2126       return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
2127
2128   case EVACUATED:
2129     /* Already evacuated, just return the forwarding address.
2130      * HOWEVER: if the requested destination generation (evac_gen) is
2131      * older than the actual generation (because the object was
2132      * already evacuated to a younger generation) then we have to
2133      * set the failed_to_evac flag to indicate that we couldn't
2134      * manage to promote the object to the desired generation.
2135      */
2136     /*
2137      * Optimisation: the check is fairly expensive, but we can often
2138      * shortcut it if either the required generation is 0, or the
2139      * current object (the EVACUATED) is in a high enough generation.
2140      * We know that an EVACUATED always points to an object in the
2141      * same or an older generation.  stp is the lowest step that the
2142      * current object would be evacuated to, so we only do the full
2143      * check if stp is too low.
2144      */
2145     if (evac_gen > 0 && stp->gen_no < evac_gen) {  // optimisation
2146       StgClosure *p = ((StgEvacuated*)q)->evacuee;
2147       if (HEAP_ALLOCED(p) && Bdescr((P_)p)->gen_no < evac_gen) {
2148         failed_to_evac = rtsTrue;
2149         TICK_GC_FAILED_PROMOTION();
2150       }
2151     }
2152     return ((StgEvacuated*)q)->evacuee;
2153
2154   case ARR_WORDS:
2155       // just copy the block
2156       return copy_noscav(q,arr_words_sizeW((StgArrWords *)q),stp);
2157
2158   case MUT_ARR_PTRS_CLEAN:
2159   case MUT_ARR_PTRS_DIRTY:
2160   case MUT_ARR_PTRS_FROZEN:
2161   case MUT_ARR_PTRS_FROZEN0:
2162       // just copy the block
2163       return copy(q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),stp);
2164
2165   case TSO:
2166     {
2167       StgTSO *tso = (StgTSO *)q;
2168
2169       /* Deal with redirected TSOs (a TSO that's had its stack enlarged).
2170        */
2171       if (tso->what_next == ThreadRelocated) {
2172         q = (StgClosure *)tso->link;
2173         goto loop;
2174       }
2175
2176       /* To evacuate a small TSO, we need to relocate the update frame
2177        * list it contains.
2178        */
2179       {
2180           StgTSO *new_tso;
2181           StgPtr p, q;
2182
2183           new_tso = (StgTSO *)copyPart((StgClosure *)tso,
2184                                        tso_sizeW(tso),
2185                                        sizeofW(StgTSO), stp);
2186           move_TSO(tso, new_tso);
2187           for (p = tso->sp, q = new_tso->sp;
2188                p < tso->stack+tso->stack_size;) {
2189               *q++ = *p++;
2190           }
2191
2192           return (StgClosure *)new_tso;
2193       }
2194     }
2195
2196 #if defined(PAR)
2197   case RBH:
2198     {
2199       //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
2200       to = copy(q,BLACKHOLE_sizeW(),stp);
2201       //ToDo: derive size etc from reverted IP
2202       //to = copy(q,size,stp);
2203       debugTrace(DEBUG_gc, "evacuate: RBH %p (%s) to %p (%s)",
2204                  q, info_type(q), to, info_type(to));
2205       return to;
2206     }
2207
2208   case BLOCKED_FETCH:
2209     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE);
2210     to = copy(q,sizeofW(StgBlockedFetch),stp);
2211     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2212                q, info_type(q), to, info_type(to));
2213     return to;
2214
2215 # ifdef DIST
2216   case REMOTE_REF:
2217 # endif
2218   case FETCH_ME:
2219     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2220     to = copy(q,sizeofW(StgFetchMe),stp);
2221     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2222                q, info_type(q), to, info_type(to)));
2223     return to;
2224
2225   case FETCH_ME_BQ:
2226     ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE);
2227     to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
2228     debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)",
2229                q, info_type(q), to, info_type(to)));
2230     return to;
2231 #endif
2232
2233   case TREC_HEADER:
2234     return copy(q,sizeofW(StgTRecHeader),stp);
2235
2236   case TVAR_WAIT_QUEUE:
2237     return copy(q,sizeofW(StgTVarWaitQueue),stp);
2238
2239   case TVAR:
2240     return copy(q,sizeofW(StgTVar),stp);
2241
2242   case TREC_CHUNK:
2243     return copy(q,sizeofW(StgTRecChunk),stp);
2244
2245   default:
2246     barf("evacuate: strange closure type %d", (int)(info->type));
2247   }
2248
2249   barf("evacuate");
2250 }
2251
2252 /* -----------------------------------------------------------------------------
2253    Evaluate a THUNK_SELECTOR if possible.
2254
2255    returns: NULL if we couldn't evaluate this THUNK_SELECTOR, or
2256    a closure pointer if we evaluated it and this is the result.  Note
2257    that "evaluating" the THUNK_SELECTOR doesn't necessarily mean
2258    reducing it to HNF, just that we have eliminated the selection.
2259    The result might be another thunk, or even another THUNK_SELECTOR.
2260
2261    If the return value is non-NULL, the original selector thunk has
2262    been BLACKHOLE'd, and should be updated with an indirection or a
2263    forwarding pointer.  If the return value is NULL, then the selector
2264    thunk is unchanged.
2265
2266    ***
2267    ToDo: the treatment of THUNK_SELECTORS could be improved in the
2268    following way (from a suggestion by Ian Lynagh):
2269
2270    We can have a chain like this:
2271
2272       sel_0 --> (a,b)
2273                  |
2274                  |-----> sel_0 --> (a,b)
2275                                     |
2276                                     |-----> sel_0 --> ...
2277
2278    and the depth limit means we don't go all the way to the end of the
2279    chain, which results in a space leak.  This affects the recursive
2280    call to evacuate() in the THUNK_SELECTOR case in evacuate(): *not*
2281    the recursive call to eval_thunk_selector() in
2282    eval_thunk_selector().
2283
2284    We could eliminate the depth bound in this case, in the following
2285    way:
2286
2287       - traverse the chain once to discover the *value* of the
2288         THUNK_SELECTOR.  Mark all THUNK_SELECTORS that we
2289         visit on the way as having been visited already (somehow).
2290
2291       - in a second pass, traverse the chain again updating all
2292         THUNK_SEELCTORS that we find on the way with indirections to
2293         the value.
2294
2295       - if we encounter a "marked" THUNK_SELECTOR in a normal
2296         evacuate(), we konw it can't be updated so just evac it.
2297
2298    Program that illustrates the problem:
2299
2300         foo [] = ([], [])
2301         foo (x:xs) = let (ys, zs) = foo xs
2302                      in if x >= 0 then (x:ys, zs) else (ys, x:zs)
2303
2304         main = bar [1..(100000000::Int)]
2305         bar xs = (\(ys, zs) -> print ys >> print zs) (foo xs)
2306
2307    -------------------------------------------------------------------------- */
2308
2309 static inline rtsBool
2310 is_to_space ( StgClosure *p )
2311 {
2312     bdescr *bd;
2313
2314     bd = Bdescr((StgPtr)p);
2315     if (HEAP_ALLOCED(p) &&
2316         ((bd->flags & BF_EVACUATED)
2317          || ((bd->flags & BF_COMPACTED) &&
2318              is_marked((P_)p,bd)))) {
2319         return rtsTrue;
2320     } else {
2321         return rtsFalse;
2322     }
2323 }
2324
2325 static StgClosure *
2326 eval_thunk_selector( nat field, StgSelector * p )
2327 {
2328     StgInfoTable *info;
2329     const StgInfoTable *info_ptr;
2330     StgClosure *selectee;
2331
2332     selectee = p->selectee;
2333
2334     // Save the real info pointer (NOTE: not the same as get_itbl()).
2335     info_ptr = p->header.info;
2336
2337     // If the THUNK_SELECTOR is in a generation that we are not
2338     // collecting, then bail out early.  We won't be able to save any
2339     // space in any case, and updating with an indirection is trickier
2340     // in an old gen.
2341     if (Bdescr((StgPtr)p)->gen_no > N) {
2342         return NULL;
2343     }
2344
2345     // BLACKHOLE the selector thunk, since it is now under evaluation.
2346     // This is important to stop us going into an infinite loop if
2347     // this selector thunk eventually refers to itself.
2348     SET_INFO(p,&stg_BLACKHOLE_info);
2349
2350 selector_loop:
2351
2352     // We don't want to end up in to-space, because this causes
2353     // problems when the GC later tries to evacuate the result of
2354     // eval_thunk_selector().  There are various ways this could
2355     // happen:
2356     //
2357     // 1. following an IND_STATIC
2358     //
2359     // 2. when the old generation is compacted, the mark phase updates
2360     //    from-space pointers to be to-space pointers, and we can't
2361     //    reliably tell which we're following (eg. from an IND_STATIC).
2362     //
2363     // 3. compacting GC again: if we're looking at a constructor in
2364     //    the compacted generation, it might point directly to objects
2365     //    in to-space.  We must bale out here, otherwise doing the selection
2366     //    will result in a to-space pointer being returned.
2367     //
2368     //  (1) is dealt with using a BF_EVACUATED test on the
2369     //  selectee. (2) and (3): we can tell if we're looking at an
2370     //  object in the compacted generation that might point to
2371     //  to-space objects by testing that (a) it is BF_COMPACTED, (b)
2372     //  the compacted generation is being collected, and (c) the
2373     //  object is marked.  Only a marked object may have pointers that
2374     //  point to to-space objects, because that happens when
2375     //  scavenging.
2376     //
2377     //  The to-space test is now embodied in the in_to_space() inline
2378     //  function, as it is re-used below.
2379     //
2380     if (is_to_space(selectee)) {
2381         goto bale_out;
2382     }
2383
2384     info = get_itbl(selectee);
2385     switch (info->type) {
2386       case CONSTR:
2387       case CONSTR_1_0:
2388       case CONSTR_0_1:
2389       case CONSTR_2_0:
2390       case CONSTR_1_1:
2391       case CONSTR_0_2:
2392       case CONSTR_STATIC:
2393       case CONSTR_NOCAF_STATIC:
2394           // check that the size is in range
2395           ASSERT(field <  (StgWord32)(info->layout.payload.ptrs +
2396                                       info->layout.payload.nptrs));
2397
2398           // Select the right field from the constructor, and check
2399           // that the result isn't in to-space.  It might be in
2400           // to-space if, for example, this constructor contains
2401           // pointers to younger-gen objects (and is on the mut-once
2402           // list).
2403           //
2404           {
2405               StgClosure *q;
2406               q = selectee->payload[field];
2407               if (is_to_space(q)) {
2408                   goto bale_out;
2409               } else {
2410                   return q;
2411               }
2412           }
2413
2414       case IND:
2415       case IND_PERM:
2416       case IND_OLDGEN:
2417       case IND_OLDGEN_PERM:
2418       case IND_STATIC:
2419           selectee = ((StgInd *)selectee)->indirectee;
2420           goto selector_loop;
2421
2422       case EVACUATED:
2423           // We don't follow pointers into to-space; the constructor
2424           // has already been evacuated, so we won't save any space
2425           // leaks by evaluating this selector thunk anyhow.
2426           break;
2427
2428       case THUNK_SELECTOR:
2429       {
2430           StgClosure *val;
2431
2432           // check that we don't recurse too much, re-using the
2433           // depth bound also used in evacuate().
2434           if (thunk_selector_depth >= MAX_THUNK_SELECTOR_DEPTH) {
2435               break;
2436           }
2437           thunk_selector_depth++;
2438
2439           val = eval_thunk_selector(info->layout.selector_offset,
2440                                     (StgSelector *)selectee);
2441
2442           thunk_selector_depth--;
2443
2444           if (val == NULL) {
2445               break;
2446           } else {
2447               // We evaluated this selector thunk, so update it with
2448               // an indirection.  NOTE: we don't use UPD_IND here,
2449               // because we are guaranteed that p is in a generation
2450               // that we are collecting, and we never want to put the
2451               // indirection on a mutable list.
2452 #ifdef PROFILING
2453               // For the purposes of LDV profiling, we have destroyed
2454               // the original selector thunk.
2455               SET_INFO(p, info_ptr);
2456               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
2457 #endif
2458               ((StgInd *)selectee)->indirectee = val;
2459               SET_INFO(selectee,&stg_IND_info);
2460
2461               // For the purposes of LDV profiling, we have created an
2462               // indirection.
2463               LDV_RECORD_CREATE(selectee);
2464
2465               selectee = val;
2466               goto selector_loop;
2467           }
2468       }
2469
2470       case AP:
2471       case AP_STACK:
2472       case THUNK:
2473       case THUNK_1_0:
2474       case THUNK_0_1:
2475       case THUNK_2_0:
2476       case THUNK_1_1:
2477       case THUNK_0_2:
2478       case THUNK_STATIC:
2479       case CAF_BLACKHOLE:
2480       case SE_CAF_BLACKHOLE:
2481       case SE_BLACKHOLE:
2482       case BLACKHOLE:
2483 #if defined(PAR)
2484       case RBH:
2485       case BLOCKED_FETCH:
2486 # ifdef DIST
2487       case REMOTE_REF:
2488 # endif
2489       case FETCH_ME:
2490       case FETCH_ME_BQ:
2491 #endif
2492           // not evaluated yet
2493           break;
2494
2495       default:
2496         barf("eval_thunk_selector: strange selectee %d",
2497              (int)(info->type));
2498     }
2499
2500 bale_out:
2501     // We didn't manage to evaluate this thunk; restore the old info pointer
2502     SET_INFO(p, info_ptr);
2503     return NULL;
2504 }
2505
2506 /* -----------------------------------------------------------------------------
2507    move_TSO is called to update the TSO structure after it has been
2508    moved from one place to another.
2509    -------------------------------------------------------------------------- */
2510
2511 void
2512 move_TSO (StgTSO *src, StgTSO *dest)
2513 {
2514     ptrdiff_t diff;
2515
2516     // relocate the stack pointer...
2517     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2518     dest->sp = (StgPtr)dest->sp + diff;
2519 }
2520
2521 /* Similar to scavenge_large_bitmap(), but we don't write back the
2522  * pointers we get back from evacuate().
2523  */
2524 static void
2525 scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
2526 {
2527     nat i, b, size;
2528     StgWord bitmap;
2529     StgClosure **p;
2530
2531     b = 0;
2532     bitmap = large_srt->l.bitmap[b];
2533     size   = (nat)large_srt->l.size;
2534     p      = (StgClosure **)large_srt->srt;
2535     for (i = 0; i < size; ) {
2536         if ((bitmap & 1) != 0) {
2537             evacuate(*p);
2538         }
2539         i++;
2540         p++;
2541         if (i % BITS_IN(W_) == 0) {
2542             b++;
2543             bitmap = large_srt->l.bitmap[b];
2544         } else {
2545             bitmap = bitmap >> 1;
2546         }
2547     }
2548 }
2549
2550 /* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
2551  * srt field in the info table.  That's ok, because we'll
2552  * never dereference it.
2553  */
2554 STATIC_INLINE void
2555 scavenge_srt (StgClosure **srt, nat srt_bitmap)
2556 {
2557   nat bitmap;
2558   StgClosure **p;
2559
2560   bitmap = srt_bitmap;
2561   p = srt;
2562
2563   if (bitmap == (StgHalfWord)(-1)) {
2564       scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
2565       return;
2566   }
2567
2568   while (bitmap != 0) {
2569       if ((bitmap & 1) != 0) {
2570 #ifdef ENABLE_WIN32_DLL_SUPPORT
2571           // Special-case to handle references to closures hiding out in DLLs, since
2572           // double indirections required to get at those. The code generator knows
2573           // which is which when generating the SRT, so it stores the (indirect)
2574           // reference to the DLL closure in the table by first adding one to it.
2575           // We check for this here, and undo the addition before evacuating it.
2576           //
2577           // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2578           // closure that's fixed at link-time, and no extra magic is required.
2579           if ( (unsigned long)(*srt) & 0x1 ) {
2580               evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2581           } else {
2582               evacuate(*p);
2583           }
2584 #else
2585           evacuate(*p);
2586 #endif
2587       }
2588       p++;
2589       bitmap = bitmap >> 1;
2590   }
2591 }
2592
2593
2594 STATIC_INLINE void
2595 scavenge_thunk_srt(const StgInfoTable *info)
2596 {
2597     StgThunkInfoTable *thunk_info;
2598
2599     if (!major_gc) return;
2600
2601     thunk_info = itbl_to_thunk_itbl(info);
2602     scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
2603 }
2604
2605 STATIC_INLINE void
2606 scavenge_fun_srt(const StgInfoTable *info)
2607 {
2608     StgFunInfoTable *fun_info;
2609
2610     if (!major_gc) return;
2611
2612     fun_info = itbl_to_fun_itbl(info);
2613     scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
2614 }
2615
2616 /* -----------------------------------------------------------------------------
2617    Scavenge a TSO.
2618    -------------------------------------------------------------------------- */
2619
2620 static void
2621 scavengeTSO (StgTSO *tso)
2622 {
2623     if (   tso->why_blocked == BlockedOnMVar
2624         || tso->why_blocked == BlockedOnBlackHole
2625         || tso->why_blocked == BlockedOnException
2626 #if defined(PAR)
2627         || tso->why_blocked == BlockedOnGA
2628         || tso->why_blocked == BlockedOnGA_NoSend
2629 #endif
2630         ) {
2631         tso->block_info.closure = evacuate(tso->block_info.closure);
2632     }
2633     tso->blocked_exceptions =
2634         (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2635
2636     // We don't always chase the link field: TSOs on the blackhole
2637     // queue are not automatically alive, so the link field is a
2638     // "weak" pointer in that case.
2639     if (tso->why_blocked != BlockedOnBlackHole) {
2640         tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
2641     }
2642
2643     // scavange current transaction record
2644     tso->trec = (StgTRecHeader *)evacuate((StgClosure *)tso->trec);
2645
2646     // scavenge this thread's stack
2647     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2648 }
2649
2650 /* -----------------------------------------------------------------------------
2651    Blocks of function args occur on the stack (at the top) and
2652    in PAPs.
2653    -------------------------------------------------------------------------- */
2654
2655 STATIC_INLINE StgPtr
2656 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2657 {
2658     StgPtr p;
2659     StgWord bitmap;
2660     nat size;
2661
2662     p = (StgPtr)args;
2663     switch (fun_info->f.fun_type) {
2664     case ARG_GEN:
2665         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2666         size = BITMAP_SIZE(fun_info->f.b.bitmap);
2667         goto small_bitmap;
2668     case ARG_GEN_BIG:
2669         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
2670         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2671         p += size;
2672         break;
2673     default:
2674         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2675         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
2676     small_bitmap:
2677         while (size > 0) {
2678             if ((bitmap & 1) == 0) {
2679                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2680             }
2681             p++;
2682             bitmap = bitmap >> 1;
2683             size--;
2684         }
2685         break;
2686     }
2687     return p;
2688 }
2689
2690 STATIC_INLINE StgPtr
2691 scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
2692 {
2693     StgPtr p;
2694     StgWord bitmap;
2695     StgFunInfoTable *fun_info;
2696
2697     fun_info = get_fun_itbl(fun);
2698     ASSERT(fun_info->i.type != PAP);
2699     p = (StgPtr)payload;
2700
2701     switch (fun_info->f.fun_type) {
2702     case ARG_GEN:
2703         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
2704         goto small_bitmap;
2705     case ARG_GEN_BIG:
2706         scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
2707         p += size;
2708         break;
2709     case ARG_BCO:
2710         scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
2711         p += size;
2712         break;
2713     default:
2714         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
2715     small_bitmap:
2716         while (size > 0) {
2717             if ((bitmap & 1) == 0) {
2718                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2719             }
2720             p++;
2721             bitmap = bitmap >> 1;
2722             size--;
2723         }
2724         break;
2725     }
2726     return p;
2727 }
2728
2729 STATIC_INLINE StgPtr
2730 scavenge_PAP (StgPAP *pap)
2731 {
2732     pap->fun = evacuate(pap->fun);
2733     return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
2734 }
2735
2736 STATIC_INLINE StgPtr
2737 scavenge_AP (StgAP *ap)
2738 {
2739     ap->fun = evacuate(ap->fun);
2740     return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
2741 }
2742
2743 /* -----------------------------------------------------------------------------
2744    Scavenge a given step until there are no more objects in this step
2745    to scavenge.
2746
2747    evac_gen is set by the caller to be either zero (for a step in a
2748    generation < N) or G where G is the generation of the step being
2749    scavenged.
2750
2751    We sometimes temporarily change evac_gen back to zero if we're
2752    scavenging a mutable object where early promotion isn't such a good
2753    idea.
2754    -------------------------------------------------------------------------- */
2755
2756 static void
2757 scavenge(step *stp)
2758 {
2759   StgPtr p, q;
2760   StgInfoTable *info;
2761   bdescr *bd;
2762   nat saved_evac_gen = evac_gen;
2763
2764   p = stp->scan;
2765   bd = stp->scan_bd;
2766
2767   failed_to_evac = rtsFalse;
2768
2769   /* scavenge phase - standard breadth-first scavenging of the
2770    * evacuated objects
2771    */
2772
2773   while (bd != stp->hp_bd || p < stp->hp) {
2774
2775     // If we're at the end of this block, move on to the next block
2776     if (bd != stp->hp_bd && p == bd->free) {
2777       bd = bd->link;
2778       p = bd->start;
2779       continue;
2780     }
2781
2782     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2783     info = get_itbl((StgClosure *)p);
2784
2785     ASSERT(thunk_selector_depth == 0);
2786
2787     q = p;
2788     switch (info->type) {
2789
2790     case MVAR:
2791     {
2792         StgMVar *mvar = ((StgMVar *)p);
2793         evac_gen = 0;
2794         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
2795         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
2796         mvar->value = evacuate((StgClosure *)mvar->value);
2797         evac_gen = saved_evac_gen;
2798         failed_to_evac = rtsTrue; // mutable.
2799         p += sizeofW(StgMVar);
2800         break;
2801     }
2802
2803     case FUN_2_0:
2804         scavenge_fun_srt(info);
2805         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2806         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2807         p += sizeofW(StgHeader) + 2;
2808         break;
2809
2810     case THUNK_2_0:
2811         scavenge_thunk_srt(info);
2812         ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
2813         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2814         p += sizeofW(StgThunk) + 2;
2815         break;
2816
2817     case CONSTR_2_0:
2818         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2819         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2820         p += sizeofW(StgHeader) + 2;
2821         break;
2822
2823     case THUNK_1_0:
2824         scavenge_thunk_srt(info);
2825         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2826         p += sizeofW(StgThunk) + 1;
2827         break;
2828
2829     case FUN_1_0:
2830         scavenge_fun_srt(info);
2831     case CONSTR_1_0:
2832         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2833         p += sizeofW(StgHeader) + 1;
2834         break;
2835
2836     case THUNK_0_1:
2837         scavenge_thunk_srt(info);
2838         p += sizeofW(StgThunk) + 1;
2839         break;
2840
2841     case FUN_0_1:
2842         scavenge_fun_srt(info);
2843     case CONSTR_0_1:
2844         p += sizeofW(StgHeader) + 1;
2845         break;
2846
2847     case THUNK_0_2:
2848         scavenge_thunk_srt(info);
2849         p += sizeofW(StgThunk) + 2;
2850         break;
2851
2852     case FUN_0_2:
2853         scavenge_fun_srt(info);
2854     case CONSTR_0_2:
2855         p += sizeofW(StgHeader) + 2;
2856         break;
2857
2858     case THUNK_1_1:
2859         scavenge_thunk_srt(info);
2860         ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
2861         p += sizeofW(StgThunk) + 2;
2862         break;
2863
2864     case FUN_1_1:
2865         scavenge_fun_srt(info);
2866     case CONSTR_1_1:
2867         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2868         p += sizeofW(StgHeader) + 2;
2869         break;
2870
2871     case FUN:
2872         scavenge_fun_srt(info);
2873         goto gen_obj;
2874
2875     case THUNK:
2876     {
2877         StgPtr end;
2878
2879         scavenge_thunk_srt(info);
2880         end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
2881         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
2882             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2883         }
2884         p += info->layout.payload.nptrs;
2885         break;
2886     }
2887
2888     gen_obj:
2889     case CONSTR:
2890     case WEAK:
2891     case STABLE_NAME:
2892     {
2893         StgPtr end;
2894
2895         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2896         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2897             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
2898         }
2899         p += info->layout.payload.nptrs;
2900         break;
2901     }
2902
2903     case BCO: {
2904         StgBCO *bco = (StgBCO *)p;
2905         bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
2906         bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
2907         bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
2908         bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
2909         p += bco_sizeW(bco);
2910         break;
2911     }
2912
2913     case IND_PERM:
2914       if (stp->gen->no != 0) {
2915 #ifdef PROFILING
2916         // @LDV profiling
2917         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2918         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2919         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2920 #endif
2921         //
2922         // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
2923         //
2924         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2925
2926         // We pretend that p has just been created.
2927         LDV_RECORD_CREATE((StgClosure *)p);
2928       }
2929         // fall through
2930     case IND_OLDGEN_PERM:
2931         ((StgInd *)p)->indirectee = evacuate(((StgInd *)p)->indirectee);
2932         p += sizeofW(StgInd);
2933         break;
2934
2935     case MUT_VAR_CLEAN:
2936     case MUT_VAR_DIRTY: {
2937         rtsBool saved_eager_promotion = eager_promotion;
2938
2939         eager_promotion = rtsFalse;
2940         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2941         eager_promotion = saved_eager_promotion;
2942
2943         if (failed_to_evac) {
2944             ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
2945         } else {
2946             ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
2947         }
2948         p += sizeofW(StgMutVar);
2949         break;
2950     }
2951
2952     case CAF_BLACKHOLE:
2953     case SE_CAF_BLACKHOLE:
2954     case SE_BLACKHOLE:
2955     case BLACKHOLE:
2956         p += BLACKHOLE_sizeW();
2957         break;
2958
2959     case THUNK_SELECTOR:
2960     {
2961         StgSelector *s = (StgSelector *)p;
2962         s->selectee = evacuate(s->selectee);
2963         p += THUNK_SELECTOR_sizeW();
2964         break;
2965     }
2966
2967     // A chunk of stack saved in a heap object
2968     case AP_STACK:
2969     {
2970         StgAP_STACK *ap = (StgAP_STACK *)p;
2971
2972         ap->fun = evacuate(ap->fun);
2973         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2974         p = (StgPtr)ap->payload + ap->size;
2975         break;
2976     }
2977
2978     case PAP:
2979         p = scavenge_PAP((StgPAP *)p);
2980         break;
2981
2982     case AP:
2983         p = scavenge_AP((StgAP *)p);
2984         break;
2985
2986     case ARR_WORDS:
2987         // nothing to follow
2988         p += arr_words_sizeW((StgArrWords *)p);
2989         break;
2990
2991     case MUT_ARR_PTRS_CLEAN:
2992     case MUT_ARR_PTRS_DIRTY:
2993         // follow everything
2994     {
2995         StgPtr next;
2996         rtsBool saved_eager;
2997
2998         // We don't eagerly promote objects pointed to by a mutable
2999         // array, but if we find the array only points to objects in
3000         // the same or an older generation, we mark it "clean" and
3001         // avoid traversing it during minor GCs.
3002         saved_eager = eager_promotion;
3003         eager_promotion = rtsFalse;
3004         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3005         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3006             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3007         }
3008         eager_promotion = saved_eager;
3009
3010         if (failed_to_evac) {
3011             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3012         } else {
3013             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3014         }
3015
3016         failed_to_evac = rtsTrue; // always put it on the mutable list.
3017         break;
3018     }
3019
3020     case MUT_ARR_PTRS_FROZEN:
3021     case MUT_ARR_PTRS_FROZEN0:
3022         // follow everything
3023     {
3024         StgPtr next;
3025
3026         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3027         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3028             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3029         }
3030
3031         // If we're going to put this object on the mutable list, then
3032         // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3033         if (failed_to_evac) {
3034             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3035         } else {
3036             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3037         }
3038         break;
3039     }
3040
3041     case TSO:
3042     {
3043         StgTSO *tso = (StgTSO *)p;
3044         rtsBool saved_eager = eager_promotion;
3045
3046         eager_promotion = rtsFalse;
3047         scavengeTSO(tso);
3048         eager_promotion = saved_eager;
3049
3050         if (failed_to_evac) {
3051             tso->flags |= TSO_DIRTY;
3052         } else {
3053             tso->flags &= ~TSO_DIRTY;
3054         }
3055
3056         failed_to_evac = rtsTrue; // always on the mutable list
3057         p += tso_sizeW(tso);
3058         break;
3059     }
3060
3061 #if defined(PAR)
3062     case RBH:
3063     {
3064 #if 0
3065         nat size, ptrs, nonptrs, vhs;
3066         char str[80];
3067         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3068 #endif
3069         StgRBH *rbh = (StgRBH *)p;
3070         (StgClosure *)rbh->blocking_queue =
3071             evacuate((StgClosure *)rbh->blocking_queue);
3072         failed_to_evac = rtsTrue;  // mutable anyhow.
3073         debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3074                    p, info_type(p), (StgClosure *)rbh->blocking_queue);
3075         // ToDo: use size of reverted closure here!
3076         p += BLACKHOLE_sizeW();
3077         break;
3078     }
3079
3080     case BLOCKED_FETCH:
3081     {
3082         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3083         // follow the pointer to the node which is being demanded
3084         (StgClosure *)bf->node =
3085             evacuate((StgClosure *)bf->node);
3086         // follow the link to the rest of the blocking queue
3087         (StgClosure *)bf->link =
3088             evacuate((StgClosure *)bf->link);
3089         debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3090                    bf, info_type((StgClosure *)bf),
3091                    bf->node, info_type(bf->node)));
3092         p += sizeofW(StgBlockedFetch);
3093         break;
3094     }
3095
3096 #ifdef DIST
3097     case REMOTE_REF:
3098 #endif
3099     case FETCH_ME:
3100         p += sizeofW(StgFetchMe);
3101         break; // nothing to do in this case
3102
3103     case FETCH_ME_BQ:
3104     {
3105         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3106         (StgClosure *)fmbq->blocking_queue =
3107             evacuate((StgClosure *)fmbq->blocking_queue);
3108         debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3109                    p, info_type((StgClosure *)p)));
3110         p += sizeofW(StgFetchMeBlockingQueue);
3111         break;
3112     }
3113 #endif
3114
3115     case TVAR_WAIT_QUEUE:
3116       {
3117         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3118         evac_gen = 0;
3119         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3120         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3121         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3122         evac_gen = saved_evac_gen;
3123         failed_to_evac = rtsTrue; // mutable
3124         p += sizeofW(StgTVarWaitQueue);
3125         break;
3126       }
3127
3128     case TVAR:
3129       {
3130         StgTVar *tvar = ((StgTVar *) p);
3131         evac_gen = 0;
3132         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3133         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3134         evac_gen = saved_evac_gen;
3135         failed_to_evac = rtsTrue; // mutable
3136         p += sizeofW(StgTVar);
3137         break;
3138       }
3139
3140     case TREC_HEADER:
3141       {
3142         StgTRecHeader *trec = ((StgTRecHeader *) p);
3143         evac_gen = 0;
3144         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3145         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3146         evac_gen = saved_evac_gen;
3147         failed_to_evac = rtsTrue; // mutable
3148         p += sizeofW(StgTRecHeader);
3149         break;
3150       }
3151
3152     case TREC_CHUNK:
3153       {
3154         StgWord i;
3155         StgTRecChunk *tc = ((StgTRecChunk *) p);
3156         TRecEntry *e = &(tc -> entries[0]);
3157         evac_gen = 0;
3158         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3159         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3160           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3161           e->expected_value = evacuate((StgClosure*)e->expected_value);
3162           e->new_value = evacuate((StgClosure*)e->new_value);
3163         }
3164         evac_gen = saved_evac_gen;
3165         failed_to_evac = rtsTrue; // mutable
3166         p += sizeofW(StgTRecChunk);
3167         break;
3168       }
3169
3170     default:
3171         barf("scavenge: unimplemented/strange closure type %d @ %p",
3172              info->type, p);
3173     }
3174
3175     /*
3176      * We need to record the current object on the mutable list if
3177      *  (a) It is actually mutable, or
3178      *  (b) It contains pointers to a younger generation.
3179      * Case (b) arises if we didn't manage to promote everything that
3180      * the current object points to into the current generation.
3181      */
3182     if (failed_to_evac) {
3183         failed_to_evac = rtsFalse;
3184         if (stp->gen_no > 0) {
3185             recordMutableGen((StgClosure *)q, stp->gen);
3186         }
3187     }
3188   }
3189
3190   stp->scan_bd = bd;
3191   stp->scan = p;
3192 }
3193
3194 /* -----------------------------------------------------------------------------
3195    Scavenge everything on the mark stack.
3196
3197    This is slightly different from scavenge():
3198       - we don't walk linearly through the objects, so the scavenger
3199         doesn't need to advance the pointer on to the next object.
3200    -------------------------------------------------------------------------- */
3201
3202 static void
3203 scavenge_mark_stack(void)
3204 {
3205     StgPtr p, q;
3206     StgInfoTable *info;
3207     nat saved_evac_gen;
3208
3209     evac_gen = oldest_gen->no;
3210     saved_evac_gen = evac_gen;
3211
3212 linear_scan:
3213     while (!mark_stack_empty()) {
3214         p = pop_mark_stack();
3215
3216         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3217         info = get_itbl((StgClosure *)p);
3218
3219         q = p;
3220         switch (info->type) {
3221
3222         case MVAR:
3223         {
3224             StgMVar *mvar = ((StgMVar *)p);
3225             evac_gen = 0;
3226             mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3227             mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3228             mvar->value = evacuate((StgClosure *)mvar->value);
3229             evac_gen = saved_evac_gen;
3230             failed_to_evac = rtsTrue; // mutable.
3231             break;
3232         }
3233
3234         case FUN_2_0:
3235             scavenge_fun_srt(info);
3236             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3237             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3238             break;
3239
3240         case THUNK_2_0:
3241             scavenge_thunk_srt(info);
3242             ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
3243             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3244             break;
3245
3246         case CONSTR_2_0:
3247             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
3248             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3249             break;
3250
3251         case FUN_1_0:
3252         case FUN_1_1:
3253             scavenge_fun_srt(info);
3254             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3255             break;
3256
3257         case THUNK_1_0:
3258         case THUNK_1_1:
3259             scavenge_thunk_srt(info);
3260             ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
3261             break;
3262
3263         case CONSTR_1_0:
3264         case CONSTR_1_1:
3265             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
3266             break;
3267
3268         case FUN_0_1:
3269         case FUN_0_2:
3270             scavenge_fun_srt(info);
3271             break;
3272
3273         case THUNK_0_1:
3274         case THUNK_0_2:
3275             scavenge_thunk_srt(info);
3276             break;
3277
3278         case CONSTR_0_1:
3279         case CONSTR_0_2:
3280             break;
3281
3282         case FUN:
3283             scavenge_fun_srt(info);
3284             goto gen_obj;
3285
3286         case THUNK:
3287         {
3288             StgPtr end;
3289
3290             scavenge_thunk_srt(info);
3291             end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3292             for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
3293                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3294             }
3295             break;
3296         }
3297
3298         gen_obj:
3299         case CONSTR:
3300         case WEAK:
3301         case STABLE_NAME:
3302         {
3303             StgPtr end;
3304
3305             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3306             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
3307                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3308             }
3309             break;
3310         }
3311
3312         case BCO: {
3313             StgBCO *bco = (StgBCO *)p;
3314             bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs);
3315             bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals);
3316             bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs);
3317             bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls);
3318             break;
3319         }
3320
3321         case IND_PERM:
3322             // don't need to do anything here: the only possible case
3323             // is that we're in a 1-space compacting collector, with
3324             // no "old" generation.
3325             break;
3326
3327         case IND_OLDGEN:
3328         case IND_OLDGEN_PERM:
3329             ((StgInd *)p)->indirectee =
3330                 evacuate(((StgInd *)p)->indirectee);
3331             break;
3332
3333         case MUT_VAR_CLEAN:
3334         case MUT_VAR_DIRTY: {
3335             rtsBool saved_eager_promotion = eager_promotion;
3336
3337             eager_promotion = rtsFalse;
3338             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3339             eager_promotion = saved_eager_promotion;
3340
3341             if (failed_to_evac) {
3342                 ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3343             } else {
3344                 ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3345             }
3346             break;
3347         }
3348
3349         case CAF_BLACKHOLE:
3350         case SE_CAF_BLACKHOLE:
3351         case SE_BLACKHOLE:
3352         case BLACKHOLE:
3353         case ARR_WORDS:
3354             break;
3355
3356         case THUNK_SELECTOR:
3357         {
3358             StgSelector *s = (StgSelector *)p;
3359             s->selectee = evacuate(s->selectee);
3360             break;
3361         }
3362
3363         // A chunk of stack saved in a heap object
3364         case AP_STACK:
3365         {
3366             StgAP_STACK *ap = (StgAP_STACK *)p;
3367
3368             ap->fun = evacuate(ap->fun);
3369             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3370             break;
3371         }
3372
3373         case PAP:
3374             scavenge_PAP((StgPAP *)p);
3375             break;
3376
3377         case AP:
3378             scavenge_AP((StgAP *)p);
3379             break;
3380
3381         case MUT_ARR_PTRS_CLEAN:
3382         case MUT_ARR_PTRS_DIRTY:
3383             // follow everything
3384         {
3385             StgPtr next;
3386             rtsBool saved_eager;
3387
3388             // We don't eagerly promote objects pointed to by a mutable
3389             // array, but if we find the array only points to objects in
3390             // the same or an older generation, we mark it "clean" and
3391             // avoid traversing it during minor GCs.
3392             saved_eager = eager_promotion;
3393             eager_promotion = rtsFalse;
3394             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3395             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3396                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3397             }
3398             eager_promotion = saved_eager;
3399
3400             if (failed_to_evac) {
3401                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3402             } else {
3403                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3404             }
3405
3406             failed_to_evac = rtsTrue; // mutable anyhow.
3407             break;
3408         }
3409
3410         case MUT_ARR_PTRS_FROZEN:
3411         case MUT_ARR_PTRS_FROZEN0:
3412             // follow everything
3413         {
3414             StgPtr next, q = p;
3415
3416             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3417             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3418                 *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3419             }
3420
3421             // If we're going to put this object on the mutable list, then
3422             // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3423             if (failed_to_evac) {
3424                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3425             } else {
3426                 ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3427             }
3428             break;
3429         }
3430
3431         case TSO:
3432         {
3433             StgTSO *tso = (StgTSO *)p;
3434             rtsBool saved_eager = eager_promotion;
3435
3436             eager_promotion = rtsFalse;
3437             scavengeTSO(tso);
3438             eager_promotion = saved_eager;
3439
3440             if (failed_to_evac) {
3441                 tso->flags |= TSO_DIRTY;
3442             } else {
3443                 tso->flags &= ~TSO_DIRTY;
3444             }
3445
3446             failed_to_evac = rtsTrue; // always on the mutable list
3447             break;
3448         }
3449
3450 #if defined(PAR)
3451         case RBH:
3452         {
3453 #if 0
3454             nat size, ptrs, nonptrs, vhs;
3455             char str[80];
3456             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3457 #endif
3458             StgRBH *rbh = (StgRBH *)p;
3459             bh->blocking_queue =
3460                 (StgTSO *)evacuate((StgClosure *)bh->blocking_queue);
3461             failed_to_evac = rtsTrue;  // mutable anyhow.
3462             debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3463                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
3464             break;
3465         }
3466
3467         case BLOCKED_FETCH:
3468         {
3469             StgBlockedFetch *bf = (StgBlockedFetch *)p;
3470             // follow the pointer to the node which is being demanded
3471             (StgClosure *)bf->node =
3472                 evacuate((StgClosure *)bf->node);
3473             // follow the link to the rest of the blocking queue
3474             (StgClosure *)bf->link =
3475                 evacuate((StgClosure *)bf->link);
3476             debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it",
3477                        bf, info_type((StgClosure *)bf),
3478                        bf->node, info_type(bf->node)));
3479             break;
3480         }
3481
3482 #ifdef DIST
3483         case REMOTE_REF:
3484 #endif
3485         case FETCH_ME:
3486             break; // nothing to do in this case
3487
3488         case FETCH_ME_BQ:
3489         {
3490             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3491             (StgClosure *)fmbq->blocking_queue =
3492                 evacuate((StgClosure *)fmbq->blocking_queue);
3493             debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3494                        p, info_type((StgClosure *)p)));
3495             break;
3496         }
3497 #endif /* PAR */
3498
3499         case TVAR_WAIT_QUEUE:
3500           {
3501             StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3502             evac_gen = 0;
3503             wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3504             wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3505             wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3506             evac_gen = saved_evac_gen;
3507             failed_to_evac = rtsTrue; // mutable
3508             break;
3509           }
3510
3511         case TVAR:
3512           {
3513             StgTVar *tvar = ((StgTVar *) p);
3514             evac_gen = 0;
3515             tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3516             tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3517             evac_gen = saved_evac_gen;
3518             failed_to_evac = rtsTrue; // mutable
3519             break;
3520           }
3521
3522         case TREC_CHUNK:
3523           {
3524             StgWord i;
3525             StgTRecChunk *tc = ((StgTRecChunk *) p);
3526             TRecEntry *e = &(tc -> entries[0]);
3527             evac_gen = 0;
3528             tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3529             for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3530               e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3531               e->expected_value = evacuate((StgClosure*)e->expected_value);
3532               e->new_value = evacuate((StgClosure*)e->new_value);
3533             }
3534             evac_gen = saved_evac_gen;
3535             failed_to_evac = rtsTrue; // mutable
3536             break;
3537           }
3538
3539         case TREC_HEADER:
3540           {
3541             StgTRecHeader *trec = ((StgTRecHeader *) p);
3542             evac_gen = 0;
3543             trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3544             trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3545             evac_gen = saved_evac_gen;
3546             failed_to_evac = rtsTrue; // mutable
3547             break;
3548           }
3549
3550         default:
3551             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
3552                  info->type, p);
3553         }
3554
3555         if (failed_to_evac) {
3556             failed_to_evac = rtsFalse;
3557             if (evac_gen > 0) {
3558                 recordMutableGen((StgClosure *)q, &generations[evac_gen]);
3559             }
3560         }
3561
3562         // mark the next bit to indicate "scavenged"
3563         mark(q+1, Bdescr(q));
3564
3565     } // while (!mark_stack_empty())
3566
3567     // start a new linear scan if the mark stack overflowed at some point
3568     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
3569         debugTrace(DEBUG_gc, "scavenge_mark_stack: starting linear scan");
3570         mark_stack_overflowed = rtsFalse;
3571         oldgen_scan_bd = oldest_gen->steps[0].old_blocks;
3572         oldgen_scan = oldgen_scan_bd->start;
3573     }
3574
3575     if (oldgen_scan_bd) {
3576         // push a new thing on the mark stack
3577     loop:
3578         // find a closure that is marked but not scavenged, and start
3579         // from there.
3580         while (oldgen_scan < oldgen_scan_bd->free
3581                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3582             oldgen_scan++;
3583         }
3584
3585         if (oldgen_scan < oldgen_scan_bd->free) {
3586
3587             // already scavenged?
3588             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3589                 oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3590                 goto loop;
3591             }
3592             push_mark_stack(oldgen_scan);
3593             // ToDo: bump the linear scan by the actual size of the object
3594             oldgen_scan += sizeofW(StgHeader) + MIN_PAYLOAD_SIZE;
3595             goto linear_scan;
3596         }
3597
3598         oldgen_scan_bd = oldgen_scan_bd->link;
3599         if (oldgen_scan_bd != NULL) {
3600             oldgen_scan = oldgen_scan_bd->start;
3601             goto loop;
3602         }
3603     }
3604 }
3605
3606 /* -----------------------------------------------------------------------------
3607    Scavenge one object.
3608
3609    This is used for objects that are temporarily marked as mutable
3610    because they contain old-to-new generation pointers.  Only certain
3611    objects can have this property.
3612    -------------------------------------------------------------------------- */
3613
3614 static rtsBool
3615 scavenge_one(StgPtr p)
3616 {
3617     const StgInfoTable *info;
3618     nat saved_evac_gen = evac_gen;
3619     rtsBool no_luck;
3620
3621     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3622     info = get_itbl((StgClosure *)p);
3623
3624     switch (info->type) {
3625
3626     case MVAR:
3627     {
3628         StgMVar *mvar = ((StgMVar *)p);
3629         evac_gen = 0;
3630         mvar->head = (StgTSO *)evacuate((StgClosure *)mvar->head);
3631         mvar->tail = (StgTSO *)evacuate((StgClosure *)mvar->tail);
3632         mvar->value = evacuate((StgClosure *)mvar->value);
3633         evac_gen = saved_evac_gen;
3634         failed_to_evac = rtsTrue; // mutable.
3635         break;
3636     }
3637
3638     case THUNK:
3639     case THUNK_1_0:
3640     case THUNK_0_1:
3641     case THUNK_1_1:
3642     case THUNK_0_2:
3643     case THUNK_2_0:
3644     {
3645         StgPtr q, end;
3646
3647         end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
3648         for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
3649             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3650         }
3651         break;
3652     }
3653
3654     case FUN:
3655     case FUN_1_0:                       // hardly worth specialising these guys
3656     case FUN_0_1:
3657     case FUN_1_1:
3658     case FUN_0_2:
3659     case FUN_2_0:
3660     case CONSTR:
3661     case CONSTR_1_0:
3662     case CONSTR_0_1:
3663     case CONSTR_1_1:
3664     case CONSTR_0_2:
3665     case CONSTR_2_0:
3666     case WEAK:
3667     case IND_PERM:
3668     {
3669         StgPtr q, end;
3670
3671         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3672         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3673             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
3674         }
3675         break;
3676     }
3677
3678     case MUT_VAR_CLEAN:
3679     case MUT_VAR_DIRTY: {
3680         StgPtr q = p;
3681         rtsBool saved_eager_promotion = eager_promotion;
3682
3683         eager_promotion = rtsFalse;
3684         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3685         eager_promotion = saved_eager_promotion;
3686
3687         if (failed_to_evac) {
3688             ((StgClosure *)q)->header.info = &stg_MUT_VAR_DIRTY_info;
3689         } else {
3690             ((StgClosure *)q)->header.info = &stg_MUT_VAR_CLEAN_info;
3691         }
3692         break;
3693     }
3694
3695     case CAF_BLACKHOLE:
3696     case SE_CAF_BLACKHOLE:
3697     case SE_BLACKHOLE:
3698     case BLACKHOLE:
3699         break;
3700
3701     case THUNK_SELECTOR:
3702     {
3703         StgSelector *s = (StgSelector *)p;
3704         s->selectee = evacuate(s->selectee);
3705         break;
3706     }
3707
3708     case AP_STACK:
3709     {
3710         StgAP_STACK *ap = (StgAP_STACK *)p;
3711
3712         ap->fun = evacuate(ap->fun);
3713         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3714         p = (StgPtr)ap->payload + ap->size;
3715         break;
3716     }
3717
3718     case PAP:
3719         p = scavenge_PAP((StgPAP *)p);
3720         break;
3721
3722     case AP:
3723         p = scavenge_AP((StgAP *)p);
3724         break;
3725
3726     case ARR_WORDS:
3727         // nothing to follow
3728         break;
3729
3730     case MUT_ARR_PTRS_CLEAN:
3731     case MUT_ARR_PTRS_DIRTY:
3732     {
3733         StgPtr next, q;
3734         rtsBool saved_eager;
3735
3736         // We don't eagerly promote objects pointed to by a mutable
3737         // array, but if we find the array only points to objects in
3738         // the same or an older generation, we mark it "clean" and
3739         // avoid traversing it during minor GCs.
3740         saved_eager = eager_promotion;
3741         eager_promotion = rtsFalse;
3742         q = p;
3743         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3744         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3745             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3746         }
3747         eager_promotion = saved_eager;
3748
3749         if (failed_to_evac) {
3750             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_DIRTY_info;
3751         } else {
3752             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_CLEAN_info;
3753         }
3754
3755         failed_to_evac = rtsTrue;
3756         break;
3757     }
3758
3759     case MUT_ARR_PTRS_FROZEN:
3760     case MUT_ARR_PTRS_FROZEN0:
3761     {
3762         // follow everything
3763         StgPtr next, q=p;
3764
3765         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3766         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3767             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
3768         }
3769
3770         // If we're going to put this object on the mutable list, then
3771         // set its info ptr to MUT_ARR_PTRS_FROZEN0 to indicate that.
3772         if (failed_to_evac) {
3773             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN0_info;
3774         } else {
3775             ((StgClosure *)q)->header.info = &stg_MUT_ARR_PTRS_FROZEN_info;
3776         }
3777         break;
3778     }
3779
3780     case TSO:
3781     {
3782         StgTSO *tso = (StgTSO *)p;
3783         rtsBool saved_eager = eager_promotion;
3784
3785         eager_promotion = rtsFalse;
3786         scavengeTSO(tso);
3787         eager_promotion = saved_eager;
3788
3789         if (failed_to_evac) {
3790             tso->flags |= TSO_DIRTY;
3791         } else {
3792             tso->flags &= ~TSO_DIRTY;
3793         }
3794
3795         failed_to_evac = rtsTrue; // always on the mutable list
3796         break;
3797     }
3798
3799 #if defined(PAR)
3800     case RBH:
3801     {
3802 #if 0
3803         nat size, ptrs, nonptrs, vhs;
3804         char str[80];
3805         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3806 #endif
3807         StgRBH *rbh = (StgRBH *)p;
3808         (StgClosure *)rbh->blocking_queue =
3809             evacuate((StgClosure *)rbh->blocking_queue);
3810         failed_to_evac = rtsTrue;  // mutable anyhow.
3811         debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)",
3812                    p, info_type(p), (StgClosure *)rbh->blocking_queue));
3813         // ToDo: use size of reverted closure here!
3814         break;
3815     }
3816
3817     case BLOCKED_FETCH:
3818     {
3819         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3820         // follow the pointer to the node which is being demanded
3821         (StgClosure *)bf->node =
3822             evacuate((StgClosure *)bf->node);
3823         // follow the link to the rest of the blocking queue
3824         (StgClosure *)bf->link =
3825             evacuate((StgClosure *)bf->link);
3826         debugTrace(DEBUG_gc,
3827                    "scavenge: %p (%s); node is now %p; exciting, isn't it",
3828                    bf, info_type((StgClosure *)bf),
3829                    bf->node, info_type(bf->node)));
3830         break;
3831     }
3832
3833 #ifdef DIST
3834     case REMOTE_REF:
3835 #endif
3836     case FETCH_ME:
3837         break; // nothing to do in this case
3838
3839     case FETCH_ME_BQ:
3840     {
3841         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3842         (StgClosure *)fmbq->blocking_queue =
3843             evacuate((StgClosure *)fmbq->blocking_queue);
3844         debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it",
3845                    p, info_type((StgClosure *)p)));
3846         break;
3847     }
3848 #endif
3849
3850     case TVAR_WAIT_QUEUE:
3851       {
3852         StgTVarWaitQueue *wq = ((StgTVarWaitQueue *) p);
3853         evac_gen = 0;
3854         wq->waiting_tso = (StgTSO *)evacuate((StgClosure*)wq->waiting_tso);
3855         wq->next_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->next_queue_entry);
3856         wq->prev_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)wq->prev_queue_entry);
3857         evac_gen = saved_evac_gen;
3858         failed_to_evac = rtsTrue; // mutable
3859         break;
3860       }
3861
3862     case TVAR:
3863       {
3864         StgTVar *tvar = ((StgTVar *) p);
3865         evac_gen = 0;
3866         tvar->current_value = evacuate((StgClosure*)tvar->current_value);
3867         tvar->first_wait_queue_entry = (StgTVarWaitQueue *)evacuate((StgClosure*)tvar->first_wait_queue_entry);
3868         evac_gen = saved_evac_gen;
3869         failed_to_evac = rtsTrue; // mutable
3870         break;
3871       }
3872
3873     case TREC_HEADER:
3874       {
3875         StgTRecHeader *trec = ((StgTRecHeader *) p);
3876         evac_gen = 0;
3877         trec->enclosing_trec = (StgTRecHeader *)evacuate((StgClosure*)trec->enclosing_trec);
3878         trec->current_chunk = (StgTRecChunk *)evacuate((StgClosure*)trec->current_chunk);
3879         evac_gen = saved_evac_gen;
3880         failed_to_evac = rtsTrue; // mutable
3881         break;
3882       }
3883
3884     case TREC_CHUNK:
3885       {
3886         StgWord i;
3887         StgTRecChunk *tc = ((StgTRecChunk *) p);
3888         TRecEntry *e = &(tc -> entries[0]);
3889         evac_gen = 0;
3890         tc->prev_chunk = (StgTRecChunk *)evacuate((StgClosure*)tc->prev_chunk);
3891         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
3892           e->tvar = (StgTVar *)evacuate((StgClosure*)e->tvar);
3893           e->expected_value = evacuate((StgClosure*)e->expected_value);
3894           e->new_value = evacuate((StgClosure*)e->new_value);
3895         }
3896         evac_gen = saved_evac_gen;
3897         failed_to_evac = rtsTrue; // mutable
3898         break;
3899       }
3900
3901     case IND_OLDGEN:
3902     case IND_OLDGEN_PERM:
3903     case IND_STATIC:
3904     {
3905         /* Careful here: a THUNK can be on the mutable list because
3906          * it contains pointers to young gen objects.  If such a thunk
3907          * is updated, the IND_OLDGEN will be added to the mutable
3908          * list again, and we'll scavenge it twice.  evacuate()
3909          * doesn't check whether the object has already been
3910          * evacuated, so we perform that check here.
3911          */
3912         StgClosure *q = ((StgInd *)p)->indirectee;
3913         if (HEAP_ALLOCED(q) && Bdescr((StgPtr)q)->flags & BF_EVACUATED) {
3914             break;
3915         }
3916         ((StgInd *)p)->indirectee = evacuate(q);
3917     }
3918
3919 #if 0 && defined(DEBUG)
3920       if (RtsFlags.DebugFlags.gc)
3921       /* Debugging code to print out the size of the thing we just
3922        * promoted
3923        */
3924       {
3925         StgPtr start = gen->steps[0].scan;
3926         bdescr *start_bd = gen->steps[0].scan_bd;
3927         nat size = 0;
3928         scavenge(&gen->steps[0]);
3929         if (start_bd != gen->steps[0].scan_bd) {
3930           size += (P_)BLOCK_ROUND_UP(start) - start;
3931           start_bd = start_bd->link;
3932           while (start_bd != gen->steps[0].scan_bd) {
3933             size += BLOCK_SIZE_W;
3934             start_bd = start_bd->link;
3935           }
3936           size += gen->steps[0].scan -
3937             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3938         } else {
3939           size = gen->steps[0].scan - start;
3940         }
3941         debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3942       }
3943 #endif
3944       break;
3945
3946     default:
3947         barf("scavenge_one: strange object %d", (int)(info->type));
3948     }
3949
3950     no_luck = failed_to_evac;
3951     failed_to_evac = rtsFalse;
3952     return (no_luck);
3953 }
3954
3955 /* -----------------------------------------------------------------------------
3956    Scavenging mutable lists.
3957
3958    We treat the mutable list of each generation > N (i.e. all the
3959    generations older than the one being collected) as roots.  We also
3960    remove non-mutable objects from the mutable list at this point.
3961    -------------------------------------------------------------------------- */
3962
3963 static void
3964 scavenge_mutable_list(generation *gen)
3965 {
3966     bdescr *bd;
3967     StgPtr p, q;
3968
3969     bd = gen->saved_mut_list;
3970
3971     evac_gen = gen->no;
3972     for (; bd != NULL; bd = bd->link) {
3973         for (q = bd->start; q < bd->free; q++) {
3974             p = (StgPtr)*q;
3975             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3976
3977 #ifdef DEBUG
3978             switch (get_itbl((StgClosure *)p)->type) {
3979             case MUT_VAR_CLEAN:
3980                 barf("MUT_VAR_CLEAN on mutable list");
3981             case MUT_VAR_DIRTY:
3982                 mutlist_MUTVARS++; break;
3983             case MUT_ARR_PTRS_CLEAN:
3984             case MUT_ARR_PTRS_DIRTY:
3985             case MUT_ARR_PTRS_FROZEN:
3986             case MUT_ARR_PTRS_FROZEN0:
3987                 mutlist_MUTARRS++; break;
3988             default:
3989                 mutlist_OTHERS++; break;
3990             }
3991 #endif
3992
3993             // Check whether this object is "clean", that is it
3994             // definitely doesn't point into a young generation.
3995             // Clean objects don't need to be scavenged.  Some clean
3996             // objects (MUT_VAR_CLEAN) are not kept on the mutable
3997             // list at all; others, such as MUT_ARR_PTRS_CLEAN and
3998             // TSO, are always on the mutable list.
3999             //
4000             switch (get_itbl((StgClosure *)p)->type) {
4001             case MUT_ARR_PTRS_CLEAN:
4002                 recordMutableGen((StgClosure *)p,gen);
4003                 continue;
4004             case TSO: {
4005                 StgTSO *tso = (StgTSO *)p;
4006                 if ((tso->flags & TSO_DIRTY) == 0) {
4007                     // A clean TSO: we don't have to traverse its
4008                     // stack.  However, we *do* follow the link field:
4009                     // we don't want to have to mark a TSO dirty just
4010                     // because we put it on a different queue.
4011                     if (tso->why_blocked != BlockedOnBlackHole) {
4012                         tso->link = (StgTSO *)evacuate((StgClosure *)tso->link);
4013                     }
4014                     recordMutableGen((StgClosure *)p,gen);
4015                     continue;
4016                 }
4017             }
4018             default:
4019                 ;
4020             }
4021
4022             if (scavenge_one(p)) {
4023                 // didn't manage to promote everything, so put the
4024                 // object back on the list.
4025                 recordMutableGen((StgClosure *)p,gen);
4026             }
4027         }
4028     }
4029
4030     // free the old mut_list
4031     freeChain(gen->saved_mut_list);
4032     gen->saved_mut_list = NULL;
4033 }
4034
4035
4036 static void
4037 scavenge_static(void)
4038 {
4039   StgClosure* p = static_objects;
4040   const StgInfoTable *info;
4041
4042   /* Always evacuate straight to the oldest generation for static
4043    * objects */
4044   evac_gen = oldest_gen->no;
4045
4046   /* keep going until we've scavenged all the objects on the linked
4047      list... */
4048   while (p != END_OF_STATIC_LIST) {
4049
4050     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
4051     info = get_itbl(p);
4052     /*
4053     if (info->type==RBH)
4054       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
4055     */
4056     // make sure the info pointer is into text space
4057
4058     /* Take this object *off* the static_objects list,
4059      * and put it on the scavenged_static_objects list.
4060      */
4061     static_objects = *STATIC_LINK(info,p);
4062     *STATIC_LINK(info,p) = scavenged_static_objects;
4063     scavenged_static_objects = p;
4064
4065     switch (info -> type) {
4066
4067     case IND_STATIC:
4068       {
4069         StgInd *ind = (StgInd *)p;
4070         ind->indirectee = evacuate(ind->indirectee);
4071
4072         /* might fail to evacuate it, in which case we have to pop it
4073          * back on the mutable list of the oldest generation.  We
4074          * leave it *on* the scavenged_static_objects list, though,
4075          * in case we visit this object again.
4076          */
4077         if (failed_to_evac) {
4078           failed_to_evac = rtsFalse;
4079           recordMutableGen((StgClosure *)p,oldest_gen);
4080         }
4081         break;
4082       }
4083
4084     case THUNK_STATIC:
4085       scavenge_thunk_srt(info);
4086       break;
4087
4088     case FUN_STATIC:
4089       scavenge_fun_srt(info);
4090       break;
4091
4092     case CONSTR_STATIC:
4093       {
4094         StgPtr q, next;
4095
4096         next = (P_)p->payload + info->layout.payload.ptrs;
4097         // evacuate the pointers
4098         for (q = (P_)p->payload; q < next; q++) {
4099             *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
4100         }
4101         break;
4102       }
4103
4104     default:
4105       barf("scavenge_static: strange closure %d", (int)(info->type));
4106     }
4107
4108     ASSERT(failed_to_evac == rtsFalse);
4109
4110     /* get the next static object from the list.  Remember, there might
4111      * be more stuff on this list now that we've done some evacuating!
4112      * (static_objects is a global)
4113      */
4114     p = static_objects;
4115   }
4116 }
4117
4118 /* -----------------------------------------------------------------------------
4119    scavenge a chunk of memory described by a bitmap
4120    -------------------------------------------------------------------------- */
4121
4122 static void
4123 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
4124 {
4125     nat i, b;
4126     StgWord bitmap;
4127
4128     b = 0;
4129     bitmap = large_bitmap->bitmap[b];
4130     for (i = 0; i < size; ) {
4131         if ((bitmap & 1) == 0) {
4132             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4133         }
4134         i++;
4135         p++;
4136         if (i % BITS_IN(W_) == 0) {
4137             b++;
4138             bitmap = large_bitmap->bitmap[b];
4139         } else {
4140             bitmap = bitmap >> 1;
4141         }
4142     }
4143 }
4144
4145 STATIC_INLINE StgPtr
4146 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
4147 {
4148     while (size > 0) {
4149         if ((bitmap & 1) == 0) {
4150             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4151         }
4152         p++;
4153         bitmap = bitmap >> 1;
4154         size--;
4155     }
4156     return p;
4157 }
4158
4159 /* -----------------------------------------------------------------------------
4160    scavenge_stack walks over a section of stack and evacuates all the
4161    objects pointed to by it.  We can use the same code for walking
4162    AP_STACK_UPDs, since these are just sections of copied stack.
4163    -------------------------------------------------------------------------- */
4164
4165
4166 static void
4167 scavenge_stack(StgPtr p, StgPtr stack_end)
4168 {
4169   const StgRetInfoTable* info;
4170   StgWord bitmap;
4171   nat size;
4172
4173   /*
4174    * Each time around this loop, we are looking at a chunk of stack
4175    * that starts with an activation record.
4176    */
4177
4178   while (p < stack_end) {
4179     info  = get_ret_itbl((StgClosure *)p);
4180
4181     switch (info->i.type) {
4182
4183     case UPDATE_FRAME:
4184         // In SMP, we can get update frames that point to indirections
4185         // when two threads evaluate the same thunk.  We do attempt to
4186         // discover this situation in threadPaused(), but it's
4187         // possible that the following sequence occurs:
4188         //
4189         //        A             B
4190         //                  enter T
4191         //     enter T
4192         //     blackhole T
4193         //                  update T
4194         //     GC
4195         //
4196         // Now T is an indirection, and the update frame is already
4197         // marked on A's stack, so we won't traverse it again in
4198         // threadPaused().  We could traverse the whole stack again
4199         // before GC, but that seems like overkill.
4200         //
4201         // Scavenging this update frame as normal would be disastrous;
4202         // the updatee would end up pointing to the value.  So we turn
4203         // the indirection into an IND_PERM, so that evacuate will
4204         // copy the indirection into the old generation instead of
4205         // discarding it.
4206         if (get_itbl(((StgUpdateFrame *)p)->updatee)->type == IND) {
4207             ((StgUpdateFrame *)p)->updatee->header.info =
4208                 (StgInfoTable *)&stg_IND_PERM_info;
4209         }
4210         ((StgUpdateFrame *)p)->updatee
4211             = evacuate(((StgUpdateFrame *)p)->updatee);
4212         p += sizeofW(StgUpdateFrame);
4213         continue;
4214
4215       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
4216     case CATCH_STM_FRAME:
4217     case CATCH_RETRY_FRAME:
4218     case ATOMICALLY_FRAME:
4219     case STOP_FRAME:
4220     case CATCH_FRAME:
4221     case RET_SMALL:
4222     case RET_VEC_SMALL:
4223         bitmap = BITMAP_BITS(info->i.layout.bitmap);
4224         size   = BITMAP_SIZE(info->i.layout.bitmap);
4225         // NOTE: the payload starts immediately after the info-ptr, we
4226         // don't have an StgHeader in the same sense as a heap closure.
4227         p++;
4228         p = scavenge_small_bitmap(p, size, bitmap);
4229
4230     follow_srt:
4231         if (major_gc)
4232             scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
4233         continue;
4234
4235     case RET_BCO: {
4236         StgBCO *bco;
4237         nat size;
4238
4239         p++;
4240         *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4241         bco = (StgBCO *)*p;
4242         p++;
4243         size = BCO_BITMAP_SIZE(bco);
4244         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
4245         p += size;
4246         continue;
4247     }
4248
4249       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
4250     case RET_BIG:
4251     case RET_VEC_BIG:
4252     {
4253         nat size;
4254
4255         size = GET_LARGE_BITMAP(&info->i)->size;
4256         p++;
4257         scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
4258         p += size;
4259         // and don't forget to follow the SRT
4260         goto follow_srt;
4261     }
4262
4263       // Dynamic bitmap: the mask is stored on the stack, and
4264       // there are a number of non-pointers followed by a number
4265       // of pointers above the bitmapped area.  (see StgMacros.h,
4266       // HEAP_CHK_GEN).
4267     case RET_DYN:
4268     {
4269         StgWord dyn;
4270         dyn = ((StgRetDyn *)p)->liveness;
4271
4272         // traverse the bitmap first
4273         bitmap = RET_DYN_LIVENESS(dyn);
4274         p      = (P_)&((StgRetDyn *)p)->payload[0];
4275         size   = RET_DYN_BITMAP_SIZE;
4276         p = scavenge_small_bitmap(p, size, bitmap);
4277
4278         // skip over the non-ptr words
4279         p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
4280
4281         // follow the ptr words
4282         for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
4283             *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
4284             p++;
4285         }
4286         continue;
4287     }
4288
4289     case RET_FUN:
4290     {
4291         StgRetFun *ret_fun = (StgRetFun *)p;
4292         StgFunInfoTable *fun_info;
4293
4294         ret_fun->fun = evacuate(ret_fun->fun);
4295         fun_info = get_fun_itbl(ret_fun->fun);
4296         p = scavenge_arg_block(fun_info, ret_fun->payload);
4297         goto follow_srt;
4298     }
4299
4300     default:
4301         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
4302     }
4303   }
4304 }
4305
4306 /*-----------------------------------------------------------------------------
4307   scavenge the large object list.
4308
4309   evac_gen set by caller; similar games played with evac_gen as with
4310   scavenge() - see comment at the top of scavenge().  Most large
4311   objects are (repeatedly) mutable, so most of the time evac_gen will
4312   be zero.
4313   --------------------------------------------------------------------------- */
4314
4315 static void
4316 scavenge_large(step *stp)
4317 {
4318   bdescr *bd;
4319   StgPtr p;
4320
4321   bd = stp->new_large_objects;
4322
4323   for (; bd != NULL; bd = stp->new_large_objects) {
4324
4325     /* take this object *off* the large objects list and put it on
4326      * the scavenged large objects list.  This is so that we can
4327      * treat new_large_objects as a stack and push new objects on
4328      * the front when evacuating.
4329      */
4330     stp->new_large_objects = bd->link;
4331     dbl_link_onto(bd, &stp->scavenged_large_objects);
4332
4333     // update the block count in this step.
4334     stp->n_scavenged_large_blocks += bd->blocks;
4335
4336     p = bd->start;
4337     if (scavenge_one(p)) {
4338         if (stp->gen_no > 0) {
4339             recordMutableGen((StgClosure *)p, stp->gen);
4340         }
4341     }
4342   }
4343 }
4344
4345 /* -----------------------------------------------------------------------------
4346    Initialising the static object & mutable lists
4347    -------------------------------------------------------------------------- */
4348
4349 static void
4350 zero_static_object_list(StgClosure* first_static)
4351 {
4352   StgClosure* p;
4353   StgClosure* link;
4354   const StgInfoTable *info;
4355
4356   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
4357     info = get_itbl(p);
4358     link = *STATIC_LINK(info, p);
4359     *STATIC_LINK(info,p) = NULL;
4360   }
4361 }
4362
4363 /* -----------------------------------------------------------------------------
4364    Reverting CAFs
4365    -------------------------------------------------------------------------- */
4366
4367 void
4368 revertCAFs( void )
4369 {
4370     StgIndStatic *c;
4371
4372     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4373          c = (StgIndStatic *)c->static_link)
4374     {
4375         SET_INFO(c, c->saved_info);
4376         c->saved_info = NULL;
4377         // could, but not necessary: c->static_link = NULL;
4378     }
4379     revertible_caf_list = NULL;
4380 }
4381
4382 void
4383 markCAFs( evac_fn evac )
4384 {
4385     StgIndStatic *c;
4386
4387     for (c = (StgIndStatic *)caf_list; c != NULL;
4388          c = (StgIndStatic *)c->static_link)
4389     {
4390         evac(&c->indirectee);
4391     }
4392     for (c = (StgIndStatic *)revertible_caf_list; c != NULL;
4393          c = (StgIndStatic *)c->static_link)
4394     {
4395         evac(&c->indirectee);
4396     }
4397 }
4398
4399 /* -----------------------------------------------------------------------------
4400    Sanity code for CAF garbage collection.
4401
4402    With DEBUG turned on, we manage a CAF list in addition to the SRT
4403    mechanism.  After GC, we run down the CAF list and blackhole any
4404    CAFs which have been garbage collected.  This means we get an error
4405    whenever the program tries to enter a garbage collected CAF.
4406
4407    Any garbage collected CAFs are taken off the CAF list at the same
4408    time.
4409    -------------------------------------------------------------------------- */
4410
4411 #if 0 && defined(DEBUG)
4412
4413 static void
4414 gcCAFs(void)
4415 {
4416   StgClosure*  p;
4417   StgClosure** pp;
4418   const StgInfoTable *info;
4419   nat i;
4420
4421   i = 0;
4422   p = caf_list;
4423   pp = &caf_list;
4424
4425   while (p != NULL) {
4426
4427     info = get_itbl(p);
4428
4429     ASSERT(info->type == IND_STATIC);
4430
4431     if (STATIC_LINK(info,p) == NULL) {
4432         debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p);
4433         // black hole it
4434         SET_INFO(p,&stg_BLACKHOLE_info);
4435         p = STATIC_LINK2(info,p);
4436         *pp = p;
4437     }
4438     else {
4439       pp = &STATIC_LINK2(info,p);
4440       p = *pp;
4441       i++;
4442     }
4443
4444   }
4445
4446   debugTrace(DEBUG_gccafs, "%d CAFs live", i);
4447 }
4448 #endif
4449
4450
4451 /* -----------------------------------------------------------------------------
4452  * Stack squeezing
4453  *
4454  * Code largely pinched from old RTS, then hacked to bits.  We also do
4455  * lazy black holing here.
4456  *
4457  * -------------------------------------------------------------------------- */
4458
4459 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
4460
4461 static void
4462 stackSqueeze(StgTSO *tso, StgPtr bottom)
4463 {
4464     StgPtr frame;
4465     rtsBool prev_was_update_frame;
4466     StgClosure *updatee = NULL;
4467     StgRetInfoTable *info;
4468     StgWord current_gap_size;
4469     struct stack_gap *gap;
4470
4471     // Stage 1:
4472     //    Traverse the stack upwards, replacing adjacent update frames
4473     //    with a single update frame and a "stack gap".  A stack gap
4474     //    contains two values: the size of the gap, and the distance
4475     //    to the next gap (or the stack top).
4476
4477     frame = tso->sp;
4478
4479     ASSERT(frame < bottom);
4480
4481     prev_was_update_frame = rtsFalse;
4482     current_gap_size = 0;
4483     gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
4484
4485     while (frame < bottom) {
4486
4487         info = get_ret_itbl((StgClosure *)frame);
4488         switch (info->i.type) {
4489
4490         case UPDATE_FRAME:
4491         {
4492             StgUpdateFrame *upd = (StgUpdateFrame *)frame;
4493
4494             if (prev_was_update_frame) {
4495
4496                 TICK_UPD_SQUEEZED();
4497                 /* wasn't there something about update squeezing and ticky to be
4498                  * sorted out?  oh yes: we aren't counting each enter properly
4499                  * in this case.  See the log somewhere.  KSW 1999-04-21
4500                  *
4501                  * Check two things: that the two update frames don't point to
4502                  * the same object, and that the updatee_bypass isn't already an
4503                  * indirection.  Both of these cases only happen when we're in a
4504                  * block hole-style loop (and there are multiple update frames
4505                  * on the stack pointing to the same closure), but they can both
4506                  * screw us up if we don't check.
4507                  */
4508                 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4509                     UPD_IND_NOLOCK(upd->updatee, updatee);
4510                 }
4511
4512                 // now mark this update frame as a stack gap.  The gap
4513                 // marker resides in the bottom-most update frame of
4514                 // the series of adjacent frames, and covers all the
4515                 // frames in this series.
4516                 current_gap_size += sizeofW(StgUpdateFrame);
4517                 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4518                 ((struct stack_gap *)frame)->next_gap = gap;
4519
4520                 frame += sizeofW(StgUpdateFrame);
4521                 continue;
4522             }
4523
4524             // single update frame, or the topmost update frame in a series
4525             else {
4526                 prev_was_update_frame = rtsTrue;
4527                 updatee = upd->updatee;
4528                 frame += sizeofW(StgUpdateFrame);
4529                 continue;
4530             }
4531         }
4532
4533         default:
4534             prev_was_update_frame = rtsFalse;
4535
4536             // we're not in a gap... check whether this is the end of a gap
4537             // (an update frame can't be the end of a gap).
4538             if (current_gap_size != 0) {
4539                 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4540             }
4541             current_gap_size = 0;
4542
4543             frame += stack_frame_sizeW((StgClosure *)frame);
4544             continue;
4545         }
4546     }
4547
4548     if (current_gap_size != 0) {
4549         gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4550     }
4551
4552     // Now we have a stack with gaps in it, and we have to walk down
4553     // shoving the stack up to fill in the gaps.  A diagram might
4554     // help:
4555     //
4556     //    +| ********* |
4557     //     | ********* | <- sp
4558     //     |           |
4559     //     |           | <- gap_start
4560     //     | ......... |                |
4561     //     | stack_gap | <- gap         | chunk_size
4562     //     | ......... |                |
4563     //     | ......... | <- gap_end     v
4564     //     | ********* |
4565     //     | ********* |
4566     //     | ********* |
4567     //    -| ********* |
4568     //
4569     // 'sp'  points the the current top-of-stack
4570     // 'gap' points to the stack_gap structure inside the gap
4571     // *****   indicates real stack data
4572     // .....   indicates gap
4573     // <empty> indicates unused
4574     //
4575     {
4576         void *sp;
4577         void *gap_start, *next_gap_start, *gap_end;
4578         nat chunk_size;
4579
4580         next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4581         sp = next_gap_start;
4582
4583         while ((StgPtr)gap > tso->sp) {
4584
4585             // we're working in *bytes* now...
4586             gap_start = next_gap_start;
4587             gap_end = (void*) ((unsigned char*)gap_start - gap->gap_size * sizeof(W_));
4588
4589             gap = gap->next_gap;
4590             next_gap_start = (void *)((unsigned char*)gap + sizeof(StgUpdateFrame));
4591
4592             chunk_size = (unsigned char*)gap_end - (unsigned char*)next_gap_start;
4593             sp -= chunk_size;
4594             memmove(sp, next_gap_start, chunk_size);
4595         }
4596
4597         tso->sp = (StgPtr)sp;
4598     }
4599 }
4600
4601 /* -----------------------------------------------------------------------------
4602  * Pausing a thread
4603  *
4604  * We have to prepare for GC - this means doing lazy black holing
4605  * here.  We also take the opportunity to do stack squeezing if it's
4606  * turned on.
4607  * -------------------------------------------------------------------------- */
4608 void
4609 threadPaused(Capability *cap, StgTSO *tso)
4610 {
4611     StgClosure *frame;
4612     StgRetInfoTable *info;
4613     StgClosure *bh;
4614     StgPtr stack_end;
4615     nat words_to_squeeze = 0;
4616     nat weight           = 0;
4617     nat weight_pending   = 0;
4618     rtsBool prev_was_update_frame;
4619
4620     // Check to see whether we have threads waiting to raise
4621     // exceptions, and we're not blocking exceptions, or are blocked
4622     // interruptibly.  This is important; if a thread is running with
4623     // TSO_BLOCKEX and becomes blocked interruptibly, this is the only
4624     // place we ensure that the blocked_exceptions get a chance.
4625     maybePerformBlockedException (cap, tso);
4626     if (tso->what_next == ThreadKilled) { return; }
4627
4628     stack_end = &tso->stack[tso->stack_size];
4629
4630     frame = (StgClosure *)tso->sp;
4631
4632     while (1) {
4633         // If we've already marked this frame, then stop here.
4634         if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) {
4635             goto end;
4636         }
4637
4638         info = get_ret_itbl(frame);
4639
4640         switch (info->i.type) {
4641
4642         case UPDATE_FRAME:
4643
4644             SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info);
4645
4646             bh = ((StgUpdateFrame *)frame)->updatee;
4647
4648             if (closure_IND(bh) || bh->header.info == &stg_BLACKHOLE_info) {
4649                 debugTrace(DEBUG_squeeze,
4650                            "suspending duplicate work: %ld words of stack",
4651                            (long)((StgPtr)frame - tso->sp));
4652
4653                 // If this closure is already an indirection, then
4654                 // suspend the computation up to this point:
4655                 suspendComputation(cap,tso,(StgPtr)frame);
4656
4657                 // Now drop the update frame, and arrange to return
4658                 // the value to the frame underneath:
4659                 tso->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2;
4660                 tso->sp[1] = (StgWord)bh;
4661                 tso->sp[0] = (W_)&stg_enter_info;
4662
4663                 // And continue with threadPaused; there might be
4664                 // yet more computation to suspend.
4665                 threadPaused(cap,tso);
4666                 return;
4667             }
4668
4669             if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
4670 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4671                 debugBelch("Unexpected lazy BHing required at 0x%04lx\n",(long)bh);
4672 #endif
4673                 // zero out the slop so that the sanity checker can tell
4674                 // where the next closure is.
4675                 DEBUG_FILL_SLOP(bh);
4676 #ifdef PROFILING
4677                 // @LDV profiling
4678                 // We pretend that bh is now dead.
4679                 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4680 #endif
4681                 SET_INFO(bh,&stg_BLACKHOLE_info);
4682
4683                 // We pretend that bh has just been created.
4684                 LDV_RECORD_CREATE(bh);
4685             }
4686
4687             frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
4688             if (prev_was_update_frame) {
4689                 words_to_squeeze += sizeofW(StgUpdateFrame);
4690                 weight += weight_pending;
4691                 weight_pending = 0;
4692             }
4693             prev_was_update_frame = rtsTrue;
4694             break;
4695
4696         case STOP_FRAME:
4697             goto end;
4698
4699             // normal stack frames; do nothing except advance the pointer
4700         default:
4701         {
4702             nat frame_size = stack_frame_sizeW(frame);
4703             weight_pending += frame_size;
4704             frame = (StgClosure *)((StgPtr)frame + frame_size);
4705             prev_was_update_frame = rtsFalse;
4706         }
4707         }
4708     }
4709
4710 end:
4711     debugTrace(DEBUG_squeeze,
4712                "words_to_squeeze: %d, weight: %d, squeeze: %s",
4713                words_to_squeeze, weight,
4714                weight < words_to_squeeze ? "YES" : "NO");
4715
4716     // Should we squeeze or not?  Arbitrary heuristic: we squeeze if
4717     // the number of words we have to shift down is less than the
4718     // number of stack words we squeeze away by doing so.
4719     if (RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue &&
4720         weight < words_to_squeeze) {
4721         stackSqueeze(tso, (StgPtr)frame);
4722     }
4723 }
4724
4725 /* -----------------------------------------------------------------------------
4726  * Debugging
4727  * -------------------------------------------------------------------------- */
4728
4729 #if DEBUG
4730 void
4731 printMutableList(generation *gen)
4732 {
4733     bdescr *bd;
4734     StgPtr p;
4735
4736     debugBelch("mutable list %p: ", gen->mut_list);
4737
4738     for (bd = gen->mut_list; bd != NULL; bd = bd->link) {
4739         for (p = bd->start; p < bd->free; p++) {
4740             debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
4741         }
4742     }
4743     debugBelch("\n");
4744 }
4745 #endif /* DEBUG */