ghc/rts/GC.c

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