ghc/rts/GC.c

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