ghc/rts/GC.c

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