ghc/rts/GC.c

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