rts/GC.c

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