ghc/rts/GC.c

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