ghc/rts/GC.c

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