ghc/rts/GC.c

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