ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.151 2003/03/26 14:52:02 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 (HEAP_ALLOCED(selectee) &&
2020         Bdescr((StgPtr)selectee)->flags & BF_EVACUATED) {
2021         goto bale_out;
2022     }
2023
2024     info = get_itbl(selectee);
2025     switch (info->type) {
2026       case CONSTR:
2027       case CONSTR_1_0:
2028       case CONSTR_0_1:
2029       case CONSTR_2_0:
2030       case CONSTR_1_1:
2031       case CONSTR_0_2:
2032       case CONSTR_STATIC:
2033       case CONSTR_NOCAF_STATIC:
2034           // check that the size is in range
2035           ASSERT(field <  (StgWord32)(info->layout.payload.ptrs +
2036                                       info->layout.payload.nptrs));
2037
2038           // ToDo: shouldn't we test whether this pointer is in
2039           // to-space?
2040           return selectee->payload[field];
2041
2042       case IND:
2043       case IND_PERM:
2044       case IND_OLDGEN:
2045       case IND_OLDGEN_PERM:
2046       case IND_STATIC:
2047           selectee = ((StgInd *)selectee)->indirectee;
2048           goto selector_loop;
2049
2050       case EVACUATED:
2051           // We don't follow pointers into to-space; the constructor
2052           // has already been evacuated, so we won't save any space
2053           // leaks by evaluating this selector thunk anyhow.
2054           break;
2055
2056       case THUNK_SELECTOR:
2057       {
2058           StgClosure *val;
2059
2060           // check that we don't recurse too much, re-using the
2061           // depth bound also used in evacuate().
2062           thunk_selector_depth++;
2063           if (thunk_selector_depth > MAX_THUNK_SELECTOR_DEPTH) {
2064               break;
2065           }
2066
2067           val = eval_thunk_selector(info->layout.selector_offset,
2068                                     (StgSelector *)selectee);
2069
2070           thunk_selector_depth--;
2071
2072           if (val == NULL) {
2073               break;
2074           } else {
2075               // We evaluated this selector thunk, so update it with
2076               // an indirection.  NOTE: we don't use UPD_IND here,
2077               // because we are guaranteed that p is in a generation
2078               // that we are collecting, and we never want to put the
2079               // indirection on a mutable list.
2080 #ifdef PROFILING
2081               // For the purposes of LDV profiling, we have destroyed
2082               // the original selector thunk.
2083               SET_INFO(p, info_ptr);
2084               LDV_recordDead_FILL_SLOP_DYNAMIC(selectee);
2085 #endif
2086               ((StgInd *)selectee)->indirectee = val;
2087               SET_INFO(selectee,&stg_IND_info);
2088 #ifdef PROFILING
2089               // For the purposes of LDV profiling, we have created an
2090               // indirection.
2091               LDV_recordCreate(selectee);
2092 #endif
2093               selectee = val;
2094               goto selector_loop;
2095           }
2096       }
2097
2098       case AP:
2099       case THUNK:
2100       case THUNK_1_0:
2101       case THUNK_0_1:
2102       case THUNK_2_0:
2103       case THUNK_1_1:
2104       case THUNK_0_2:
2105       case THUNK_STATIC:
2106       case CAF_BLACKHOLE:
2107       case SE_CAF_BLACKHOLE:
2108       case SE_BLACKHOLE:
2109       case BLACKHOLE:
2110       case BLACKHOLE_BQ:
2111 #if defined(PAR)
2112       case RBH:
2113       case BLOCKED_FETCH:
2114 # ifdef DIST
2115       case REMOTE_REF:
2116 # endif
2117       case FETCH_ME:
2118       case FETCH_ME_BQ:
2119 #endif
2120           // not evaluated yet
2121           break;
2122
2123       default:
2124         barf("eval_thunk_selector: strange selectee %d",
2125              (int)(info->type));
2126     }
2127
2128 bale_out:
2129     // We didn't manage to evaluate this thunk; restore the old info pointer
2130     SET_INFO(p, info_ptr);
2131     return NULL;
2132 }
2133
2134 /* -----------------------------------------------------------------------------
2135    move_TSO is called to update the TSO structure after it has been
2136    moved from one place to another.
2137    -------------------------------------------------------------------------- */
2138
2139 void
2140 move_TSO (StgTSO *src, StgTSO *dest)
2141 {
2142     ptrdiff_t diff;
2143
2144     // relocate the stack pointers...
2145     diff = (StgPtr)dest - (StgPtr)src; // In *words*
2146     dest->sp = (StgPtr)dest->sp + diff;
2147 }
2148
2149 /* evacuate the SRT.  If srt_len is zero, then there isn't an
2150  * srt field in the info table.  That's ok, because we'll
2151  * never dereference it.
2152  */
2153 static inline void
2154 scavenge_srt (StgClosure **srt, nat srt_len)
2155 {
2156   StgClosure **srt_end;
2157
2158   srt_end = srt + srt_len;
2159
2160   for (; srt < srt_end; srt++) {
2161     /* Special-case to handle references to closures hiding out in DLLs, since
2162        double indirections required to get at those. The code generator knows
2163        which is which when generating the SRT, so it stores the (indirect)
2164        reference to the DLL closure in the table by first adding one to it.
2165        We check for this here, and undo the addition before evacuating it.
2166
2167        If the SRT entry hasn't got bit 0 set, the SRT entry points to a
2168        closure that's fixed at link-time, and no extra magic is required.
2169     */
2170 #ifdef ENABLE_WIN32_DLL_SUPPORT
2171     if ( (unsigned long)(*srt) & 0x1 ) {
2172        evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
2173     } else {
2174        evacuate(*srt);
2175     }
2176 #else
2177        evacuate(*srt);
2178 #endif
2179   }
2180 }
2181
2182
2183 static inline void
2184 scavenge_thunk_srt(const StgInfoTable *info)
2185 {
2186     StgThunkInfoTable *thunk_info;
2187
2188     thunk_info = itbl_to_thunk_itbl(info);
2189     scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_len);
2190 }
2191
2192 static inline void
2193 scavenge_fun_srt(const StgInfoTable *info)
2194 {
2195     StgFunInfoTable *fun_info;
2196
2197     fun_info = itbl_to_fun_itbl(info);
2198     scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_len);
2199 }
2200
2201 static inline void
2202 scavenge_ret_srt(const StgInfoTable *info)
2203 {
2204     StgRetInfoTable *ret_info;
2205
2206     ret_info = itbl_to_ret_itbl(info);
2207     scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_len);
2208 }
2209
2210 /* -----------------------------------------------------------------------------
2211    Scavenge a TSO.
2212    -------------------------------------------------------------------------- */
2213
2214 static void
2215 scavengeTSO (StgTSO *tso)
2216 {
2217     // chase the link field for any TSOs on the same queue
2218     (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2219     if (   tso->why_blocked == BlockedOnMVar
2220         || tso->why_blocked == BlockedOnBlackHole
2221         || tso->why_blocked == BlockedOnException
2222 #if defined(PAR)
2223         || tso->why_blocked == BlockedOnGA
2224         || tso->why_blocked == BlockedOnGA_NoSend
2225 #endif
2226         ) {
2227         tso->block_info.closure = evacuate(tso->block_info.closure);
2228     }
2229     if ( tso->blocked_exceptions != NULL ) {
2230         tso->blocked_exceptions =
2231             (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
2232     }
2233
2234     // scavenge this thread's stack
2235     scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2236 }
2237
2238 /* -----------------------------------------------------------------------------
2239    Blocks of function args occur on the stack (at the top) and
2240    in PAPs.
2241    -------------------------------------------------------------------------- */
2242
2243 static inline StgPtr
2244 scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
2245 {
2246     StgPtr p;
2247     StgWord bitmap;
2248     nat size;
2249
2250     p = (StgPtr)args;
2251     switch (fun_info->fun_type) {
2252     case ARG_GEN:
2253         bitmap = BITMAP_BITS(fun_info->bitmap);
2254         size = BITMAP_SIZE(fun_info->bitmap);
2255         goto small_bitmap;
2256     case ARG_GEN_BIG:
2257         size = ((StgLargeBitmap *)fun_info->bitmap)->size;
2258         scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
2259         p += size;
2260         break;
2261     default:
2262         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
2263         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
2264     small_bitmap:
2265         while (size > 0) {
2266             if ((bitmap & 1) == 0) {
2267                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2268             }
2269             p++;
2270             bitmap = bitmap >> 1;
2271             size--;
2272         }
2273         break;
2274     }
2275     return p;
2276 }
2277
2278 static inline StgPtr
2279 scavenge_PAP (StgPAP *pap)
2280 {
2281     StgPtr p;
2282     StgWord bitmap, size;
2283     StgFunInfoTable *fun_info;
2284
2285     pap->fun = evacuate(pap->fun);
2286     fun_info = get_fun_itbl(pap->fun);
2287     ASSERT(fun_info->i.type != PAP);
2288
2289     p = (StgPtr)pap->payload;
2290     size = pap->n_args;
2291
2292     switch (fun_info->fun_type) {
2293     case ARG_GEN:
2294         bitmap = BITMAP_BITS(fun_info->bitmap);
2295         goto small_bitmap;
2296     case ARG_GEN_BIG:
2297         scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
2298         p += size;
2299         break;
2300     case ARG_BCO:
2301         scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
2302         p += size;
2303         break;
2304     default:
2305         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
2306     small_bitmap:
2307         size = pap->n_args;
2308         while (size > 0) {
2309             if ((bitmap & 1) == 0) {
2310                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2311             }
2312             p++;
2313             bitmap = bitmap >> 1;
2314             size--;
2315         }
2316         break;
2317     }
2318     return p;
2319 }
2320
2321 /* -----------------------------------------------------------------------------
2322    Scavenge a given step until there are no more objects in this step
2323    to scavenge.
2324
2325    evac_gen is set by the caller to be either zero (for a step in a
2326    generation < N) or G where G is the generation of the step being
2327    scavenged.
2328
2329    We sometimes temporarily change evac_gen back to zero if we're
2330    scavenging a mutable object where early promotion isn't such a good
2331    idea.
2332    -------------------------------------------------------------------------- */
2333
2334 static void
2335 scavenge(step *stp)
2336 {
2337   StgPtr p, q;
2338   StgInfoTable *info;
2339   bdescr *bd;
2340   nat saved_evac_gen = evac_gen;
2341
2342   p = stp->scan;
2343   bd = stp->scan_bd;
2344
2345   failed_to_evac = rtsFalse;
2346
2347   /* scavenge phase - standard breadth-first scavenging of the
2348    * evacuated objects
2349    */
2350
2351   while (bd != stp->hp_bd || p < stp->hp) {
2352
2353     // If we're at the end of this block, move on to the next block
2354     if (bd != stp->hp_bd && p == bd->free) {
2355       bd = bd->link;
2356       p = bd->start;
2357       continue;
2358     }
2359
2360     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2361     info = get_itbl((StgClosure *)p);
2362
2363     ASSERT(thunk_selector_depth == 0);
2364
2365     q = p;
2366     switch (info->type) {
2367
2368     case MVAR:
2369         /* treat MVars specially, because we don't want to evacuate the
2370          * mut_link field in the middle of the closure.
2371          */
2372     {
2373         StgMVar *mvar = ((StgMVar *)p);
2374         evac_gen = 0;
2375         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2376         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2377         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2378         evac_gen = saved_evac_gen;
2379         recordMutable((StgMutClosure *)mvar);
2380         failed_to_evac = rtsFalse; // mutable.
2381         p += sizeofW(StgMVar);
2382         break;
2383     }
2384
2385     case FUN_2_0:
2386         scavenge_fun_srt(info);
2387         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2388         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2389         p += sizeofW(StgHeader) + 2;
2390         break;
2391
2392     case THUNK_2_0:
2393         scavenge_thunk_srt(info);
2394     case CONSTR_2_0:
2395         ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2396         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2397         p += sizeofW(StgHeader) + 2;
2398         break;
2399
2400     case THUNK_1_0:
2401         scavenge_thunk_srt(info);
2402         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2403         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2404         break;
2405
2406     case FUN_1_0:
2407         scavenge_fun_srt(info);
2408     case CONSTR_1_0:
2409         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2410         p += sizeofW(StgHeader) + 1;
2411         break;
2412
2413     case THUNK_0_1:
2414         scavenge_thunk_srt(info);
2415         p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
2416         break;
2417
2418     case FUN_0_1:
2419         scavenge_fun_srt(info);
2420     case CONSTR_0_1:
2421         p += sizeofW(StgHeader) + 1;
2422         break;
2423
2424     case THUNK_0_2:
2425         scavenge_thunk_srt(info);
2426         p += sizeofW(StgHeader) + 2;
2427         break;
2428
2429     case FUN_0_2:
2430         scavenge_fun_srt(info);
2431     case CONSTR_0_2:
2432         p += sizeofW(StgHeader) + 2;
2433         break;
2434
2435     case THUNK_1_1:
2436         scavenge_thunk_srt(info);
2437         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2438         p += sizeofW(StgHeader) + 2;
2439         break;
2440
2441     case FUN_1_1:
2442         scavenge_fun_srt(info);
2443     case CONSTR_1_1:
2444         ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2445         p += sizeofW(StgHeader) + 2;
2446         break;
2447
2448     case FUN:
2449         scavenge_fun_srt(info);
2450         goto gen_obj;
2451
2452     case THUNK:
2453         scavenge_thunk_srt(info);
2454         // fall through
2455
2456     gen_obj:
2457     case CONSTR:
2458     case WEAK:
2459     case FOREIGN:
2460     case STABLE_NAME:
2461     {
2462         StgPtr end;
2463
2464         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2465         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2466             (StgClosure *)*p = evacuate((StgClosure *)*p);
2467         }
2468         p += info->layout.payload.nptrs;
2469         break;
2470     }
2471
2472     case BCO: {
2473         StgBCO *bco = (StgBCO *)p;
2474         (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2475         (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2476         (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2477         (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2478         p += bco_sizeW(bco);
2479         break;
2480     }
2481
2482     case IND_PERM:
2483       if (stp->gen->no != 0) {
2484 #ifdef PROFILING
2485         // @LDV profiling
2486         // No need to call LDV_recordDead_FILL_SLOP_DYNAMIC() because an
2487         // IND_OLDGEN_PERM closure is larger than an IND_PERM closure.
2488         LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
2489 #endif
2490         //
2491         // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
2492         //
2493         SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
2494 #ifdef PROFILING
2495         // @LDV profiling
2496         // We pretend that p has just been created.
2497         LDV_recordCreate((StgClosure *)p);
2498 #endif
2499       }
2500         // fall through
2501     case IND_OLDGEN_PERM:
2502         ((StgIndOldGen *)p)->indirectee =
2503             evacuate(((StgIndOldGen *)p)->indirectee);
2504         if (failed_to_evac) {
2505             failed_to_evac = rtsFalse;
2506             recordOldToNewPtrs((StgMutClosure *)p);
2507         }
2508         p += sizeofW(StgIndOldGen);
2509         break;
2510
2511     case MUT_VAR:
2512         evac_gen = 0;
2513         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2514         evac_gen = saved_evac_gen;
2515         recordMutable((StgMutClosure *)p);
2516         failed_to_evac = rtsFalse; // mutable anyhow
2517         p += sizeofW(StgMutVar);
2518         break;
2519
2520     case MUT_CONS:
2521         // ignore these
2522         failed_to_evac = rtsFalse; // mutable anyhow
2523         p += sizeofW(StgMutVar);
2524         break;
2525
2526     case CAF_BLACKHOLE:
2527     case SE_CAF_BLACKHOLE:
2528     case SE_BLACKHOLE:
2529     case BLACKHOLE:
2530         p += BLACKHOLE_sizeW();
2531         break;
2532
2533     case BLACKHOLE_BQ:
2534     {
2535         StgBlockingQueue *bh = (StgBlockingQueue *)p;
2536         (StgClosure *)bh->blocking_queue =
2537             evacuate((StgClosure *)bh->blocking_queue);
2538         recordMutable((StgMutClosure *)bh);
2539         failed_to_evac = rtsFalse;
2540         p += BLACKHOLE_sizeW();
2541         break;
2542     }
2543
2544     case THUNK_SELECTOR:
2545     {
2546         StgSelector *s = (StgSelector *)p;
2547         s->selectee = evacuate(s->selectee);
2548         p += THUNK_SELECTOR_sizeW();
2549         break;
2550     }
2551
2552     // A chunk of stack saved in a heap object
2553     case AP_STACK:
2554     {
2555         StgAP_STACK *ap = (StgAP_STACK *)p;
2556
2557         ap->fun = evacuate(ap->fun);
2558         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2559         p = (StgPtr)ap->payload + ap->size;
2560         break;
2561     }
2562
2563     case PAP:
2564     case AP:
2565         p = scavenge_PAP((StgPAP *)p);
2566         break;
2567
2568     case ARR_WORDS:
2569         // nothing to follow
2570         p += arr_words_sizeW((StgArrWords *)p);
2571         break;
2572
2573     case MUT_ARR_PTRS:
2574         // follow everything
2575     {
2576         StgPtr next;
2577
2578         evac_gen = 0;           // repeatedly mutable
2579         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2580         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2581             (StgClosure *)*p = evacuate((StgClosure *)*p);
2582         }
2583         evac_gen = saved_evac_gen;
2584         recordMutable((StgMutClosure *)q);
2585         failed_to_evac = rtsFalse; // mutable anyhow.
2586         break;
2587     }
2588
2589     case MUT_ARR_PTRS_FROZEN:
2590         // follow everything
2591     {
2592         StgPtr next;
2593
2594         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2595         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2596             (StgClosure *)*p = evacuate((StgClosure *)*p);
2597         }
2598         // it's tempting to recordMutable() if failed_to_evac is
2599         // false, but that breaks some assumptions (eg. every
2600         // closure on the mutable list is supposed to have the MUT
2601         // flag set, and MUT_ARR_PTRS_FROZEN doesn't).
2602         break;
2603     }
2604
2605     case TSO:
2606     {
2607         StgTSO *tso = (StgTSO *)p;
2608         evac_gen = 0;
2609         scavengeTSO(tso);
2610         evac_gen = saved_evac_gen;
2611         recordMutable((StgMutClosure *)tso);
2612         failed_to_evac = rtsFalse; // mutable anyhow.
2613         p += tso_sizeW(tso);
2614         break;
2615     }
2616
2617 #if defined(PAR)
2618     case RBH: // cf. BLACKHOLE_BQ
2619     {
2620 #if 0
2621         nat size, ptrs, nonptrs, vhs;
2622         char str[80];
2623         StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2624 #endif
2625         StgRBH *rbh = (StgRBH *)p;
2626         (StgClosure *)rbh->blocking_queue =
2627             evacuate((StgClosure *)rbh->blocking_queue);
2628         recordMutable((StgMutClosure *)to);
2629         failed_to_evac = rtsFalse;  // mutable anyhow.
2630         IF_DEBUG(gc,
2631                  belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2632                        p, info_type(p), (StgClosure *)rbh->blocking_queue));
2633         // ToDo: use size of reverted closure here!
2634         p += BLACKHOLE_sizeW();
2635         break;
2636     }
2637
2638     case BLOCKED_FETCH:
2639     {
2640         StgBlockedFetch *bf = (StgBlockedFetch *)p;
2641         // follow the pointer to the node which is being demanded
2642         (StgClosure *)bf->node =
2643             evacuate((StgClosure *)bf->node);
2644         // follow the link to the rest of the blocking queue
2645         (StgClosure *)bf->link =
2646             evacuate((StgClosure *)bf->link);
2647         if (failed_to_evac) {
2648             failed_to_evac = rtsFalse;
2649             recordMutable((StgMutClosure *)bf);
2650         }
2651         IF_DEBUG(gc,
2652                  belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2653                        bf, info_type((StgClosure *)bf),
2654                        bf->node, info_type(bf->node)));
2655         p += sizeofW(StgBlockedFetch);
2656         break;
2657     }
2658
2659 #ifdef DIST
2660     case REMOTE_REF:
2661 #endif
2662     case FETCH_ME:
2663         p += sizeofW(StgFetchMe);
2664         break; // nothing to do in this case
2665
2666     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2667     {
2668         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2669         (StgClosure *)fmbq->blocking_queue =
2670             evacuate((StgClosure *)fmbq->blocking_queue);
2671         if (failed_to_evac) {
2672             failed_to_evac = rtsFalse;
2673             recordMutable((StgMutClosure *)fmbq);
2674         }
2675         IF_DEBUG(gc,
2676                  belch("@@ scavenge: %p (%s) exciting, isn't it",
2677                        p, info_type((StgClosure *)p)));
2678         p += sizeofW(StgFetchMeBlockingQueue);
2679         break;
2680     }
2681 #endif
2682
2683     default:
2684         barf("scavenge: unimplemented/strange closure type %d @ %p",
2685              info->type, p);
2686     }
2687
2688     /* If we didn't manage to promote all the objects pointed to by
2689      * the current object, then we have to designate this object as
2690      * mutable (because it contains old-to-new generation pointers).
2691      */
2692     if (failed_to_evac) {
2693         failed_to_evac = rtsFalse;
2694         mkMutCons((StgClosure *)q, &generations[evac_gen]);
2695     }
2696   }
2697
2698   stp->scan_bd = bd;
2699   stp->scan = p;
2700 }
2701
2702 /* -----------------------------------------------------------------------------
2703    Scavenge everything on the mark stack.
2704
2705    This is slightly different from scavenge():
2706       - we don't walk linearly through the objects, so the scavenger
2707         doesn't need to advance the pointer on to the next object.
2708    -------------------------------------------------------------------------- */
2709
2710 static void
2711 scavenge_mark_stack(void)
2712 {
2713     StgPtr p, q;
2714     StgInfoTable *info;
2715     nat saved_evac_gen;
2716
2717     evac_gen = oldest_gen->no;
2718     saved_evac_gen = evac_gen;
2719
2720 linear_scan:
2721     while (!mark_stack_empty()) {
2722         p = pop_mark_stack();
2723
2724         ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
2725         info = get_itbl((StgClosure *)p);
2726
2727         q = p;
2728         switch (info->type) {
2729
2730         case MVAR:
2731             /* treat MVars specially, because we don't want to evacuate the
2732              * mut_link field in the middle of the closure.
2733              */
2734         {
2735             StgMVar *mvar = ((StgMVar *)p);
2736             evac_gen = 0;
2737             (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
2738             (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
2739             (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
2740             evac_gen = saved_evac_gen;
2741             failed_to_evac = rtsFalse; // mutable.
2742             break;
2743         }
2744
2745         case FUN_2_0:
2746             scavenge_fun_srt(info);
2747             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2748             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2749             break;
2750
2751         case THUNK_2_0:
2752             scavenge_thunk_srt(info);
2753         case CONSTR_2_0:
2754             ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
2755             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2756             break;
2757
2758         case FUN_1_0:
2759         case FUN_1_1:
2760             scavenge_fun_srt(info);
2761             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2762             break;
2763
2764         case THUNK_1_0:
2765         case THUNK_1_1:
2766             scavenge_thunk_srt(info);
2767         case CONSTR_1_0:
2768         case CONSTR_1_1:
2769             ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
2770             break;
2771
2772         case FUN_0_1:
2773         case FUN_0_2:
2774             scavenge_fun_srt(info);
2775             break;
2776
2777         case THUNK_0_1:
2778         case THUNK_0_2:
2779             scavenge_thunk_srt(info);
2780             break;
2781
2782         case CONSTR_0_1:
2783         case CONSTR_0_2:
2784             break;
2785
2786         case FUN:
2787             scavenge_fun_srt(info);
2788             goto gen_obj;
2789
2790         case THUNK:
2791             scavenge_thunk_srt(info);
2792             // fall through
2793
2794         gen_obj:
2795         case CONSTR:
2796         case WEAK:
2797         case FOREIGN:
2798         case STABLE_NAME:
2799         {
2800             StgPtr end;
2801
2802             end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
2803             for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
2804                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2805             }
2806             break;
2807         }
2808
2809         case BCO: {
2810             StgBCO *bco = (StgBCO *)p;
2811             (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
2812             (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
2813             (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
2814             (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
2815             break;
2816         }
2817
2818         case IND_PERM:
2819             // don't need to do anything here: the only possible case
2820             // is that we're in a 1-space compacting collector, with
2821             // no "old" generation.
2822             break;
2823
2824         case IND_OLDGEN:
2825         case IND_OLDGEN_PERM:
2826             ((StgIndOldGen *)p)->indirectee =
2827                 evacuate(((StgIndOldGen *)p)->indirectee);
2828             if (failed_to_evac) {
2829                 recordOldToNewPtrs((StgMutClosure *)p);
2830             }
2831             failed_to_evac = rtsFalse;
2832             break;
2833
2834         case MUT_VAR:
2835             evac_gen = 0;
2836             ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
2837             evac_gen = saved_evac_gen;
2838             failed_to_evac = rtsFalse;
2839             break;
2840
2841         case MUT_CONS:
2842             // ignore these
2843             failed_to_evac = rtsFalse;
2844             break;
2845
2846         case CAF_BLACKHOLE:
2847         case SE_CAF_BLACKHOLE:
2848         case SE_BLACKHOLE:
2849         case BLACKHOLE:
2850         case ARR_WORDS:
2851             break;
2852
2853         case BLACKHOLE_BQ:
2854         {
2855             StgBlockingQueue *bh = (StgBlockingQueue *)p;
2856             (StgClosure *)bh->blocking_queue =
2857                 evacuate((StgClosure *)bh->blocking_queue);
2858             failed_to_evac = rtsFalse;
2859             break;
2860         }
2861
2862         case THUNK_SELECTOR:
2863         {
2864             StgSelector *s = (StgSelector *)p;
2865             s->selectee = evacuate(s->selectee);
2866             break;
2867         }
2868
2869         // A chunk of stack saved in a heap object
2870         case AP_STACK:
2871         {
2872             StgAP_STACK *ap = (StgAP_STACK *)p;
2873
2874             ap->fun = evacuate(ap->fun);
2875             scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
2876             break;
2877         }
2878
2879         case PAP:
2880         case AP:
2881             scavenge_PAP((StgPAP *)p);
2882             break;
2883
2884         case MUT_ARR_PTRS:
2885             // follow everything
2886         {
2887             StgPtr next;
2888
2889             evac_gen = 0;               // repeatedly mutable
2890             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2891             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2892                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2893             }
2894             evac_gen = saved_evac_gen;
2895             failed_to_evac = rtsFalse; // mutable anyhow.
2896             break;
2897         }
2898
2899         case MUT_ARR_PTRS_FROZEN:
2900             // follow everything
2901         {
2902             StgPtr next;
2903
2904             next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2905             for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2906                 (StgClosure *)*p = evacuate((StgClosure *)*p);
2907             }
2908             break;
2909         }
2910
2911         case TSO:
2912         {
2913             StgTSO *tso = (StgTSO *)p;
2914             evac_gen = 0;
2915             scavengeTSO(tso);
2916             evac_gen = saved_evac_gen;
2917             failed_to_evac = rtsFalse;
2918             break;
2919         }
2920
2921 #if defined(PAR)
2922         case RBH: // cf. BLACKHOLE_BQ
2923         {
2924 #if 0
2925             nat size, ptrs, nonptrs, vhs;
2926             char str[80];
2927             StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
2928 #endif
2929             StgRBH *rbh = (StgRBH *)p;
2930             (StgClosure *)rbh->blocking_queue =
2931                 evacuate((StgClosure *)rbh->blocking_queue);
2932             recordMutable((StgMutClosure *)rbh);
2933             failed_to_evac = rtsFalse;  // mutable anyhow.
2934             IF_DEBUG(gc,
2935                      belch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)",
2936                            p, info_type(p), (StgClosure *)rbh->blocking_queue));
2937             break;
2938         }
2939
2940         case BLOCKED_FETCH:
2941         {
2942             StgBlockedFetch *bf = (StgBlockedFetch *)p;
2943             // follow the pointer to the node which is being demanded
2944             (StgClosure *)bf->node =
2945                 evacuate((StgClosure *)bf->node);
2946             // follow the link to the rest of the blocking queue
2947             (StgClosure *)bf->link =
2948                 evacuate((StgClosure *)bf->link);
2949             if (failed_to_evac) {
2950                 failed_to_evac = rtsFalse;
2951                 recordMutable((StgMutClosure *)bf);
2952             }
2953             IF_DEBUG(gc,
2954                      belch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it",
2955                            bf, info_type((StgClosure *)bf),
2956                            bf->node, info_type(bf->node)));
2957             break;
2958         }
2959
2960 #ifdef DIST
2961         case REMOTE_REF:
2962 #endif
2963         case FETCH_ME:
2964             break; // nothing to do in this case
2965
2966         case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
2967         {
2968             StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
2969             (StgClosure *)fmbq->blocking_queue =
2970                 evacuate((StgClosure *)fmbq->blocking_queue);
2971             if (failed_to_evac) {
2972                 failed_to_evac = rtsFalse;
2973                 recordMutable((StgMutClosure *)fmbq);
2974             }
2975             IF_DEBUG(gc,
2976                      belch("@@ scavenge: %p (%s) exciting, isn't it",
2977                            p, info_type((StgClosure *)p)));
2978             break;
2979         }
2980 #endif // PAR
2981
2982         default:
2983             barf("scavenge_mark_stack: unimplemented/strange closure type %d @ %p",
2984                  info->type, p);
2985         }
2986
2987         if (failed_to_evac) {
2988             failed_to_evac = rtsFalse;
2989             mkMutCons((StgClosure *)q, &generations[evac_gen]);
2990         }
2991
2992         // mark the next bit to indicate "scavenged"
2993         mark(q+1, Bdescr(q));
2994
2995     } // while (!mark_stack_empty())
2996
2997     // start a new linear scan if the mark stack overflowed at some point
2998     if (mark_stack_overflowed && oldgen_scan_bd == NULL) {
2999         IF_DEBUG(gc, belch("scavenge_mark_stack: starting linear scan"));
3000         mark_stack_overflowed = rtsFalse;
3001         oldgen_scan_bd = oldest_gen->steps[0].blocks;
3002         oldgen_scan = oldgen_scan_bd->start;
3003     }
3004
3005     if (oldgen_scan_bd) {
3006         // push a new thing on the mark stack
3007     loop:
3008         // find a closure that is marked but not scavenged, and start
3009         // from there.
3010         while (oldgen_scan < oldgen_scan_bd->free
3011                && !is_marked(oldgen_scan,oldgen_scan_bd)) {
3012             oldgen_scan++;
3013         }
3014
3015         if (oldgen_scan < oldgen_scan_bd->free) {
3016
3017             // already scavenged?
3018             if (is_marked(oldgen_scan+1,oldgen_scan_bd)) {
3019                 oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3020                 goto loop;
3021             }
3022             push_mark_stack(oldgen_scan);
3023             // ToDo: bump the linear scan by the actual size of the object
3024             oldgen_scan += sizeofW(StgHeader) + MIN_NONUPD_SIZE;
3025             goto linear_scan;
3026         }
3027
3028         oldgen_scan_bd = oldgen_scan_bd->link;
3029         if (oldgen_scan_bd != NULL) {
3030             oldgen_scan = oldgen_scan_bd->start;
3031             goto loop;
3032         }
3033     }
3034 }
3035
3036 /* -----------------------------------------------------------------------------
3037    Scavenge one object.
3038
3039    This is used for objects that are temporarily marked as mutable
3040    because they contain old-to-new generation pointers.  Only certain
3041    objects can have this property.
3042    -------------------------------------------------------------------------- */
3043
3044 static rtsBool
3045 scavenge_one(StgPtr p)
3046 {
3047     const StgInfoTable *info;
3048     nat saved_evac_gen = evac_gen;
3049     rtsBool no_luck;
3050
3051     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3052     info = get_itbl((StgClosure *)p);
3053
3054     switch (info->type) {
3055
3056     case FUN:
3057     case FUN_1_0:                       // hardly worth specialising these guys
3058     case FUN_0_1:
3059     case FUN_1_1:
3060     case FUN_0_2:
3061     case FUN_2_0:
3062     case THUNK:
3063     case THUNK_1_0:
3064     case THUNK_0_1:
3065     case THUNK_1_1:
3066     case THUNK_0_2:
3067     case THUNK_2_0:
3068     case CONSTR:
3069     case CONSTR_1_0:
3070     case CONSTR_0_1:
3071     case CONSTR_1_1:
3072     case CONSTR_0_2:
3073     case CONSTR_2_0:
3074     case WEAK:
3075     case FOREIGN:
3076     case IND_PERM:
3077     case IND_OLDGEN_PERM:
3078     {
3079         StgPtr q, end;
3080
3081         end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
3082         for (q = (StgPtr)((StgClosure *)p)->payload; q < end; q++) {
3083             (StgClosure *)*q = evacuate((StgClosure *)*q);
3084         }
3085         break;
3086     }
3087
3088     case CAF_BLACKHOLE:
3089     case SE_CAF_BLACKHOLE:
3090     case SE_BLACKHOLE:
3091     case BLACKHOLE:
3092         break;
3093
3094     case THUNK_SELECTOR:
3095     {
3096         StgSelector *s = (StgSelector *)p;
3097         s->selectee = evacuate(s->selectee);
3098         break;
3099     }
3100
3101     case ARR_WORDS:
3102         // nothing to follow
3103         break;
3104
3105     case MUT_ARR_PTRS:
3106     {
3107         // follow everything
3108         StgPtr next;
3109
3110         evac_gen = 0;           // repeatedly mutable
3111         recordMutable((StgMutClosure *)p);
3112         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3113         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3114             (StgClosure *)*p = evacuate((StgClosure *)*p);
3115         }
3116         evac_gen = saved_evac_gen;
3117         failed_to_evac = rtsFalse;
3118         break;
3119     }
3120
3121     case MUT_ARR_PTRS_FROZEN:
3122     {
3123         // follow everything
3124         StgPtr next;
3125
3126         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3127         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
3128             (StgClosure *)*p = evacuate((StgClosure *)*p);
3129         }
3130         break;
3131     }
3132
3133     case TSO:
3134     {
3135         StgTSO *tso = (StgTSO *)p;
3136
3137         evac_gen = 0;           // repeatedly mutable
3138         scavengeTSO(tso);
3139         recordMutable((StgMutClosure *)tso);
3140         evac_gen = saved_evac_gen;
3141         failed_to_evac = rtsFalse;
3142         break;
3143     }
3144
3145     case AP_STACK:
3146     {
3147         StgAP_STACK *ap = (StgAP_STACK *)p;
3148
3149         ap->fun = evacuate(ap->fun);
3150         scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
3151         p = (StgPtr)ap->payload + ap->size;
3152         break;
3153     }
3154
3155     case PAP:
3156     case AP:
3157         p = scavenge_PAP((StgPAP *)p);
3158         break;
3159
3160     case IND_OLDGEN:
3161         // This might happen if for instance a MUT_CONS was pointing to a
3162         // THUNK which has since been updated.  The IND_OLDGEN will
3163         // be on the mutable list anyway, so we don't need to do anything
3164         // here.
3165         break;
3166
3167     default:
3168         barf("scavenge_one: strange object %d", (int)(info->type));
3169     }
3170
3171     no_luck = failed_to_evac;
3172     failed_to_evac = rtsFalse;
3173     return (no_luck);
3174 }
3175
3176 /* -----------------------------------------------------------------------------
3177    Scavenging mutable lists.
3178
3179    We treat the mutable list of each generation > N (i.e. all the
3180    generations older than the one being collected) as roots.  We also
3181    remove non-mutable objects from the mutable list at this point.
3182    -------------------------------------------------------------------------- */
3183
3184 static void
3185 scavenge_mut_once_list(generation *gen)
3186 {
3187   const StgInfoTable *info;
3188   StgMutClosure *p, *next, *new_list;
3189
3190   p = gen->mut_once_list;
3191   new_list = END_MUT_LIST;
3192   next = p->mut_link;
3193
3194   evac_gen = gen->no;
3195   failed_to_evac = rtsFalse;
3196
3197   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3198
3199     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3200     info = get_itbl(p);
3201     /*
3202     if (info->type==RBH)
3203       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3204     */
3205     switch(info->type) {
3206
3207     case IND_OLDGEN:
3208     case IND_OLDGEN_PERM:
3209     case IND_STATIC:
3210       /* Try to pull the indirectee into this generation, so we can
3211        * remove the indirection from the mutable list.
3212        */
3213       ((StgIndOldGen *)p)->indirectee =
3214         evacuate(((StgIndOldGen *)p)->indirectee);
3215
3216 #if 0 && defined(DEBUG)
3217       if (RtsFlags.DebugFlags.gc)
3218       /* Debugging code to print out the size of the thing we just
3219        * promoted
3220        */
3221       {
3222         StgPtr start = gen->steps[0].scan;
3223         bdescr *start_bd = gen->steps[0].scan_bd;
3224         nat size = 0;
3225         scavenge(&gen->steps[0]);
3226         if (start_bd != gen->steps[0].scan_bd) {
3227           size += (P_)BLOCK_ROUND_UP(start) - start;
3228           start_bd = start_bd->link;
3229           while (start_bd != gen->steps[0].scan_bd) {
3230             size += BLOCK_SIZE_W;
3231             start_bd = start_bd->link;
3232           }
3233           size += gen->steps[0].scan -
3234             (P_)BLOCK_ROUND_DOWN(gen->steps[0].scan);
3235         } else {
3236           size = gen->steps[0].scan - start;
3237         }
3238         belch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
3239       }
3240 #endif
3241
3242       /* failed_to_evac might happen if we've got more than two
3243        * generations, we're collecting only generation 0, the
3244        * indirection resides in generation 2 and the indirectee is
3245        * in generation 1.
3246        */
3247       if (failed_to_evac) {
3248         failed_to_evac = rtsFalse;
3249         p->mut_link = new_list;
3250         new_list = p;
3251       } else {
3252         /* the mut_link field of an IND_STATIC is overloaded as the
3253          * static link field too (it just so happens that we don't need
3254          * both at the same time), so we need to NULL it out when
3255          * removing this object from the mutable list because the static
3256          * link fields are all assumed to be NULL before doing a major
3257          * collection.
3258          */
3259         p->mut_link = NULL;
3260       }
3261       continue;
3262
3263     case MUT_CONS:
3264         /* MUT_CONS is a kind of MUT_VAR, except it that we try to remove
3265          * it from the mutable list if possible by promoting whatever it
3266          * points to.
3267          */
3268         if (scavenge_one((StgPtr)((StgMutVar *)p)->var)) {
3269             /* didn't manage to promote everything, so put the
3270              * MUT_CONS back on the list.
3271              */
3272             p->mut_link = new_list;
3273             new_list = p;
3274         }
3275         continue;
3276
3277     default:
3278       // shouldn't have anything else on the mutables list
3279       barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
3280     }
3281   }
3282
3283   gen->mut_once_list = new_list;
3284 }
3285
3286
3287 static void
3288 scavenge_mutable_list(generation *gen)
3289 {
3290   const StgInfoTable *info;
3291   StgMutClosure *p, *next;
3292
3293   p = gen->saved_mut_list;
3294   next = p->mut_link;
3295
3296   evac_gen = 0;
3297   failed_to_evac = rtsFalse;
3298
3299   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
3300
3301     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3302     info = get_itbl(p);
3303     /*
3304     if (info->type==RBH)
3305       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3306     */
3307     switch(info->type) {
3308
3309     case MUT_ARR_PTRS:
3310       // follow everything
3311       p->mut_link = gen->mut_list;
3312       gen->mut_list = p;
3313       {
3314         StgPtr end, q;
3315
3316         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3317         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3318           (StgClosure *)*q = evacuate((StgClosure *)*q);
3319         }
3320         continue;
3321       }
3322
3323       // Happens if a MUT_ARR_PTRS in the old generation is frozen
3324     case MUT_ARR_PTRS_FROZEN:
3325       {
3326         StgPtr end, q;
3327
3328         evac_gen = gen->no;
3329         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
3330         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
3331           (StgClosure *)*q = evacuate((StgClosure *)*q);
3332         }
3333         evac_gen = 0;
3334         p->mut_link = NULL;
3335         if (failed_to_evac) {
3336             failed_to_evac = rtsFalse;
3337             mkMutCons((StgClosure *)p, gen);
3338         }
3339         continue;
3340       }
3341
3342     case MUT_VAR:
3343         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
3344         p->mut_link = gen->mut_list;
3345         gen->mut_list = p;
3346         continue;
3347
3348     case MVAR:
3349       {
3350         StgMVar *mvar = (StgMVar *)p;
3351         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
3352         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
3353         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
3354         p->mut_link = gen->mut_list;
3355         gen->mut_list = p;
3356         continue;
3357       }
3358
3359     case TSO:
3360       {
3361         StgTSO *tso = (StgTSO *)p;
3362
3363         scavengeTSO(tso);
3364
3365         /* Don't take this TSO off the mutable list - it might still
3366          * point to some younger objects (because we set evac_gen to 0
3367          * above).
3368          */
3369         tso->mut_link = gen->mut_list;
3370         gen->mut_list = (StgMutClosure *)tso;
3371         continue;
3372       }
3373
3374     case BLACKHOLE_BQ:
3375       {
3376         StgBlockingQueue *bh = (StgBlockingQueue *)p;
3377         (StgClosure *)bh->blocking_queue =
3378           evacuate((StgClosure *)bh->blocking_queue);
3379         p->mut_link = gen->mut_list;
3380         gen->mut_list = p;
3381         continue;
3382       }
3383
3384       /* Happens if a BLACKHOLE_BQ in the old generation is updated:
3385        */
3386     case IND_OLDGEN:
3387     case IND_OLDGEN_PERM:
3388       /* Try to pull the indirectee into this generation, so we can
3389        * remove the indirection from the mutable list.
3390        */
3391       evac_gen = gen->no;
3392       ((StgIndOldGen *)p)->indirectee =
3393         evacuate(((StgIndOldGen *)p)->indirectee);
3394       evac_gen = 0;
3395
3396       if (failed_to_evac) {
3397         failed_to_evac = rtsFalse;
3398         p->mut_link = gen->mut_once_list;
3399         gen->mut_once_list = p;
3400       } else {
3401         p->mut_link = NULL;
3402       }
3403       continue;
3404
3405 #if defined(PAR)
3406     // HWL: check whether all of these are necessary
3407
3408     case RBH: // cf. BLACKHOLE_BQ
3409       {
3410         // nat size, ptrs, nonptrs, vhs;
3411         // char str[80];
3412         // StgInfoTable *rip = get_closure_info(p, &size, &ptrs, &nonptrs, &vhs, str);
3413         StgRBH *rbh = (StgRBH *)p;
3414         (StgClosure *)rbh->blocking_queue =
3415           evacuate((StgClosure *)rbh->blocking_queue);
3416         if (failed_to_evac) {
3417           failed_to_evac = rtsFalse;
3418           recordMutable((StgMutClosure *)rbh);
3419         }
3420         // ToDo: use size of reverted closure here!
3421         p += BLACKHOLE_sizeW();
3422         break;
3423       }
3424
3425     case BLOCKED_FETCH:
3426       {
3427         StgBlockedFetch *bf = (StgBlockedFetch *)p;
3428         // follow the pointer to the node which is being demanded
3429         (StgClosure *)bf->node =
3430           evacuate((StgClosure *)bf->node);
3431         // follow the link to the rest of the blocking queue
3432         (StgClosure *)bf->link =
3433           evacuate((StgClosure *)bf->link);
3434         if (failed_to_evac) {
3435           failed_to_evac = rtsFalse;
3436           recordMutable((StgMutClosure *)bf);
3437         }
3438         p += sizeofW(StgBlockedFetch);
3439         break;
3440       }
3441
3442 #ifdef DIST
3443     case REMOTE_REF:
3444       barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
3445 #endif
3446     case FETCH_ME:
3447       p += sizeofW(StgFetchMe);
3448       break; // nothing to do in this case
3449
3450     case FETCH_ME_BQ: // cf. BLACKHOLE_BQ
3451       {
3452         StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p;
3453         (StgClosure *)fmbq->blocking_queue =
3454           evacuate((StgClosure *)fmbq->blocking_queue);
3455         if (failed_to_evac) {
3456           failed_to_evac = rtsFalse;
3457           recordMutable((StgMutClosure *)fmbq);
3458         }
3459         p += sizeofW(StgFetchMeBlockingQueue);
3460         break;
3461       }
3462 #endif
3463
3464     default:
3465       // shouldn't have anything else on the mutables list
3466       barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
3467     }
3468   }
3469 }
3470
3471
3472 static void
3473 scavenge_static(void)
3474 {
3475   StgClosure* p = static_objects;
3476   const StgInfoTable *info;
3477
3478   /* Always evacuate straight to the oldest generation for static
3479    * objects */
3480   evac_gen = oldest_gen->no;
3481
3482   /* keep going until we've scavenged all the objects on the linked
3483      list... */
3484   while (p != END_OF_STATIC_LIST) {
3485
3486     ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
3487     info = get_itbl(p);
3488     /*
3489     if (info->type==RBH)
3490       info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
3491     */
3492     // make sure the info pointer is into text space
3493
3494     /* Take this object *off* the static_objects list,
3495      * and put it on the scavenged_static_objects list.
3496      */
3497     static_objects = STATIC_LINK(info,p);
3498     STATIC_LINK(info,p) = scavenged_static_objects;
3499     scavenged_static_objects = p;
3500
3501     switch (info -> type) {
3502
3503     case IND_STATIC:
3504       {
3505         StgInd *ind = (StgInd *)p;
3506         ind->indirectee = evacuate(ind->indirectee);
3507
3508         /* might fail to evacuate it, in which case we have to pop it
3509          * back on the mutable list (and take it off the
3510          * scavenged_static list because the static link and mut link
3511          * pointers are one and the same).
3512          */
3513         if (failed_to_evac) {
3514           failed_to_evac = rtsFalse;
3515           scavenged_static_objects = IND_STATIC_LINK(p);
3516           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_once_list;
3517           oldest_gen->mut_once_list = (StgMutClosure *)ind;
3518         }
3519         break;
3520       }
3521
3522     case THUNK_STATIC:
3523       scavenge_thunk_srt(info);
3524       break;
3525
3526     case FUN_STATIC:
3527       scavenge_fun_srt(info);
3528       break;
3529
3530     case CONSTR_STATIC:
3531       {
3532         StgPtr q, next;
3533
3534         next = (P_)p->payload + info->layout.payload.ptrs;
3535         // evacuate the pointers
3536         for (q = (P_)p->payload; q < next; q++) {
3537           (StgClosure *)*q = evacuate((StgClosure *)*q);
3538         }
3539         break;
3540       }
3541
3542     default:
3543       barf("scavenge_static: strange closure %d", (int)(info->type));
3544     }
3545
3546     ASSERT(failed_to_evac == rtsFalse);
3547
3548     /* get the next static object from the list.  Remember, there might
3549      * be more stuff on this list now that we've done some evacuating!
3550      * (static_objects is a global)
3551      */
3552     p = static_objects;
3553   }
3554 }
3555
3556 /* -----------------------------------------------------------------------------
3557    scavenge a chunk of memory described by a bitmap
3558    -------------------------------------------------------------------------- */
3559
3560 static void
3561 scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
3562 {
3563     nat i, b;
3564     StgWord bitmap;
3565
3566     b = 0;
3567     bitmap = large_bitmap->bitmap[b];
3568     for (i = 0; i < size; ) {
3569         if ((bitmap & 1) == 0) {
3570             (StgClosure *)*p = evacuate((StgClosure *)*p);
3571         }
3572         i++;
3573         p++;
3574         if (i % BITS_IN(W_) == 0) {
3575             b++;
3576             bitmap = large_bitmap->bitmap[b];
3577         } else {
3578             bitmap = bitmap >> 1;
3579         }
3580     }
3581 }
3582
3583 static inline StgPtr
3584 scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
3585 {
3586     while (size > 0) {
3587         if ((bitmap & 1) == 0) {
3588             (StgClosure *)*p = evacuate((StgClosure *)*p);
3589         }
3590         p++;
3591         bitmap = bitmap >> 1;
3592         size--;
3593     }
3594     return p;
3595 }
3596
3597 /* -----------------------------------------------------------------------------
3598    scavenge_stack walks over a section of stack and evacuates all the
3599    objects pointed to by it.  We can use the same code for walking
3600    AP_STACK_UPDs, since these are just sections of copied stack.
3601    -------------------------------------------------------------------------- */
3602
3603
3604 static void
3605 scavenge_stack(StgPtr p, StgPtr stack_end)
3606 {
3607   const StgRetInfoTable* info;
3608   StgWord bitmap;
3609   nat size;
3610
3611   //IF_DEBUG(sanity, belch("  scavenging stack between %p and %p", p, stack_end));
3612
3613   /*
3614    * Each time around this loop, we are looking at a chunk of stack
3615    * that starts with an activation record.
3616    */
3617
3618   while (p < stack_end) {
3619     info  = get_ret_itbl((StgClosure *)p);
3620
3621     switch (info->i.type) {
3622
3623     case UPDATE_FRAME:
3624         ((StgUpdateFrame *)p)->updatee
3625             = evacuate(((StgUpdateFrame *)p)->updatee);
3626         p += sizeofW(StgUpdateFrame);
3627         continue;
3628
3629       // small bitmap (< 32 entries, or 64 on a 64-bit machine)
3630     case STOP_FRAME:
3631     case CATCH_FRAME:
3632     case RET_SMALL:
3633     case RET_VEC_SMALL:
3634         bitmap = BITMAP_BITS(info->i.layout.bitmap);
3635         size   = BITMAP_SIZE(info->i.layout.bitmap);
3636         // NOTE: the payload starts immediately after the info-ptr, we
3637         // don't have an StgHeader in the same sense as a heap closure.
3638         p++;
3639         p = scavenge_small_bitmap(p, size, bitmap);
3640
3641     follow_srt:
3642         scavenge_srt((StgClosure **)info->srt, info->i.srt_len);
3643         continue;
3644
3645     case RET_BCO: {
3646         StgBCO *bco;
3647         nat size;
3648
3649         p++;
3650         (StgClosure *)*p = evacuate((StgClosure *)*p);
3651         bco = (StgBCO *)*p;
3652         p++;
3653         size = BCO_BITMAP_SIZE(bco);
3654         scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
3655         p += size;
3656         continue;
3657     }
3658
3659       // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
3660     case RET_BIG:
3661     case RET_VEC_BIG:
3662     {
3663         nat size;
3664
3665         size = info->i.layout.large_bitmap->size;
3666         p++;
3667         scavenge_large_bitmap(p, info->i.layout.large_bitmap, size);
3668         p += size;
3669         // and don't forget to follow the SRT
3670         goto follow_srt;
3671     }
3672
3673       // Dynamic bitmap: the mask is stored on the stack, and
3674       // there are a number of non-pointers followed by a number
3675       // of pointers above the bitmapped area.  (see StgMacros.h,
3676       // HEAP_CHK_GEN).
3677     case RET_DYN:
3678     {
3679         StgWord dyn;
3680         dyn = ((StgRetDyn *)p)->liveness;
3681
3682         // traverse the bitmap first
3683         bitmap = GET_LIVENESS(dyn);
3684         p      = (P_)&((StgRetDyn *)p)->payload[0];
3685         size   = RET_DYN_SIZE;
3686         p = scavenge_small_bitmap(p, size, bitmap);
3687
3688         // skip over the non-ptr words
3689         p += GET_NONPTRS(dyn);
3690
3691         // follow the ptr words
3692         for (size = GET_PTRS(dyn); size > 0; size--) {
3693             (StgClosure *)*p = evacuate((StgClosure *)*p);
3694             p++;
3695         }
3696         continue;
3697     }
3698
3699     case RET_FUN:
3700     {
3701         StgRetFun *ret_fun = (StgRetFun *)p;
3702         StgFunInfoTable *fun_info;
3703
3704         ret_fun->fun = evacuate(ret_fun->fun);
3705         fun_info = get_fun_itbl(ret_fun->fun);
3706         p = scavenge_arg_block(fun_info, ret_fun->payload);
3707         goto follow_srt;
3708     }
3709
3710     default:
3711         barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
3712     }
3713   }
3714 }
3715
3716 /*-----------------------------------------------------------------------------
3717   scavenge the large object list.
3718
3719   evac_gen set by caller; similar games played with evac_gen as with
3720   scavenge() - see comment at the top of scavenge().  Most large
3721   objects are (repeatedly) mutable, so most of the time evac_gen will
3722   be zero.
3723   --------------------------------------------------------------------------- */
3724
3725 static void
3726 scavenge_large(step *stp)
3727 {
3728   bdescr *bd;
3729   StgPtr p;
3730
3731   bd = stp->new_large_objects;
3732
3733   for (; bd != NULL; bd = stp->new_large_objects) {
3734
3735     /* take this object *off* the large objects list and put it on
3736      * the scavenged large objects list.  This is so that we can
3737      * treat new_large_objects as a stack and push new objects on
3738      * the front when evacuating.
3739      */
3740     stp->new_large_objects = bd->link;
3741     dbl_link_onto(bd, &stp->scavenged_large_objects);
3742
3743     // update the block count in this step.
3744     stp->n_scavenged_large_blocks += bd->blocks;
3745
3746     p = bd->start;
3747     if (scavenge_one(p)) {
3748         mkMutCons((StgClosure *)p, stp->gen);
3749     }
3750   }
3751 }
3752
3753 /* -----------------------------------------------------------------------------
3754    Initialising the static object & mutable lists
3755    -------------------------------------------------------------------------- */
3756
3757 static void
3758 zero_static_object_list(StgClosure* first_static)
3759 {
3760   StgClosure* p;
3761   StgClosure* link;
3762   const StgInfoTable *info;
3763
3764   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
3765     info = get_itbl(p);
3766     link = STATIC_LINK(info, p);
3767     STATIC_LINK(info,p) = NULL;
3768   }
3769 }
3770
3771 /* This function is only needed because we share the mutable link
3772  * field with the static link field in an IND_STATIC, so we have to
3773  * zero the mut_link field before doing a major GC, which needs the
3774  * static link field.
3775  *
3776  * It doesn't do any harm to zero all the mutable link fields on the
3777  * mutable list.
3778  */
3779
3780 static void
3781 zero_mutable_list( StgMutClosure *first )
3782 {
3783   StgMutClosure *next, *c;
3784
3785   for (c = first; c != END_MUT_LIST; c = next) {
3786     next = c->mut_link;
3787     c->mut_link = NULL;
3788   }
3789 }
3790
3791 /* -----------------------------------------------------------------------------
3792    Reverting CAFs
3793    -------------------------------------------------------------------------- */
3794
3795 void
3796 revertCAFs( void )
3797 {
3798     StgIndStatic *c;
3799
3800     for (c = (StgIndStatic *)caf_list; c != NULL;
3801          c = (StgIndStatic *)c->static_link)
3802     {
3803         c->header.info = c->saved_info;
3804         c->saved_info = NULL;
3805         // could, but not necessary: c->static_link = NULL;
3806     }
3807     caf_list = NULL;
3808 }
3809
3810 void
3811 markCAFs( evac_fn evac )
3812 {
3813     StgIndStatic *c;
3814
3815     for (c = (StgIndStatic *)caf_list; c != NULL;
3816          c = (StgIndStatic *)c->static_link)
3817     {
3818         evac(&c->indirectee);
3819     }
3820 }
3821
3822 /* -----------------------------------------------------------------------------
3823    Sanity code for CAF garbage collection.
3824
3825    With DEBUG turned on, we manage a CAF list in addition to the SRT
3826    mechanism.  After GC, we run down the CAF list and blackhole any
3827    CAFs which have been garbage collected.  This means we get an error
3828    whenever the program tries to enter a garbage collected CAF.
3829
3830    Any garbage collected CAFs are taken off the CAF list at the same
3831    time.
3832    -------------------------------------------------------------------------- */
3833
3834 #if 0 && defined(DEBUG)
3835
3836 static void
3837 gcCAFs(void)
3838 {
3839   StgClosure*  p;
3840   StgClosure** pp;
3841   const StgInfoTable *info;
3842   nat i;
3843
3844   i = 0;
3845   p = caf_list;
3846   pp = &caf_list;
3847
3848   while (p != NULL) {
3849
3850     info = get_itbl(p);
3851
3852     ASSERT(info->type == IND_STATIC);
3853
3854     if (STATIC_LINK(info,p) == NULL) {
3855       IF_DEBUG(gccafs, belch("CAF gc'd at 0x%04lx", (long)p));
3856       // black hole it
3857       SET_INFO(p,&stg_BLACKHOLE_info);
3858       p = STATIC_LINK2(info,p);
3859       *pp = p;
3860     }
3861     else {
3862       pp = &STATIC_LINK2(info,p);
3863       p = *pp;
3864       i++;
3865     }
3866
3867   }
3868
3869   //  belch("%d CAFs live", i);
3870 }
3871 #endif
3872
3873
3874 /* -----------------------------------------------------------------------------
3875    Lazy black holing.
3876
3877    Whenever a thread returns to the scheduler after possibly doing
3878    some work, we have to run down the stack and black-hole all the
3879    closures referred to by update frames.
3880    -------------------------------------------------------------------------- */
3881
3882 static void
3883 threadLazyBlackHole(StgTSO *tso)
3884 {
3885     StgClosure *frame;
3886     StgRetInfoTable *info;
3887     StgBlockingQueue *bh;
3888     StgPtr stack_end;
3889
3890     stack_end = &tso->stack[tso->stack_size];
3891
3892     frame = (StgClosure *)tso->sp;
3893
3894     while (1) {
3895         info = get_ret_itbl(frame);
3896
3897         switch (info->i.type) {
3898
3899         case UPDATE_FRAME:
3900             bh = (StgBlockingQueue *)((StgUpdateFrame *)frame)->updatee;
3901
3902             /* if the thunk is already blackholed, it means we've also
3903              * already blackholed the rest of the thunks on this stack,
3904              * so we can stop early.
3905              *
3906              * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
3907              * don't interfere with this optimisation.
3908              */
3909             if (bh->header.info == &stg_BLACKHOLE_info) {
3910                 return;
3911             }
3912
3913             if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
3914                 bh->header.info != &stg_CAF_BLACKHOLE_info) {
3915 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
3916                 belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
3917 #endif
3918 #ifdef PROFILING
3919                 // @LDV profiling
3920                 // We pretend that bh is now dead.
3921                 LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
3922 #endif
3923                 SET_INFO(bh,&stg_BLACKHOLE_info);
3924 #ifdef PROFILING
3925                 // @LDV profiling
3926                 // We pretend that bh has just been created.
3927                 LDV_recordCreate(bh);
3928 #endif
3929             }
3930
3931             frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
3932             break;
3933
3934         case STOP_FRAME:
3935             return;
3936
3937             // normal stack frames; do nothing except advance the pointer
3938         default:
3939             (StgPtr)frame += stack_frame_sizeW(frame);
3940         }
3941     }
3942 }
3943
3944
3945 /* -----------------------------------------------------------------------------
3946  * Stack squeezing
3947  *
3948  * Code largely pinched from old RTS, then hacked to bits.  We also do
3949  * lazy black holing here.
3950  *
3951  * -------------------------------------------------------------------------- */
3952
3953 struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
3954
3955 static void
3956 threadSqueezeStack(StgTSO *tso)
3957 {
3958     StgPtr frame;
3959     rtsBool prev_was_update_frame;
3960     StgClosure *updatee = NULL;
3961     StgPtr bottom;
3962     StgRetInfoTable *info;
3963     StgWord current_gap_size;
3964     struct stack_gap *gap;
3965
3966     // Stage 1:
3967     //    Traverse the stack upwards, replacing adjacent update frames
3968     //    with a single update frame and a "stack gap".  A stack gap
3969     //    contains two values: the size of the gap, and the distance
3970     //    to the next gap (or the stack top).
3971
3972     bottom = &(tso->stack[tso->stack_size]);
3973
3974     frame = tso->sp;
3975
3976     ASSERT(frame < bottom);
3977
3978     prev_was_update_frame = rtsFalse;
3979     current_gap_size = 0;
3980     gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
3981
3982     while (frame < bottom) {
3983
3984         info = get_ret_itbl((StgClosure *)frame);
3985         switch (info->i.type) {
3986
3987         case UPDATE_FRAME:
3988         {
3989             StgUpdateFrame *upd = (StgUpdateFrame *)frame;
3990
3991             if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
3992
3993                 // found a BLACKHOLE'd update frame; we've been here
3994                 // before, in a previous GC, so just break out.
3995
3996                 // Mark the end of the gap, if we're in one.
3997                 if (current_gap_size != 0) {
3998                     gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
3999                 }
4000
4001                 frame += sizeofW(StgUpdateFrame);
4002                 goto done_traversing;
4003             }
4004
4005             if (prev_was_update_frame) {
4006
4007                 TICK_UPD_SQUEEZED();
4008                 /* wasn't there something about update squeezing and ticky to be
4009                  * sorted out?  oh yes: we aren't counting each enter properly
4010                  * in this case.  See the log somewhere.  KSW 1999-04-21
4011                  *
4012                  * Check two things: that the two update frames don't point to
4013                  * the same object, and that the updatee_bypass isn't already an
4014                  * indirection.  Both of these cases only happen when we're in a
4015                  * block hole-style loop (and there are multiple update frames
4016                  * on the stack pointing to the same closure), but they can both
4017                  * screw us up if we don't check.
4018                  */
4019                 if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
4020                     // this wakes the threads up
4021                     UPD_IND_NOLOCK(upd->updatee, updatee);
4022                 }
4023
4024                 // now mark this update frame as a stack gap.  The gap
4025                 // marker resides in the bottom-most update frame of
4026                 // the series of adjacent frames, and covers all the
4027                 // frames in this series.
4028                 current_gap_size += sizeofW(StgUpdateFrame);
4029                 ((struct stack_gap *)frame)->gap_size = current_gap_size;
4030                 ((struct stack_gap *)frame)->next_gap = gap;
4031
4032                 frame += sizeofW(StgUpdateFrame);
4033                 continue;
4034             }
4035
4036             // single update frame, or the topmost update frame in a series
4037             else {
4038                 StgBlockingQueue *bh = (StgBlockingQueue *)upd->updatee;
4039
4040                 // Do lazy black-holing
4041                 if (bh->header.info != &stg_BLACKHOLE_info &&
4042                     bh->header.info != &stg_BLACKHOLE_BQ_info &&
4043                     bh->header.info != &stg_CAF_BLACKHOLE_info) {
4044 #if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
4045                     belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
4046 #endif
4047 #ifdef DEBUG
4048                     /* zero out the slop so that the sanity checker can tell
4049                      * where the next closure is.
4050                      */
4051                     {
4052                         StgInfoTable *bh_info = get_itbl(bh);
4053                         nat np = bh_info->layout.payload.ptrs,
4054                             nw = bh_info->layout.payload.nptrs, i;
4055                         /* don't zero out slop for a THUNK_SELECTOR,
4056                          * because its layout info is used for a
4057                          * different purpose, and it's exactly the
4058                          * same size as a BLACKHOLE in any case.
4059                          */
4060                         if (bh_info->type != THUNK_SELECTOR) {
4061                             for (i = np; i < np + nw; i++) {
4062                                 ((StgClosure *)bh)->payload[i] = 0;
4063                             }
4064                         }
4065                     }
4066 #endif
4067 #ifdef PROFILING
4068                     // We pretend that bh is now dead.
4069                     LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
4070 #endif
4071                     // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
4072                     SET_INFO(bh,&stg_BLACKHOLE_info);
4073 #ifdef PROFILING
4074                     // We pretend that bh has just been created.
4075                     LDV_recordCreate(bh);
4076 #endif
4077                 }
4078
4079                 prev_was_update_frame = rtsTrue;
4080                 updatee = upd->updatee;
4081                 frame += sizeofW(StgUpdateFrame);
4082                 continue;
4083             }
4084         }
4085
4086         default:
4087             prev_was_update_frame = rtsFalse;
4088
4089             // we're not in a gap... check whether this is the end of a gap
4090             // (an update frame can't be the end of a gap).
4091             if (current_gap_size != 0) {
4092                 gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
4093             }
4094             current_gap_size = 0;
4095
4096             frame += stack_frame_sizeW((StgClosure *)frame);
4097             continue;
4098         }
4099     }
4100
4101 done_traversing:
4102
4103     // Now we have a stack with gaps in it, and we have to walk down
4104     // shoving the stack up to fill in the gaps.  A diagram might
4105     // help:
4106     //
4107     //    +| ********* |
4108     //     | ********* | <- sp
4109     //     |           |
4110     //     |           | <- gap_start
4111     //     | ......... |                |
4112     //     | stack_gap | <- gap         | chunk_size
4113     //     | ......... |                |
4114     //     | ......... | <- gap_end     v
4115     //     | ********* |
4116     //     | ********* |
4117     //     | ********* |
4118     //    -| ********* |
4119     //
4120     // 'sp'  points the the current top-of-stack
4121     // 'gap' points to the stack_gap structure inside the gap
4122     // *****   indicates real stack data
4123     // .....   indicates gap
4124     // <empty> indicates unused
4125     //
4126     {
4127         void *sp;
4128         void *gap_start, *next_gap_start, *gap_end;
4129         nat chunk_size;
4130
4131         next_gap_start = (void *)gap + sizeof(StgUpdateFrame);
4132         sp = next_gap_start;
4133
4134         while ((StgPtr)gap > tso->sp) {
4135
4136             // we're working in *bytes* now...
4137             gap_start = next_gap_start;
4138             gap_end = gap_start - gap->gap_size * sizeof(W_);
4139
4140             gap = gap->next_gap;
4141             next_gap_start = (void *)gap + sizeof(StgUpdateFrame);
4142
4143             chunk_size = gap_end - next_gap_start;
4144             sp -= chunk_size;
4145             memmove(sp, next_gap_start, chunk_size);
4146         }
4147
4148         tso->sp = (StgPtr)sp;
4149     }
4150 }
4151
4152 /* -----------------------------------------------------------------------------
4153  * Pausing a thread
4154  *
4155  * We have to prepare for GC - this means doing lazy black holing
4156  * here.  We also take the opportunity to do stack squeezing if it's
4157  * turned on.
4158  * -------------------------------------------------------------------------- */
4159 void
4160 threadPaused(StgTSO *tso)
4161 {
4162   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
4163     threadSqueezeStack(tso);    // does black holing too
4164   else
4165     threadLazyBlackHole(tso);
4166 }
4167
4168 /* -----------------------------------------------------------------------------
4169  * Debugging
4170  * -------------------------------------------------------------------------- */
4171
4172 #if DEBUG
4173 void
4174 printMutOnceList(generation *gen)
4175 {
4176   StgMutClosure *p, *next;
4177
4178   p = gen->mut_once_list;
4179   next = p->mut_link;
4180
4181   fprintf(stderr, "@@ Mut once list %p: ", gen->mut_once_list);
4182   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4183     fprintf(stderr, "%p (%s), ",
4184             p, info_type((StgClosure *)p));
4185   }
4186   fputc('\n', stderr);
4187 }
4188
4189 void
4190 printMutableList(generation *gen)
4191 {
4192   StgMutClosure *p, *next;
4193
4194   p = gen->mut_list;
4195   next = p->mut_link;
4196
4197   fprintf(stderr, "@@ Mutable list %p: ", gen->mut_list);
4198   for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
4199     fprintf(stderr, "%p (%s), ",
4200             p, info_type((StgClosure *)p));
4201   }
4202   fputc('\n', stderr);
4203 }
4204
4205 static inline rtsBool
4206 maybeLarge(StgClosure *closure)
4207 {
4208   StgInfoTable *info = get_itbl(closure);
4209
4210   /* closure types that may be found on the new_large_objects list;
4211      see scavenge_large */
4212   return (info->type == MUT_ARR_PTRS ||
4213           info->type == MUT_ARR_PTRS_FROZEN ||
4214           info->type == TSO ||
4215           info->type == ARR_WORDS);
4216 }
4217
4218
4219 #endif // DEBUG