ghc/rts/GC.c

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