ghc/rts/GC.c

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