ghc/rts/GC.c

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