ghc/rts/GC.c

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