ghc/rts/GC.c

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