ghc/rts/GC.c

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