ghc/rts/GC.c

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