ghc/rts/GC.c

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