ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.8 1999/01/14 11:11:29 simonm Exp $
   3  *
   4  * Two-space garbage collector
   5  *
   6  * ---------------------------------------------------------------------------*/
   7
   8 #include "Rts.h"
   9 #include "RtsFlags.h"
  10 #include "RtsUtils.h"
  11 #include "Storage.h"
  12 #include "StoragePriv.h"
  13 #include "Stats.h"
  14 #include "Schedule.h"
  15 #include "SchedAPI.h" /* for ReverCAFs prototype */
  16 #include "Sanity.h"
  17 #include "GC.h"
  18 #include "BlockAlloc.h"
  19 #include "Main.h"
  20 #include "DebugProf.h"
  21 #include "SchedAPI.h"
  22 #include "Weak.h"
  23
  24 StgCAF* enteredCAFs;
  25
  26 /* STATIC OBJECT LIST.
  27  *
  28  * During GC:
  29  * We maintain a linked list of static objects that are still live.
  30  * The requirements for this list are:
  31  *
  32  *  - we need to scan the list while adding to it, in order to
  33  *    scavenge all the static objects (in the same way that
  34  *    breadth-first scavenging works for dynamic objects).
  35  *
  36  *  - we need to be able to tell whether an object is already on
  37  *    the list, to break loops.
  38  *
  39  * Each static object has a "static link field", which we use for
  40  * linking objects on to the list.  We use a stack-type list, consing
  41  * objects on the front as they are added (this means that the
  42  * scavenge phase is depth-first, not breadth-first, but that
  43  * shouldn't matter).
  44  *
  45  * A separate list is kept for objects that have been scavenged
  46  * already - this is so that we can zero all the marks afterwards.
  47  *
  48  * An object is on the list if its static link field is non-zero; this
  49  * means that we have to mark the end of the list with '1', not NULL.
  50  *
  51  * Extra notes for generational GC:
  52  *
  53  * Each generation has a static object list associated with it.  When
  54  * collecting generations up to N, we treat the static object lists
  55  * from generations > N as roots.
  56  *
  57  * We build up a static object list while collecting generations 0..N,
  58  * which is then appended to the static object list of generation N+1.
  59  */
  60 StgClosure* static_objects;           /* live static objects */
  61 StgClosure* scavenged_static_objects; /* static objects scavenged so far */
  62
  63 /* N is the oldest generation being collected, where the generations
  64  * are numbered starting at 0.  A major GC (indicated by the major_gc
  65  * flag) is when we're collecting all generations.  We only attempt to
  66  * deal with static objects and GC CAFs when doing a major GC.
  67  */
  68 static nat N;
  69 static rtsBool major_gc;
  70
  71 /* Youngest generation that objects should be evacuated to in
  72  * evacuate().  (Logically an argument to evacuate, but it's static
  73  * a lot of the time so we optimise it into a global variable).
  74  */
  75 static nat evac_gen;
  76
  77 /* WEAK POINTERS
  78  */
  79 static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
  80 static rtsBool weak_done;       /* all done for this pass */
  81
  82 /* Flag indicating failure to evacuate an object to the desired
  83  * generation.
  84  */
  85 static rtsBool failed_to_evac;
  86
  87 /* -----------------------------------------------------------------------------
  88    Static function declarations
  89    -------------------------------------------------------------------------- */
  90
  91 static StgClosure *evacuate(StgClosure *q);
  92 static void    zeroStaticObjectList(StgClosure* first_static);
  93 static rtsBool traverse_weak_ptr_list(void);
  94 static void    zeroMutableList(StgMutClosure *first);
  95 static void    revertDeadCAFs(void);
  96
  97 static void           scavenge_stack(StgPtr p, StgPtr stack_end);
  98 static void           scavenge_large(step *step);
  99 static void           scavenge(step *step);
 100 static void           scavenge_static(void);
 101 static StgMutClosure *scavenge_mutable_list(StgMutClosure *p, nat gen);
 102
 103 #ifdef DEBUG
 104 static void gcCAFs(void);
 105 #endif
 106
 107 /* -----------------------------------------------------------------------------
 108    GarbageCollect
 109
 110    For garbage collecting generation N (and all younger generations):
 111
 112      - follow all pointers in the root set.  the root set includes all
 113        mutable objects in all steps in all generations.
 114
 115      - for each pointer, evacuate the object it points to into either
 116        + to-space in the next higher step in that generation, if one exists,
 117        + if the object's generation == N, then evacuate it to the next
 118          generation if one exists, or else to-space in the current
 119          generation.
 120        + if the object's generation < N, then evacuate it to to-space
 121          in the next generation.
 122
 123      - repeatedly scavenge to-space from each step in each generation
 124        being collected until no more objects can be evacuated.
 125
 126      - free from-space in each step, and set from-space = to-space.
 127
 128    -------------------------------------------------------------------------- */
 129
 130 void GarbageCollect(void (*get_roots)(void))
 131 {
 132   bdescr *bd;
 133   step *step;
 134   lnat live, allocated, collected = 0;
 135   nat g, s;
 136
 137 #ifdef PROFILING
 138   CostCentreStack *prev_CCS;
 139 #endif
 140
 141   /* tell the stats department that we've started a GC */
 142   stat_startGC();
 143
 144   /* attribute any costs to CCS_GC */
 145 #ifdef PROFILING
 146   prev_CCS = CCCS;
 147   CCCS = CCS_GC;
 148 #endif
 149
 150   /* We might have been called from Haskell land by _ccall_GC, in
 151    * which case we need to call threadPaused() because the scheduler
 152    * won't have done it.
 153    */
 154   if (CurrentTSO) { threadPaused(CurrentTSO); }
 155
 156   /* Approximate how much we allocated: number of blocks in the
 157    * nursery + blocks allocated via allocate() - unused nusery blocks.
 158    * This leaves a little slop at the end of each block, and doesn't
 159    * take into account large objects (ToDo).
 160    */
 161   allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
 162   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 163     allocated -= BLOCK_SIZE_W;
 164   }
 165
 166   /* Figure out which generation to collect
 167    */
 168   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 169     if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
 170       N = g;
 171     }
 172   }
 173   major_gc = (N == RtsFlags.GcFlags.generations-1);
 174
 175   /* check stack sanity *before* GC (ToDo: check all threads) */
 176   /*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
 177   IF_DEBUG(sanity, checkFreeListSanity());
 178
 179   /* Initialise the static object lists
 180    */
 181   static_objects = END_OF_STATIC_LIST;
 182   scavenged_static_objects = END_OF_STATIC_LIST;
 183
 184   /* zero the mutable list for the oldest generation (see comment by
 185    * zeroMutableList below).
 186    */
 187   if (major_gc) {
 188     zeroMutableList(generations[RtsFlags.GcFlags.generations-1].mut_list);
 189   }
 190
 191   /* Initialise to-space in all the generations/steps that we're
 192    * collecting.
 193    */
 194   for (g = 0; g <= N; g++) {
 195     generations[g].mut_list = END_MUT_LIST;
 196
 197     for (s = 0; s < generations[g].n_steps; s++) {
 198       /* generation 0, step 0 doesn't need to-space */
 199       if (g == 0 && s == 0) { continue; }
 200       /* Get a free block for to-space.  Extra blocks will be chained on
 201        * as necessary.
 202        */
 203       bd = allocBlock();
 204       step = &generations[g].steps[s];
 205       ASSERT(step->gen->no == g);
 206       ASSERT(step->hp ? Bdescr(step->hp)->step == step : rtsTrue);
 207       bd->gen  = &generations[g];
 208       bd->step = step;
 209       bd->link = NULL;
 210       bd->evacuated = 1;        /* it's a to-space block */
 211       step->hp        = bd->start;
 212       step->hpLim     = step->hp + BLOCK_SIZE_W;
 213       step->hp_bd     = bd;
 214       step->to_space  = bd;
 215       step->to_blocks = 1; /* ???? */
 216       step->scan      = bd->start;
 217       step->scan_bd   = bd;
 218       step->new_large_objects = NULL;
 219       step->scavenged_large_objects = NULL;
 220       /* mark the large objects as not evacuated yet */
 221       for (bd = step->large_objects; bd; bd = bd->link) {
 222         bd->evacuated = 0;
 223       }
 224     }
 225   }
 226
 227   /* make sure the older generations have at least one block to
 228    * allocate into (this makes things easier for copy(), see below.
 229    */
 230   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 231     for (s = 0; s < generations[g].n_steps; s++) {
 232       step = &generations[g].steps[s];
 233       if (step->hp_bd == NULL) {
 234         bd = allocBlock();
 235         bd->gen = &generations[g];
 236         bd->step = step;
 237         bd->link = NULL;
 238         bd->evacuated = 0;      /* *not* a to-space block */
 239         step->hp = bd->start;
 240         step->hpLim = step->hp + BLOCK_SIZE_W;
 241         step->hp_bd = bd;
 242         step->blocks = bd;
 243         step->n_blocks = 1;
 244       }
 245       /* Set the scan pointer for older generations: remember we
 246        * still have to scavenge objects that have been promoted. */
 247       step->scan = step->hp;
 248       step->scan_bd = step->hp_bd;
 249       step->to_space = NULL;
 250       step->to_blocks = 0;
 251       step->new_large_objects = NULL;
 252       step->scavenged_large_objects = NULL;
 253 #ifdef DEBUG
 254       /* retain these so we can sanity-check later on */
 255       step->old_scan    = step->scan;
 256       step->old_scan_bd = step->scan_bd;
 257 #endif
 258     }
 259   }
 260
 261   /* -----------------------------------------------------------------------
 262    * follow all the roots that the application knows about.
 263    */
 264   evac_gen = 0;
 265   get_roots();
 266
 267   /* follow all the roots that we know about:
 268    *   - mutable lists from each generation > N
 269    * we want to *scavenge* these roots, not evacuate them: they're not
 270    * going to move in this GC.
 271    * Also: do them in reverse generation order.  This is because we
 272    * often want to promote objects that are pointed to by older
 273    * generations early, so we don't have to repeatedly copy them.
 274    * Doing the generations in reverse order ensures that we don't end
 275    * up in the situation where we want to evac an object to gen 3 and
 276    * it has already been evaced to gen 2.
 277    */
 278   {
 279     StgMutClosure *tmp, **pp;
 280     for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
 281       /* the act of scavenging the mutable list for this generation
 282        * might place more objects on the mutable list itself.  So we
 283        * place the current mutable list in a temporary, scavenge it,
 284        * and then append it to the new list.
 285        */
 286       tmp = generations[g].mut_list;
 287       generations[g].mut_list = END_MUT_LIST;
 288       tmp = scavenge_mutable_list(tmp, g);
 289
 290       pp = &generations[g].mut_list;
 291       while (*pp != END_MUT_LIST) {
 292            pp = &(*pp)->mut_link;
 293       }
 294       *pp = tmp;
 295     }
 296   }
 297   /* And don't forget to mark the TSO if we got here direct from
 298    * Haskell! */
 299   if (CurrentTSO) {
 300     CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
 301   }
 302
 303   /* Mark the weak pointer list, and prepare to detect dead weak
 304    * pointers.
 305    */
 306   markWeakList();
 307   old_weak_ptr_list = weak_ptr_list;
 308   weak_ptr_list = NULL;
 309   weak_done = rtsFalse;
 310
 311 #ifdef INTERPRETER
 312   {
 313       /* ToDo: To fix the caf leak, we need to make the commented out
 314        * parts of this code do something sensible - as described in
 315        * the CAF document.
 316        */
 317       extern void markHugsObjects(void);
 318 #if 0
 319       /* ToDo: This (undefined) function should contain the scavenge
 320        * loop immediately below this block of code - but I'm not sure
 321        * enough of the details to do this myself.
 322        */
 323       scavengeEverything();
 324       /* revert dead CAFs and update enteredCAFs list */
 325       revertDeadCAFs();
 326 #endif
 327       markHugsObjects();
 328 #if 0
 329       /* This will keep the CAFs and the attached BCOs alive
 330        * but the values will have been reverted
 331        */
 332       scavengeEverything();
 333 #endif
 334   }
 335 #endif
 336
 337   /* -------------------------------------------------------------------------
 338    * Repeatedly scavenge all the areas we know about until there's no
 339    * more scavenging to be done.
 340    */
 341   {
 342     rtsBool flag;
 343   loop:
 344     flag = rtsFalse;
 345
 346     /* scavenge static objects */
 347     if (major_gc && static_objects != END_OF_STATIC_LIST) {
 348       scavenge_static();
 349     }
 350
 351     /* When scavenging the older generations:  Objects may have been
 352      * evacuated from generations <= N into older generations, and we
 353      * need to scavenge these objects.  We're going to try to ensure that
 354      * any evacuations that occur move the objects into at least the
 355      * same generation as the object being scavenged, otherwise we
 356      * have to create new entries on the mutable list for the older
 357      * generation.
 358      */
 359
 360     /* scavenge each step in generations 0..maxgen */
 361     {
 362       int gen;
 363       for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
 364         for (s = 0; s < generations[gen].n_steps; s++) {
 365           step = &generations[gen].steps[s];
 366           evac_gen = gen;
 367           if (step->hp_bd != step->scan_bd || step->scan < step->hp) {
 368             scavenge(step);
 369             flag = rtsTrue;
 370           }
 371           if (step->new_large_objects != NULL) {
 372             scavenge_large(step);
 373             flag = rtsTrue;
 374           }
 375         }
 376       }
 377     }
 378     if (flag) { goto loop; }
 379
 380     /* must be last... */
 381     if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
 382       goto loop;
 383     }
 384   }
 385
 386   /* run through all the generations/steps and tidy up
 387    */
 388   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 389
 390     if (g <= N) {
 391       generations[g].collections++; /* for stats */
 392     }
 393
 394     for (s = 0; s < generations[g].n_steps; s++) {
 395       bdescr *next;
 396       step = &generations[g].steps[s];
 397
 398       if (!(g == 0 && s == 0)) {
 399         /* Tidy the end of the to-space chains */
 400         step->hp_bd->free = step->hp;
 401         step->hp_bd->link = NULL;
 402       }
 403
 404       /* for generations we collected... */
 405       if (g <= N) {
 406
 407         collected += step->n_blocks * BLOCK_SIZE_W; /* for stats */
 408
 409         /* free old memory and shift to-space into from-space for all
 410          * the collected steps (except the allocation area).  These
 411          * freed blocks will probaby be quickly recycled.
 412          */
 413         if (!(g == 0 && s == 0)) {
 414           freeChain(step->blocks);
 415           step->blocks = step->to_space;
 416           step->n_blocks = step->to_blocks;
 417           step->to_space = NULL;
 418           step->to_blocks = 0;
 419           for (bd = step->blocks; bd != NULL; bd = bd->link) {
 420             bd->evacuated = 0;  /* now from-space */
 421           }
 422         }
 423
 424         /* LARGE OBJECTS.  The current live large objects are chained on
 425          * scavenged_large, having been moved during garbage
 426          * collection from large_objects.  Any objects left on
 427          * large_objects list are therefore dead, so we free them here.
 428          */
 429         for (bd = step->large_objects; bd != NULL; bd = next) {
 430           next = bd->link;
 431           freeGroup(bd);
 432           bd = next;
 433         }
 434         for (bd = step->scavenged_large_objects; bd != NULL; bd = bd->link) {
 435           bd->evacuated = 0;
 436         }
 437         step->large_objects = step->scavenged_large_objects;
 438
 439         /* Set the maximum blocks for this generation,
 440          * using an arbitrary factor of the no. of blocks in step 0.
 441          */
 442         if (g != 0) {
 443           generation *gen = &generations[g];
 444           gen->max_blocks =
 445             stg_max(gen->steps[s].n_blocks * 2,
 446                     RtsFlags.GcFlags.minAllocAreaSize * 4);
 447           if (gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
 448             gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
 449             if (((int)gen->max_blocks - (int)gen->steps[0].n_blocks) <
 450                 (RtsFlags.GcFlags.pcFreeHeap *
 451                  RtsFlags.GcFlags.maxHeapSize / 200)) {
 452               heapOverflow();
 453             }
 454           }
 455         }
 456
 457       /* for older generations... */
 458       } else {
 459
 460         /* For older generations, we need to append the
 461          * scavenged_large_object list (i.e. large objects that have been
 462          * promoted during this GC) to the large_object list for that step.
 463          */
 464         for (bd = step->scavenged_large_objects; bd; bd = next) {
 465           next = bd->link;
 466           bd->evacuated = 0;
 467           dbl_link_onto(bd, &step->large_objects);
 468         }
 469
 470         /* add the new blocks we promoted during this GC */
 471         step->n_blocks += step->to_blocks;
 472       }
 473     }
 474   }
 475
 476   /* revert dead CAFs and update enteredCAFs list */
 477   revertDeadCAFs();
 478
 479   /* mark the garbage collected CAFs as dead */
 480 #ifdef DEBUG
 481   if (major_gc) { gcCAFs(); }
 482 #endif
 483
 484   /* zero the scavenged static object list */
 485   if (major_gc) {
 486     zeroStaticObjectList(scavenged_static_objects);
 487   }
 488
 489   /* Reset the nursery
 490    */
 491   for (bd = g0s0->blocks; bd; bd = bd->link) {
 492     bd->free = bd->start;
 493     ASSERT(bd->gen == g0);
 494     ASSERT(bd->step == g0s0);
 495   }
 496   current_nursery = g0s0->blocks;
 497
 498   live = 0;
 499   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 500     for (s = 0; s < generations[g].n_steps; s++) {
 501       /* approximate amount of live data (doesn't take into account slop
 502        * at end of each block).  ToDo: this more accurately.
 503        */
 504       if (g == 0 && s == 0) { continue; }
 505       step = &generations[g].steps[s];
 506       live += step->n_blocks * BLOCK_SIZE_W +
 507         ((lnat)step->hp_bd->free -(lnat)step->hp_bd->start) / sizeof(W_);
 508     }
 509   }
 510
 511   /* Free the small objects allocated via allocate(), since this will
 512    * all have been copied into G0S1 now.
 513    */
 514   if (small_alloc_list != NULL) {
 515     freeChain(small_alloc_list);
 516   }
 517   small_alloc_list = NULL;
 518   alloc_blocks = 0;
 519   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
 520
 521   /* start any pending finalisers */
 522   scheduleFinalisers(old_weak_ptr_list);
 523
 524   /* check sanity after GC */
 525 #ifdef DEBUG
 526   for (g = 0; g <= N; g++) {
 527     for (s = 0; s < generations[g].n_steps; s++) {
 528       if (g == 0 && s == 0) { continue; }
 529       IF_DEBUG(sanity, checkHeap(generations[g].steps[s].blocks, NULL));
 530       IF_DEBUG(sanity, checkChain(generations[g].steps[s].large_objects));
 531     }
 532   }
 533   for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
 534     for (s = 0; s < generations[g].n_steps; s++) {
 535       IF_DEBUG(sanity, checkHeap(generations[g].steps[s].old_scan_bd,
 536                                  generations[g].steps[s].old_scan));
 537       IF_DEBUG(sanity, checkChain(generations[g].steps[s].large_objects));
 538     }
 539   }
 540   IF_DEBUG(sanity, checkFreeListSanity());
 541 #endif
 542
 543   IF_DEBUG(gc, stat_describe_gens());
 544
 545 #ifdef DEBUG
 546   /* symbol-table based profiling */
 547   /*  heapCensus(to_space); */ /* ToDo */
 548 #endif
 549
 550   /* restore enclosing cost centre */
 551 #ifdef PROFILING
 552   CCCS = prev_CCS;
 553 #endif
 554
 555   /* check for memory leaks if sanity checking is on */
 556   IF_DEBUG(sanity, memInventory());
 557
 558   /* ok, GC over: tell the stats department what happened. */
 559   stat_endGC(allocated, collected, live, N);
 560 }
 561
 562 /* -----------------------------------------------------------------------------
 563    Weak Pointers
 564
 565    traverse_weak_ptr_list is called possibly many times during garbage
 566    collection.  It returns a flag indicating whether it did any work
 567    (i.e. called evacuate on any live pointers).
 568
 569    Invariant: traverse_weak_ptr_list is called when the heap is in an
 570    idempotent state.  That means that there are no pending
 571    evacuate/scavenge operations.  This invariant helps the weak
 572    pointer code decide which weak pointers are dead - if there are no
 573    new live weak pointers, then all the currently unreachable ones are
 574    dead.
 575
 576    For generational GC: we just don't try to finalise weak pointers in
 577    older generations than the one we're collecting.  This could
 578    probably be optimised by keeping per-generation lists of weak
 579    pointers, but for a few weak pointers this scheme will work.
 580    -------------------------------------------------------------------------- */
 581
 582 static rtsBool
 583 traverse_weak_ptr_list(void)
 584 {
 585   StgWeak *w, **last_w, *next_w;
 586   StgClosure *target;
 587   const StgInfoTable *info;
 588   rtsBool flag = rtsFalse;
 589
 590   if (weak_done) { return rtsFalse; }
 591
 592   /* doesn't matter where we evacuate values/finalisers to, since
 593    * these pointers are treated as roots (iff the keys are alive).
 594    */
 595   evac_gen = 0;
 596
 597   last_w = &old_weak_ptr_list;
 598   for (w = old_weak_ptr_list; w; w = next_w) {
 599     target = w->key;
 600   loop:
 601     /* ignore weak pointers in older generations */
 602     if (!LOOKS_LIKE_STATIC(target) && Bdescr((P_)target)->gen->no > N) {
 603       IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive (in old gen) at %p\n", w));
 604       /* remove this weak ptr from the old_weak_ptr list */
 605       *last_w = w->link;
 606       /* and put it on the new weak ptr list */
 607       next_w  = w->link;
 608       w->link = weak_ptr_list;
 609       weak_ptr_list = w;
 610       flag = rtsTrue;
 611       continue;
 612     }
 613
 614     info = get_itbl(target);
 615     switch (info->type) {
 616
 617     case IND:
 618     case IND_STATIC:
 619     case IND_PERM:
 620     case IND_OLDGEN:            /* rely on compatible layout with StgInd */
 621     case IND_OLDGEN_PERM:
 622       /* follow indirections */
 623       target = ((StgInd *)target)->indirectee;
 624       goto loop;
 625
 626     case EVACUATED:
 627       /* If key is alive, evacuate value and finaliser and
 628        * place weak ptr on new weak ptr list.
 629        */
 630       IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p\n", w));
 631       w->key = ((StgEvacuated *)target)->evacuee;
 632       w->value = evacuate(w->value);
 633       w->finaliser = evacuate(w->finaliser);
 634
 635       /* remove this weak ptr from the old_weak_ptr list */
 636       *last_w = w->link;
 637
 638       /* and put it on the new weak ptr list */
 639       next_w  = w->link;
 640       w->link = weak_ptr_list;
 641       weak_ptr_list = w;
 642       flag = rtsTrue;
 643       break;
 644
 645     default:                    /* key is dead */
 646       last_w = &(w->link);
 647       next_w = w->link;
 648       break;
 649     }
 650   }
 651
 652   /* If we didn't make any changes, then we can go round and kill all
 653    * the dead weak pointers.  The old_weak_ptr list is used as a list
 654    * of pending finalisers later on.
 655    */
 656   if (flag == rtsFalse) {
 657     for (w = old_weak_ptr_list; w; w = w->link) {
 658       w->value = evacuate(w->value);
 659       w->finaliser = evacuate(w->finaliser);
 660     }
 661     weak_done = rtsTrue;
 662   }
 663
 664   return rtsTrue;
 665 }
 666
 667 StgClosure *
 668 MarkRoot(StgClosure *root)
 669 {
 670   root = evacuate(root);
 671   return root;
 672 }
 673
 674 static inline void addBlock(step *step)
 675 {
 676   bdescr *bd = allocBlock();
 677   bd->gen = step->gen;
 678   bd->step = step;
 679
 680   if (step->gen->no <= N) {
 681     bd->evacuated = 1;
 682   } else {
 683     bd->evacuated = 0;
 684   }
 685
 686   step->hp_bd->free = step->hp;
 687   step->hp_bd->link = bd;
 688   step->hp = bd->start;
 689   step->hpLim = step->hp + BLOCK_SIZE_W;
 690   step->hp_bd = bd;
 691   step->to_blocks++;
 692 }
 693
 694 static __inline__ StgClosure *
 695 copy(StgClosure *src, W_ size, bdescr *bd)
 696 {
 697   step *step;
 698   P_ to, from, dest;
 699
 700   /* Find out where we're going, using the handy "to" pointer in
 701    * the step of the source object.  If it turns out we need to
 702    * evacuate to an older generation, adjust it here (see comment
 703    * by evacuate()).
 704    */
 705   step = bd->step->to;
 706   if (step->gen->no < evac_gen) {
 707     step = &generations[evac_gen].steps[0];
 708   }
 709
 710   /* chain a new block onto the to-space for the destination step if
 711    * necessary.
 712    */
 713   if (step->hp + size >= step->hpLim) {
 714     addBlock(step);
 715   }
 716
 717   dest = step->hp;
 718   step->hp += size;
 719   for(to = dest, from = (P_)src; size>0; --size) {
 720     *to++ = *from++;
 721   }
 722   return (StgClosure *)dest;
 723 }
 724
 725 static __inline__ void
 726 upd_evacuee(StgClosure *p, StgClosure *dest)
 727 {
 728   StgEvacuated *q = (StgEvacuated *)p;
 729
 730   SET_INFO(q,&EVACUATED_info);
 731   q->evacuee = dest;
 732 }
 733
 734 /* -----------------------------------------------------------------------------
 735    Evacuate a mutable object
 736
 737    If we evacuate a mutable object to an old generation, cons the
 738    object onto the older generation's mutable list.
 739    -------------------------------------------------------------------------- */
 740
 741 static inline void
 742 evacuate_mutable(StgMutClosure *c)
 743 {
 744   bdescr *bd;
 745
 746   bd = Bdescr((P_)c);
 747   if (bd->gen->no > 0) {
 748     c->mut_link = bd->gen->mut_list;
 749     bd->gen->mut_list = c;
 750   }
 751 }
 752
 753 /* -----------------------------------------------------------------------------
 754    Evacuate a large object
 755
 756    This just consists of removing the object from the (doubly-linked)
 757    large_alloc_list, and linking it on to the (singly-linked)
 758    new_large_objects list, from where it will be scavenged later.
 759
 760    Convention: bd->evacuated is /= 0 for a large object that has been
 761    evacuated, or 0 otherwise.
 762    -------------------------------------------------------------------------- */
 763
 764 static inline void
 765 evacuate_large(StgPtr p, rtsBool mutable)
 766 {
 767   bdescr *bd = Bdescr(p);
 768   step *step;
 769
 770   /* should point to the beginning of the block */
 771   ASSERT(((W_)p & BLOCK_MASK) == 0);
 772
 773   /* already evacuated? */
 774   if (bd->evacuated) {
 775     /* Don't forget to set the failed_to_evac flag if we didn't get
 776      * the desired destination (see comments in evacuate()).
 777      */
 778     if (bd->gen->no < evac_gen) {
 779       failed_to_evac = rtsTrue;
 780     }
 781     return;
 782   }
 783
 784   step = bd->step;
 785   /* remove from large_object list */
 786   if (bd->back) {
 787     bd->back->link = bd->link;
 788   } else { /* first object in the list */
 789     step->large_objects = bd->link;
 790   }
 791   if (bd->link) {
 792     bd->link->back = bd->back;
 793   }
 794
 795   /* link it on to the evacuated large object list of the destination step
 796    */
 797   step = bd->step->to;
 798   if (step->gen->no < evac_gen) {
 799     step = &generations[evac_gen].steps[0];
 800   }
 801
 802   bd->step = step;
 803   bd->gen = step->gen;
 804   bd->link = step->new_large_objects;
 805   step->new_large_objects = bd;
 806   bd->evacuated = 1;
 807
 808   if (mutable) {
 809     evacuate_mutable((StgMutClosure *)p);
 810   }
 811 }
 812
 813 /* -----------------------------------------------------------------------------
 814    Adding a MUT_CONS to an older generation.
 815
 816    This is necessary from time to time when we end up with an
 817    old-to-new generation pointer in a non-mutable object.  We defer
 818    the promotion until the next GC.
 819    -------------------------------------------------------------------------- */
 820
 821 static StgClosure *
 822 mkMutCons(StgClosure *ptr, generation *gen)
 823 {
 824   StgMutVar *q;
 825   step *step;
 826
 827   step = &gen->steps[0];
 828
 829   /* chain a new block onto the to-space for the destination step if
 830    * necessary.
 831    */
 832   if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
 833     addBlock(step);
 834   }
 835
 836   q = (StgMutVar *)step->hp;
 837   step->hp += sizeofW(StgMutVar);
 838
 839   SET_HDR(q,&MUT_CONS_info,CCS_GC);
 840   q->var = ptr;
 841   evacuate_mutable((StgMutClosure *)q);
 842
 843   return (StgClosure *)q;
 844 }
 845
 846 /* -----------------------------------------------------------------------------
 847    Evacuate
 848
 849    This is called (eventually) for every live object in the system.
 850
 851    The caller to evacuate specifies a desired generation in the
 852    evac_gen global variable.  The following conditions apply to
 853    evacuating an object which resides in generation M when we're
 854    collecting up to generation N
 855
 856    if  M >= evac_gen
 857            if  M > N     do nothing
 858            else          evac to step->to
 859
 860    if  M < evac_gen      evac to evac_gen, step 0
 861
 862    if the object is already evacuated, then we check which generation
 863    it now resides in.
 864
 865    if  M >= evac_gen     do nothing
 866    if  M <  evac_gen     set failed_to_evac flag to indicate that we
 867                          didn't manage to evacuate this object into evac_gen.
 868
 869    -------------------------------------------------------------------------- */
 870
 871
 872 static StgClosure *
 873 evacuate(StgClosure *q)
 874 {
 875   StgClosure *to;
 876   bdescr *bd = NULL;
 877   const StgInfoTable *info;
 878
 879 loop:
 880   if (!LOOKS_LIKE_STATIC(q)) {
 881     bd = Bdescr((P_)q);
 882     if (bd->gen->no > N) {
 883       /* Can't evacuate this object, because it's in a generation
 884        * older than the ones we're collecting.  Let's hope that it's
 885        * in evac_gen or older, or we will have to make an IND_OLDGEN object.
 886        */
 887       if (bd->gen->no < evac_gen) {
 888         /* nope */
 889         failed_to_evac = rtsTrue;
 890       }
 891       return q;
 892     }
 893   }
 894
 895   /* make sure the info pointer is into text space */
 896   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
 897                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
 898
 899   info = get_itbl(q);
 900   switch (info -> type) {
 901
 902   case BCO:
 903     to = copy(q,bco_sizeW(stgCast(StgBCO*,q)),bd);
 904     upd_evacuee(q,to);
 905     return to;
 906
 907   case MUT_VAR:
 908   case MVAR:
 909     to = copy(q,sizeW_fromITBL(info),bd);
 910     upd_evacuee(q,to);
 911     evacuate_mutable((StgMutClosure *)to);
 912     return to;
 913
 914   case FUN:
 915   case THUNK:
 916   case CONSTR:
 917   case IND_PERM:
 918   case IND_OLDGEN_PERM:
 919   case CAF_UNENTERED:
 920   case CAF_ENTERED:
 921   case WEAK:
 922   case FOREIGN:
 923     to = copy(q,sizeW_fromITBL(info),bd);
 924     upd_evacuee(q,to);
 925     return to;
 926
 927   case CAF_BLACKHOLE:
 928   case BLACKHOLE:
 929     to = copy(q,BLACKHOLE_sizeW(),bd);
 930     upd_evacuee(q,to);
 931     return to;
 932
 933   case THUNK_SELECTOR:
 934     {
 935       const StgInfoTable* selectee_info;
 936       StgClosure* selectee = ((StgSelector*)q)->selectee;
 937
 938     selector_loop:
 939       selectee_info = get_itbl(selectee);
 940       switch (selectee_info->type) {
 941       case CONSTR:
 942       case CONSTR_STATIC:
 943         {
 944           StgNat32 offset = info->layout.selector_offset;
 945
 946           /* check that the size is in range */
 947           ASSERT(offset <
 948                  (StgNat32)(selectee_info->layout.payload.ptrs +
 949                             selectee_info->layout.payload.nptrs));
 950
 951           /* perform the selection! */
 952           q = selectee->payload[offset];
 953
 954           /* if we're already in to-space, there's no need to continue
 955            * with the evacuation, just update the source address with
 956            * a pointer to the (evacuated) constructor field.
 957            */
 958           if (IS_USER_PTR(q)) {
 959             bdescr *bd = Bdescr((P_)q);
 960             if (bd->evacuated) {
 961               if (bd->gen->no < evac_gen) {
 962                 failed_to_evac = rtsTrue;
 963               }
 964               return q;
 965             }
 966           }
 967
 968           /* otherwise, carry on and evacuate this constructor field,
 969            * (but not the constructor itself)
 970            */
 971           goto loop;
 972         }
 973
 974       case IND:
 975       case IND_STATIC:
 976       case IND_PERM:
 977       case IND_OLDGEN:
 978       case IND_OLDGEN_PERM:
 979         selectee = stgCast(StgInd *,selectee)->indirectee;
 980         goto selector_loop;
 981
 982       case CAF_ENTERED:
 983         selectee = stgCast(StgCAF *,selectee)->value;
 984         goto selector_loop;
 985
 986       case EVACUATED:
 987         selectee = stgCast(StgEvacuated*,selectee)->evacuee;
 988         goto selector_loop;
 989
 990       case THUNK:
 991       case THUNK_STATIC:
 992       case THUNK_SELECTOR:
 993         /* aargh - do recursively???? */
 994       case CAF_UNENTERED:
 995       case CAF_BLACKHOLE:
 996       case BLACKHOLE:
 997         /* not evaluated yet */
 998         break;
 999
1000       default:
1001         barf("evacuate: THUNK_SELECTOR: strange selectee");
1002       }
1003     }
1004     to = copy(q,THUNK_SELECTOR_sizeW(),bd);
1005     upd_evacuee(q,to);
1006     return to;
1007
1008   case IND:
1009   case IND_OLDGEN:
1010     /* follow chains of indirections, don't evacuate them */
1011     q = ((StgInd*)q)->indirectee;
1012     goto loop;
1013
1014     /* ToDo: optimise STATIC_LINK for known cases.
1015        - FUN_STATIC       : payload[0]
1016        - THUNK_STATIC     : payload[1]
1017        - IND_STATIC       : payload[1]
1018     */
1019   case THUNK_STATIC:
1020   case FUN_STATIC:
1021     if (info->srt_len == 0) {   /* small optimisation */
1022       return q;
1023     }
1024     /* fall through */
1025   case CONSTR_STATIC:
1026   case IND_STATIC:
1027     /* don't want to evacuate these, but we do want to follow pointers
1028      * from SRTs  - see scavenge_static.
1029      */
1030
1031     /* put the object on the static list, if necessary.
1032      */
1033     if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
1034       STATIC_LINK(info,(StgClosure *)q) = static_objects;
1035       static_objects = (StgClosure *)q;
1036     }
1037     /* fall through */
1038
1039   case CONSTR_INTLIKE:
1040   case CONSTR_CHARLIKE:
1041   case CONSTR_NOCAF_STATIC:
1042     /* no need to put these on the static linked list, they don't need
1043      * to be scavenged.
1044      */
1045     return q;
1046
1047   case RET_BCO:
1048   case RET_SMALL:
1049   case RET_VEC_SMALL:
1050   case RET_BIG:
1051   case RET_VEC_BIG:
1052   case RET_DYN:
1053   case UPDATE_FRAME:
1054   case STOP_FRAME:
1055   case CATCH_FRAME:
1056   case SEQ_FRAME:
1057     /* shouldn't see these */
1058     barf("evacuate: stack frame\n");
1059
1060   case AP_UPD:
1061   case PAP:
1062     /* these are special - the payload is a copy of a chunk of stack,
1063        tagging and all. */
1064     to = copy(q,pap_sizeW(stgCast(StgPAP*,q)),bd);
1065     upd_evacuee(q,to);
1066     return to;
1067
1068   case EVACUATED:
1069     /* Already evacuated, just return the forwarding address.
1070      * HOWEVER: if the requested destination generation (evac_gen) is
1071      * older than the actual generation (because the object was
1072      * already evacuated to a younger generation) then we have to
1073      * set the failed_to_evac flag to indicate that we couldn't
1074      * manage to promote the object to the desired generation.
1075      */
1076     if (evac_gen > 0) {         /* optimisation */
1077       StgClosure *p = ((StgEvacuated*)q)->evacuee;
1078       if (Bdescr((P_)p)->gen->no < evac_gen) {
1079         /*      fprintf(stderr,"evac failed!\n");*/
1080         failed_to_evac = rtsTrue;
1081       }
1082     }
1083     return ((StgEvacuated*)q)->evacuee;
1084
1085   case MUT_ARR_WORDS:
1086   case ARR_WORDS:
1087     {
1088       nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
1089
1090       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1091         evacuate_large((P_)q, rtsFalse);
1092         return q;
1093       } else {
1094         /* just copy the block */
1095         to = copy(q,size,bd);
1096         upd_evacuee(q,to);
1097         return to;
1098       }
1099     }
1100
1101   case MUT_ARR_PTRS:
1102   case MUT_ARR_PTRS_FROZEN:
1103     {
1104       nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
1105
1106       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1107         evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
1108         to = q;
1109       } else {
1110         /* just copy the block */
1111         to = copy(q,size,bd);
1112         upd_evacuee(q,to);
1113         if (info->type == MUT_ARR_PTRS) {
1114           evacuate_mutable((StgMutClosure *)to);
1115         }
1116       }
1117       return to;
1118     }
1119
1120   case TSO:
1121     {
1122       StgTSO *tso = stgCast(StgTSO *,q);
1123       nat size = tso_sizeW(tso);
1124       int diff;
1125
1126       /* Large TSOs don't get moved, so no relocation is required.
1127        */
1128       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
1129         evacuate_large((P_)q, rtsFalse);
1130         tso->mut_link = NULL;   /* see below */
1131         return q;
1132
1133       /* To evacuate a small TSO, we need to relocate the update frame
1134        * list it contains.
1135        */
1136       } else {
1137         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),bd);
1138
1139         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
1140
1141         /* relocate the stack pointers... */
1142         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
1143         new_tso->sp = (StgPtr)new_tso->sp + diff;
1144         new_tso->splim = (StgPtr)new_tso->splim + diff;
1145
1146         relocate_TSO(tso, new_tso);
1147         upd_evacuee(q,(StgClosure *)new_tso);
1148
1149         /* don't evac_mutable - these things are marked mutable as
1150          * required.  We *do* need to zero the mut_link field, though:
1151          * this TSO might have been on the mutable list for this
1152          * generation, but we're collecting this generation anyway so
1153          * we didn't follow the mutable list.
1154          */
1155         new_tso->mut_link = NULL;
1156
1157         return (StgClosure *)new_tso;
1158       }
1159     }
1160
1161   case BLOCKED_FETCH:
1162   case FETCH_ME:
1163     fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
1164     return q;
1165
1166   default:
1167     barf("evacuate: strange closure type");
1168   }
1169
1170   barf("evacuate");
1171 }
1172
1173 /* -----------------------------------------------------------------------------
1174    relocate_TSO is called just after a TSO has been copied from src to
1175    dest.  It adjusts the update frame list for the new location.
1176    -------------------------------------------------------------------------- */
1177
1178 StgTSO *
1179 relocate_TSO(StgTSO *src, StgTSO *dest)
1180 {
1181   StgUpdateFrame *su;
1182   StgCatchFrame  *cf;
1183   StgSeqFrame    *sf;
1184   int diff;
1185
1186   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
1187
1188   su = dest->su;
1189
1190   while ((P_)su < dest->stack + dest->stack_size) {
1191     switch (get_itbl(su)->type) {
1192
1193       /* GCC actually manages to common up these three cases! */
1194
1195     case UPDATE_FRAME:
1196       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
1197       su = su->link;
1198       continue;
1199
1200     case CATCH_FRAME:
1201       cf = (StgCatchFrame *)su;
1202       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
1203       su = cf->link;
1204       continue;
1205
1206     case SEQ_FRAME:
1207       sf = (StgSeqFrame *)su;
1208       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
1209       su = sf->link;
1210       continue;
1211
1212     case STOP_FRAME:
1213       /* all done! */
1214       break;
1215
1216     default:
1217       barf("relocate_TSO");
1218     }
1219     break;
1220   }
1221
1222   return dest;
1223 }
1224
1225 static inline void
1226 scavenge_srt(const StgInfoTable *info)
1227 {
1228   StgClosure **srt, **srt_end;
1229
1230   /* evacuate the SRT.  If srt_len is zero, then there isn't an
1231    * srt field in the info table.  That's ok, because we'll
1232    * never dereference it.
1233    */
1234   srt = stgCast(StgClosure **,info->srt);
1235   srt_end = srt + info->srt_len;
1236   for (; srt < srt_end; srt++) {
1237     evacuate(*srt);
1238   }
1239 }
1240
1241 /* -----------------------------------------------------------------------------
1242    Scavenge a given step until there are no more objects in this step
1243    to scavenge.
1244
1245    evac_gen is set by the caller to be either zero (for a step in a
1246    generation < N) or G where G is the generation of the step being
1247    scavenged.
1248
1249    We sometimes temporarily change evac_gen back to zero if we're
1250    scavenging a mutable object where early promotion isn't such a good
1251    idea.
1252    -------------------------------------------------------------------------- */
1253
1254
1255 static void
1256 scavenge(step *step)
1257 {
1258   StgPtr p, q;
1259   const StgInfoTable *info;
1260   bdescr *bd;
1261   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1262
1263   p = step->scan;
1264   bd = step->scan_bd;
1265
1266   failed_to_evac = rtsFalse;
1267
1268   /* scavenge phase - standard breadth-first scavenging of the
1269    * evacuated objects
1270    */
1271
1272   while (bd != step->hp_bd || p < step->hp) {
1273
1274     /* If we're at the end of this block, move on to the next block */
1275     if (bd != step->hp_bd && p == bd->free) {
1276       bd = bd->link;
1277       p = bd->start;
1278       continue;
1279     }
1280
1281     q = p;                      /* save ptr to object */
1282
1283     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1284                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1285
1286     info = get_itbl((StgClosure *)p);
1287     switch (info -> type) {
1288
1289     case BCO:
1290       {
1291         StgBCO* bco = stgCast(StgBCO*,p);
1292         nat i;
1293         for (i = 0; i < bco->n_ptrs; i++) {
1294           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1295         }
1296         p += bco_sizeW(bco);
1297         break;
1298       }
1299
1300     case MVAR:
1301       /* treat MVars specially, because we don't want to evacuate the
1302        * mut_link field in the middle of the closure.
1303        */
1304       {
1305         StgMVar *mvar = ((StgMVar *)p);
1306         evac_gen = 0;
1307         (StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
1308         (StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
1309         (StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
1310         p += sizeofW(StgMVar);
1311         evac_gen = saved_evac_gen;
1312         break;
1313       }
1314
1315     case FUN:
1316     case THUNK:
1317       scavenge_srt(info);
1318       /* fall through */
1319
1320     case CONSTR:
1321     case WEAK:
1322     case FOREIGN:
1323     case IND_PERM:
1324     case IND_OLDGEN_PERM:
1325     case CAF_UNENTERED:
1326     case CAF_ENTERED:
1327       {
1328         StgPtr end;
1329
1330         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1331         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1332           (StgClosure *)*p = evacuate((StgClosure *)*p);
1333         }
1334         p += info->layout.payload.nptrs;
1335         break;
1336       }
1337
1338     case MUT_VAR:
1339       /* ignore MUT_CONSs */
1340       if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
1341         evac_gen = 0;
1342         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1343         evac_gen = saved_evac_gen;
1344       }
1345       p += sizeofW(StgMutVar);
1346       break;
1347
1348     case CAF_BLACKHOLE:
1349     case BLACKHOLE:
1350       {
1351         StgBlackHole *bh = (StgBlackHole *)p;
1352         (StgClosure *)bh->blocking_queue =
1353           evacuate((StgClosure *)bh->blocking_queue);
1354         p += BLACKHOLE_sizeW();
1355         break;
1356       }
1357
1358     case THUNK_SELECTOR:
1359       {
1360         StgSelector *s = (StgSelector *)p;
1361         s->selectee = evacuate(s->selectee);
1362         p += THUNK_SELECTOR_sizeW();
1363         break;
1364       }
1365
1366     case IND:
1367     case IND_OLDGEN:
1368       barf("scavenge:IND???\n");
1369
1370     case CONSTR_INTLIKE:
1371     case CONSTR_CHARLIKE:
1372     case CONSTR_STATIC:
1373     case CONSTR_NOCAF_STATIC:
1374     case THUNK_STATIC:
1375     case FUN_STATIC:
1376     case IND_STATIC:
1377       /* Shouldn't see a static object here. */
1378       barf("scavenge: STATIC object\n");
1379
1380     case RET_BCO:
1381     case RET_SMALL:
1382     case RET_VEC_SMALL:
1383     case RET_BIG:
1384     case RET_VEC_BIG:
1385     case RET_DYN:
1386     case UPDATE_FRAME:
1387     case STOP_FRAME:
1388     case CATCH_FRAME:
1389     case SEQ_FRAME:
1390       /* Shouldn't see stack frames here. */
1391       barf("scavenge: stack frame\n");
1392
1393     case AP_UPD: /* same as PAPs */
1394     case PAP:
1395       /* Treat a PAP just like a section of stack, not forgetting to
1396        * evacuate the function pointer too...
1397        */
1398       {
1399         StgPAP* pap = stgCast(StgPAP*,p);
1400
1401         pap->fun = evacuate(pap->fun);
1402         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1403         p += pap_sizeW(pap);
1404         break;
1405       }
1406
1407     case ARR_WORDS:
1408     case MUT_ARR_WORDS:
1409       /* nothing to follow */
1410       p += arr_words_sizeW(stgCast(StgArrWords*,p));
1411       break;
1412
1413     case MUT_ARR_PTRS:
1414       /* follow everything */
1415       {
1416         StgPtr next;
1417
1418         evac_gen = 0;           /* repeatedly mutable */
1419         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1420         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1421           (StgClosure *)*p = evacuate((StgClosure *)*p);
1422         }
1423         evac_gen = saved_evac_gen;
1424         break;
1425       }
1426
1427     case MUT_ARR_PTRS_FROZEN:
1428       /* follow everything */
1429       {
1430         StgPtr start = p, next;
1431
1432         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1433         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1434           (StgClosure *)*p = evacuate((StgClosure *)*p);
1435         }
1436         if (failed_to_evac) {
1437           /* we can do this easier... */
1438           evacuate_mutable((StgMutClosure *)start);
1439           failed_to_evac = rtsFalse;
1440         }
1441         break;
1442       }
1443
1444     case TSO:
1445       {
1446         StgTSO *tso;
1447
1448         tso = (StgTSO *)p;
1449         evac_gen = 0;
1450         /* chase the link field for any TSOs on the same queue */
1451         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1452         /* scavenge this thread's stack */
1453         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1454         evac_gen = saved_evac_gen;
1455         p += tso_sizeW(tso);
1456         break;
1457       }
1458
1459     case BLOCKED_FETCH:
1460     case FETCH_ME:
1461     case EVACUATED:
1462       barf("scavenge: unimplemented/strange closure type\n");
1463
1464     default:
1465       barf("scavenge");
1466     }
1467
1468     /* If we didn't manage to promote all the objects pointed to by
1469      * the current object, then we have to designate this object as
1470      * mutable (because it contains old-to-new generation pointers).
1471      */
1472     if (failed_to_evac) {
1473       mkMutCons((StgClosure *)q, &generations[evac_gen]);
1474       failed_to_evac = rtsFalse;
1475     }
1476   }
1477
1478   step->scan_bd = bd;
1479   step->scan = p;
1480 }
1481
1482 /* -----------------------------------------------------------------------------
1483    Scavenge one object.
1484
1485    This is used for objects that are temporarily marked as mutable
1486    because they contain old-to-new generation pointers.  Only certain
1487    objects can have this property.
1488    -------------------------------------------------------------------------- */
1489 static rtsBool
1490 scavenge_one(StgPtr p)
1491 {
1492   StgInfoTable *info;
1493   rtsBool no_luck;
1494
1495   ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
1496                || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
1497
1498   info = get_itbl((StgClosure *)p);
1499
1500   switch (info -> type) {
1501
1502   case FUN:
1503   case THUNK:
1504   case CONSTR:
1505   case WEAK:
1506   case FOREIGN:
1507   case IND_PERM:
1508   case IND_OLDGEN_PERM:
1509   case CAF_UNENTERED:
1510   case CAF_ENTERED:
1511     {
1512       StgPtr end;
1513
1514       end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1515       for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
1516         (StgClosure *)*p = evacuate((StgClosure *)*p);
1517       }
1518       break;
1519     }
1520
1521   case CAF_BLACKHOLE:
1522   case BLACKHOLE:
1523     {
1524       StgBlackHole *bh = (StgBlackHole *)p;
1525       (StgClosure *)bh->blocking_queue =
1526         evacuate((StgClosure *)bh->blocking_queue);
1527       break;
1528     }
1529
1530   case THUNK_SELECTOR:
1531     {
1532       StgSelector *s = (StgSelector *)p;
1533       s->selectee = evacuate(s->selectee);
1534        break;
1535     }
1536
1537   case AP_UPD: /* same as PAPs */
1538   case PAP:
1539     /* Treat a PAP just like a section of stack, not forgetting to
1540      * evacuate the function pointer too...
1541      */
1542     {
1543       StgPAP* pap = stgCast(StgPAP*,p);
1544
1545       pap->fun = evacuate(pap->fun);
1546       scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1547       break;
1548     }
1549
1550   case IND_OLDGEN:
1551     /* This might happen if for instance a MUT_CONS was pointing to a
1552      * THUNK which has since been updated.  The IND_OLDGEN will
1553      * be on the mutable list anyway, so we don't need to do anything
1554      * here.
1555      */
1556     break;
1557
1558   default:
1559     barf("scavenge_one: strange object");
1560   }
1561
1562   no_luck = failed_to_evac;
1563   failed_to_evac = rtsFalse;
1564   return (no_luck);
1565 }
1566
1567
1568 /* -----------------------------------------------------------------------------
1569    Scavenging mutable lists.
1570
1571    We treat the mutable list of each generation > N (i.e. all the
1572    generations older than the one being collected) as roots.  We also
1573    remove non-mutable objects from the mutable list at this point.
1574    -------------------------------------------------------------------------- */
1575
1576 static StgMutClosure *
1577 scavenge_mutable_list(StgMutClosure *p, nat gen)
1578 {
1579   StgInfoTable *info;
1580   StgMutClosure *start;
1581   StgMutClosure **prev;
1582
1583   evac_gen = 0;
1584
1585   prev = &start;
1586   start = p;
1587
1588   failed_to_evac = rtsFalse;
1589
1590   for (; p != END_MUT_LIST; p = *prev) {
1591
1592     /* make sure the info pointer is into text space */
1593     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1594                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1595
1596     info = get_itbl(p);
1597     switch(info->type) {
1598
1599     case MUT_ARR_PTRS_FROZEN:
1600       /* remove this guy from the mutable list, but follow the ptrs
1601        * anyway (and make sure they get promoted to this gen).
1602        */
1603       {
1604         StgPtr end, q;
1605
1606         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1607         evac_gen = gen;
1608         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1609           (StgClosure *)*q = evacuate((StgClosure *)*q);
1610         }
1611         evac_gen = 0;
1612
1613         if (failed_to_evac) {
1614           failed_to_evac = rtsFalse;
1615           prev = &p->mut_link;
1616         } else {
1617           *prev = p->mut_link;
1618         }
1619         continue;
1620       }
1621
1622     case MUT_ARR_PTRS:
1623       /* follow everything */
1624       prev = &p->mut_link;
1625       {
1626         StgPtr end, q;
1627
1628         end = (P_)p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1629         for (q = (P_)((StgMutArrPtrs *)p)->payload; q < end; q++) {
1630           (StgClosure *)*q = evacuate((StgClosure *)*q);
1631         }
1632         continue;
1633       }
1634
1635     case MUT_VAR:
1636       /* MUT_CONS is a kind of MUT_VAR, except that we try to remove
1637        * it from the mutable list if possible by promoting whatever it
1638        * points to.
1639        */
1640       if (p->header.info == &MUT_CONS_info) {
1641         evac_gen = gen;
1642         if (scavenge_one((P_)((StgMutVar *)p)->var) == rtsTrue) {
1643           /* didn't manage to promote everything, so leave the
1644            * MUT_CONS on the list.
1645            */
1646           prev = &p->mut_link;
1647         } else {
1648           *prev = p->mut_link;
1649         }
1650         evac_gen = 0;
1651       } else {
1652         ((StgMutVar *)p)->var = evacuate(((StgMutVar *)p)->var);
1653         prev = &p->mut_link;
1654       }
1655       continue;
1656
1657     case TSO:
1658       /* follow ptrs and remove this from the mutable list */
1659       {
1660         StgTSO *tso = (StgTSO *)p;
1661
1662         /* Don't bother scavenging if this thread is dead
1663          */
1664         if (!(tso->whatNext == ThreadComplete ||
1665               tso->whatNext == ThreadKilled)) {
1666           /* Don't need to chase the link field for any TSOs on the
1667            * same queue. Just scavenge this thread's stack
1668            */
1669           scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1670         }
1671
1672         /* Don't take this TSO off the mutable list - it might still
1673          * point to some younger objects (because we set evac_gen to 0
1674          * above).
1675          */
1676         prev = &tso->mut_link;
1677         continue;
1678       }
1679
1680     case IND_OLDGEN:
1681     case IND_OLDGEN_PERM:
1682     case IND_STATIC:
1683       /* Try to pull the indirectee into this generation, so we can
1684        * remove the indirection from the mutable list.
1685        */
1686       evac_gen = gen;
1687       ((StgIndOldGen *)p)->indirectee =
1688         evacuate(((StgIndOldGen *)p)->indirectee);
1689       evac_gen = 0;
1690
1691       if (failed_to_evac) {
1692         failed_to_evac = rtsFalse;
1693         prev = &p->mut_link;
1694       } else {
1695         *prev = p->mut_link;
1696         /* the mut_link field of an IND_STATIC is overloaded as the
1697          * static link field too (it just so happens that we don't need
1698          * both at the same time), so we need to NULL it out when
1699          * removing this object from the mutable list because the static
1700          * link fields are all assumed to be NULL before doing a major
1701          * collection.
1702          */
1703         p->mut_link = NULL;
1704       }
1705       continue;
1706
1707     default:
1708       /* shouldn't have anything else on the mutables list */
1709       barf("scavenge_mutable_object: non-mutable object?");
1710     }
1711   }
1712   return start;
1713 }
1714
1715 static void
1716 scavenge_static(void)
1717 {
1718   StgClosure* p = static_objects;
1719   const StgInfoTable *info;
1720
1721   /* Always evacuate straight to the oldest generation for static
1722    * objects */
1723   evac_gen = oldest_gen->no;
1724
1725   /* keep going until we've scavenged all the objects on the linked
1726      list... */
1727   while (p != END_OF_STATIC_LIST) {
1728
1729     info = get_itbl(p);
1730
1731     /* make sure the info pointer is into text space */
1732     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1733                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1734
1735     /* Take this object *off* the static_objects list,
1736      * and put it on the scavenged_static_objects list.
1737      */
1738     static_objects = STATIC_LINK(info,p);
1739     STATIC_LINK(info,p) = scavenged_static_objects;
1740     scavenged_static_objects = p;
1741
1742     switch (info -> type) {
1743
1744     case IND_STATIC:
1745       {
1746         StgInd *ind = (StgInd *)p;
1747         ind->indirectee = evacuate(ind->indirectee);
1748
1749         /* might fail to evacuate it, in which case we have to pop it
1750          * back on the mutable list (and take it off the
1751          * scavenged_static list because the static link and mut link
1752          * pointers are one and the same).
1753          */
1754         if (failed_to_evac) {
1755           failed_to_evac = rtsFalse;
1756           scavenged_static_objects = STATIC_LINK(info,p);
1757           ((StgMutClosure *)ind)->mut_link = oldest_gen->mut_list;
1758           oldest_gen->mut_list = (StgMutClosure *)ind;
1759         }
1760         break;
1761       }
1762
1763     case THUNK_STATIC:
1764     case FUN_STATIC:
1765       scavenge_srt(info);
1766       /* fall through */
1767
1768     case CONSTR_STATIC:
1769       {
1770         StgPtr q, next;
1771
1772         next = (P_)p->payload + info->layout.payload.ptrs;
1773         /* evacuate the pointers */
1774         for (q = (P_)p->payload; q < next; q++) {
1775           (StgClosure *)*q = evacuate((StgClosure *)*q);
1776         }
1777         break;
1778       }
1779
1780     default:
1781       barf("scavenge_static");
1782     }
1783
1784     ASSERT(failed_to_evac == rtsFalse);
1785
1786     /* get the next static object from the list.  Remeber, there might
1787      * be more stuff on this list now that we've done some evacuating!
1788      * (static_objects is a global)
1789      */
1790     p = static_objects;
1791   }
1792 }
1793
1794 /* -----------------------------------------------------------------------------
1795    scavenge_stack walks over a section of stack and evacuates all the
1796    objects pointed to by it.  We can use the same code for walking
1797    PAPs, since these are just sections of copied stack.
1798    -------------------------------------------------------------------------- */
1799
1800 static void
1801 scavenge_stack(StgPtr p, StgPtr stack_end)
1802 {
1803   StgPtr q;
1804   const StgInfoTable* info;
1805   StgNat32 bitmap;
1806
1807   /*
1808    * Each time around this loop, we are looking at a chunk of stack
1809    * that starts with either a pending argument section or an
1810    * activation record.
1811    */
1812
1813   while (p < stack_end) {
1814     q = *stgCast(StgPtr*,p);
1815
1816     /* If we've got a tag, skip over that many words on the stack */
1817     if (IS_ARG_TAG(stgCast(StgWord,q))) {
1818       p += ARG_SIZE(q);
1819       p++; continue;
1820     }
1821
1822     /* Is q a pointer to a closure?
1823      */
1824     if (! LOOKS_LIKE_GHC_INFO(q)) {
1825
1826 #ifdef DEBUG
1827       if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
1828         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
1829       }
1830       /* otherwise, must be a pointer into the allocation space.
1831        */
1832 #endif
1833
1834       (StgClosure *)*p = evacuate((StgClosure *)q);
1835       p++;
1836       continue;
1837     }
1838
1839     /*
1840      * Otherwise, q must be the info pointer of an activation
1841      * record.  All activation records have 'bitmap' style layout
1842      * info.
1843      */
1844     info  = get_itbl(stgCast(StgClosure*,p));
1845
1846     switch (info->type) {
1847
1848       /* Dynamic bitmap: the mask is stored on the stack */
1849     case RET_DYN:
1850       bitmap = stgCast(StgRetDyn*,p)->liveness;
1851       p      = &payloadWord(stgCast(StgRetDyn*,p),0);
1852       goto small_bitmap;
1853
1854       /* probably a slow-entry point return address: */
1855     case FUN:
1856     case FUN_STATIC:
1857       p++;
1858       goto follow_srt;
1859
1860       /* Specialised code for update frames, since they're so common.
1861        * We *know* the updatee points to a BLACKHOLE or CAF_BLACKHOLE,
1862        * so just inline the code to evacuate it here.
1863        */
1864     case UPDATE_FRAME:
1865       {
1866         StgUpdateFrame *frame = (StgUpdateFrame *)p;
1867         StgClosure *to;
1868         StgClosureType type = get_itbl(frame->updatee)->type;
1869
1870         p += sizeofW(StgUpdateFrame);
1871         if (type == EVACUATED) {
1872           frame->updatee = evacuate(frame->updatee);
1873           continue;
1874         } else {
1875           bdescr *bd = Bdescr((P_)frame->updatee);
1876           ASSERT(type == BLACKHOLE || type == CAF_BLACKHOLE);
1877           if (bd->gen->no >= evac_gen && bd->gen->no > N) { continue; }
1878           to = copy(frame->updatee, BLACKHOLE_sizeW(), bd);
1879           upd_evacuee(frame->updatee,to);
1880           frame->updatee = to;
1881           continue;
1882         }
1883       }
1884
1885       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
1886     case RET_BCO:
1887     case RET_SMALL:
1888     case RET_VEC_SMALL:
1889     case STOP_FRAME:
1890     case CATCH_FRAME:
1891     case SEQ_FRAME:
1892       bitmap = info->layout.bitmap;
1893       p++;
1894     small_bitmap:
1895       while (bitmap != 0) {
1896         if ((bitmap & 1) == 0) {
1897           (StgClosure *)*p = evacuate((StgClosure *)*p);
1898         }
1899         p++;
1900         bitmap = bitmap >> 1;
1901       }
1902
1903     follow_srt:
1904       scavenge_srt(info);
1905       continue;
1906
1907       /* large bitmap (> 32 entries) */
1908     case RET_BIG:
1909     case RET_VEC_BIG:
1910       {
1911         StgPtr q;
1912         StgLargeBitmap *large_bitmap;
1913         nat i;
1914
1915         large_bitmap = info->layout.large_bitmap;
1916         p++;
1917
1918         for (i=0; i<large_bitmap->size; i++) {
1919           bitmap = large_bitmap->bitmap[i];
1920           q = p + sizeof(W_) * 8;
1921           while (bitmap != 0) {
1922             if ((bitmap & 1) == 0) {
1923               (StgClosure *)*p = evacuate((StgClosure *)*p);
1924             }
1925             p++;
1926             bitmap = bitmap >> 1;
1927           }
1928           if (i+1 < large_bitmap->size) {
1929             while (p < q) {
1930               (StgClosure *)*p = evacuate((StgClosure *)*p);
1931               p++;
1932             }
1933           }
1934         }
1935
1936         /* and don't forget to follow the SRT */
1937         goto follow_srt;
1938       }
1939
1940     default:
1941       barf("scavenge_stack: weird activation record found on stack.\n");
1942     }
1943   }
1944 }
1945
1946 /*-----------------------------------------------------------------------------
1947   scavenge the large object list.
1948
1949   evac_gen set by caller; similar games played with evac_gen as with
1950   scavenge() - see comment at the top of scavenge().  Most large
1951   objects are (repeatedly) mutable, so most of the time evac_gen will
1952   be zero.
1953   --------------------------------------------------------------------------- */
1954
1955 static void
1956 scavenge_large(step *step)
1957 {
1958   bdescr *bd;
1959   StgPtr p;
1960   const StgInfoTable* info;
1961   nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */
1962
1963   evac_gen = 0;                 /* most objects are mutable */
1964   bd = step->new_large_objects;
1965
1966   for (; bd != NULL; bd = step->new_large_objects) {
1967
1968     /* take this object *off* the large objects list and put it on
1969      * the scavenged large objects list.  This is so that we can
1970      * treat new_large_objects as a stack and push new objects on
1971      * the front when evacuating.
1972      */
1973     step->new_large_objects = bd->link;
1974     dbl_link_onto(bd, &step->scavenged_large_objects);
1975
1976     p = bd->start;
1977     info  = get_itbl(stgCast(StgClosure*,p));
1978
1979     switch (info->type) {
1980
1981     /* only certain objects can be "large"... */
1982
1983     case ARR_WORDS:
1984     case MUT_ARR_WORDS:
1985       /* nothing to follow */
1986       continue;
1987
1988     case MUT_ARR_PTRS:
1989       /* follow everything */
1990       {
1991         StgPtr next;
1992
1993         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1994         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1995           (StgClosure *)*p = evacuate((StgClosure *)*p);
1996         }
1997         continue;
1998       }
1999
2000     case MUT_ARR_PTRS_FROZEN:
2001       /* follow everything */
2002       {
2003         StgPtr start = p, next;
2004
2005         evac_gen = saved_evac_gen; /* not really mutable */
2006         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
2007         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
2008           (StgClosure *)*p = evacuate((StgClosure *)*p);
2009         }
2010         evac_gen = 0;
2011         if (failed_to_evac) {
2012           evacuate_mutable((StgMutClosure *)start);
2013         }
2014         continue;
2015       }
2016
2017     case BCO:
2018       {
2019         StgBCO* bco = stgCast(StgBCO*,p);
2020         nat i;
2021         evac_gen = saved_evac_gen;
2022         for (i = 0; i < bco->n_ptrs; i++) {
2023           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
2024         }
2025         evac_gen = 0;
2026         continue;
2027       }
2028
2029     case TSO:
2030       {
2031         StgTSO *tso;
2032
2033         tso = (StgTSO *)p;
2034         /* chase the link field for any TSOs on the same queue */
2035         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
2036         /* scavenge this thread's stack */
2037         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
2038         continue;
2039       }
2040
2041     default:
2042       barf("scavenge_large: unknown/strange object");
2043     }
2044   }
2045 }
2046
2047 static void
2048 zeroStaticObjectList(StgClosure* first_static)
2049 {
2050   StgClosure* p;
2051   StgClosure* link;
2052   const StgInfoTable *info;
2053
2054   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
2055     info = get_itbl(p);
2056     link = STATIC_LINK(info, p);
2057     STATIC_LINK(info,p) = NULL;
2058   }
2059 }
2060
2061 /* This function is only needed because we share the mutable link
2062  * field with the static link field in an IND_STATIC, so we have to
2063  * zero the mut_link field before doing a major GC, which needs the
2064  * static link field.
2065  *
2066  * It doesn't do any harm to zero all the mutable link fields on the
2067  * mutable list.
2068  */
2069 static void
2070 zeroMutableList(StgMutClosure *first)
2071 {
2072   StgMutClosure *next, *c;
2073
2074   for (c = first; c != END_MUT_LIST; c = next) {
2075     next = c->mut_link;
2076     c->mut_link = NULL;
2077   }
2078 }
2079
2080 /* -----------------------------------------------------------------------------
2081    Reverting CAFs
2082    -------------------------------------------------------------------------- */
2083
2084 void RevertCAFs(void)
2085 {
2086   while (enteredCAFs != END_CAF_LIST) {
2087     StgCAF* caf = enteredCAFs;
2088
2089     enteredCAFs = caf->link;
2090     ASSERT(get_itbl(caf)->type == CAF_ENTERED);
2091     SET_INFO(caf,&CAF_UNENTERED_info);
2092     caf->value = stgCast(StgClosure*,0xdeadbeef);
2093     caf->link  = stgCast(StgCAF*,0xdeadbeef);
2094   }
2095 }
2096
2097 void revertDeadCAFs(void)
2098 {
2099     StgCAF* caf = enteredCAFs;
2100     enteredCAFs = END_CAF_LIST;
2101     while (caf != END_CAF_LIST) {
2102         StgCAF* next = caf->link;
2103
2104         switch(GET_INFO(caf)->type) {
2105         case EVACUATED:
2106             {
2107                 /* This object has been evacuated, it must be live. */
2108                 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
2109                 new->link = enteredCAFs;
2110                 enteredCAFs = new;
2111                 break;
2112             }
2113         case CAF_ENTERED:
2114             {
2115                 SET_INFO(caf,&CAF_UNENTERED_info);
2116                 caf->value = stgCast(StgClosure*,0xdeadbeef);
2117                 caf->link  = stgCast(StgCAF*,0xdeadbeef);
2118                 break;
2119             }
2120         default:
2121                 barf("revertDeadCAFs: enteredCAFs list corrupted");
2122         }
2123         caf = next;
2124     }
2125 }
2126
2127 /* -----------------------------------------------------------------------------
2128    Sanity code for CAF garbage collection.
2129
2130    With DEBUG turned on, we manage a CAF list in addition to the SRT
2131    mechanism.  After GC, we run down the CAF list and blackhole any
2132    CAFs which have been garbage collected.  This means we get an error
2133    whenever the program tries to enter a garbage collected CAF.
2134
2135    Any garbage collected CAFs are taken off the CAF list at the same
2136    time.
2137    -------------------------------------------------------------------------- */
2138
2139 #ifdef DEBUG
2140 static void
2141 gcCAFs(void)
2142 {
2143   StgClosure*  p;
2144   StgClosure** pp;
2145   const StgInfoTable *info;
2146   nat i;
2147
2148   i = 0;
2149   p = caf_list;
2150   pp = &caf_list;
2151
2152   while (p != NULL) {
2153
2154     info = get_itbl(p);
2155
2156     ASSERT(info->type == IND_STATIC);
2157
2158     if (STATIC_LINK(info,p) == NULL) {
2159       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
2160       /* black hole it */
2161       SET_INFO(p,&BLACKHOLE_info);
2162       p = STATIC_LINK2(info,p);
2163       *pp = p;
2164     }
2165     else {
2166       pp = &STATIC_LINK2(info,p);
2167       p = *pp;
2168       i++;
2169     }
2170
2171   }
2172
2173   /*  fprintf(stderr, "%d CAFs live\n", i); */
2174 }
2175 #endif
2176
2177 /* -----------------------------------------------------------------------------
2178    Lazy black holing.
2179
2180    Whenever a thread returns to the scheduler after possibly doing
2181    some work, we have to run down the stack and black-hole all the
2182    closures referred to by update frames.
2183    -------------------------------------------------------------------------- */
2184
2185 static void
2186 threadLazyBlackHole(StgTSO *tso)
2187 {
2188   StgUpdateFrame *update_frame;
2189   StgBlackHole *bh;
2190   StgPtr stack_end;
2191
2192   stack_end = &tso->stack[tso->stack_size];
2193   update_frame = tso->su;
2194
2195   while (1) {
2196     switch (get_itbl(update_frame)->type) {
2197
2198     case CATCH_FRAME:
2199       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
2200       break;
2201
2202     case UPDATE_FRAME:
2203       bh = stgCast(StgBlackHole*,update_frame->updatee);
2204
2205       /* if the thunk is already blackholed, it means we've also
2206        * already blackholed the rest of the thunks on this stack,
2207        * so we can stop early.
2208        */
2209
2210       /* Don't for now: when we enter a CAF, we create a black hole on
2211        * the heap and make the update frame point to it.  Thus the
2212        * above optimisation doesn't apply.
2213        */
2214       if (bh->header.info != &BLACKHOLE_info
2215           && bh->header.info != &CAF_BLACKHOLE_info) {
2216         SET_INFO(bh,&BLACKHOLE_info);
2217         bh->blocking_queue = END_TSO_QUEUE;
2218       }
2219
2220       update_frame = update_frame->link;
2221       break;
2222
2223     case SEQ_FRAME:
2224       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
2225       break;
2226
2227     case STOP_FRAME:
2228       return;
2229     default:
2230       barf("threadPaused");
2231     }
2232   }
2233 }
2234
2235 /* -----------------------------------------------------------------------------
2236  * Stack squeezing
2237  *
2238  * Code largely pinched from old RTS, then hacked to bits.  We also do
2239  * lazy black holing here.
2240  *
2241  * -------------------------------------------------------------------------- */
2242
2243 static void
2244 threadSqueezeStack(StgTSO *tso)
2245 {
2246   lnat displacement = 0;
2247   StgUpdateFrame *frame;
2248   StgUpdateFrame *next_frame;                   /* Temporally next */
2249   StgUpdateFrame *prev_frame;                   /* Temporally previous */
2250   StgPtr bottom;
2251   rtsBool prev_was_update_frame;
2252
2253   bottom = &(tso->stack[tso->stack_size]);
2254   frame  = tso->su;
2255
2256   /* There must be at least one frame, namely the STOP_FRAME.
2257    */
2258   ASSERT((P_)frame < bottom);
2259
2260   /* Walk down the stack, reversing the links between frames so that
2261    * we can walk back up as we squeeze from the bottom.  Note that
2262    * next_frame and prev_frame refer to next and previous as they were
2263    * added to the stack, rather than the way we see them in this
2264    * walk. (It makes the next loop less confusing.)
2265    *
2266    * Could stop if we find an update frame pointing to a black hole,
2267    * but see comment in threadLazyBlackHole().
2268    */
2269
2270   next_frame = NULL;
2271   while ((P_)frame < bottom - 1) {  /* bottom - 1 is the STOP_FRAME */
2272     prev_frame = frame->link;
2273     frame->link = next_frame;
2274     next_frame = frame;
2275     frame = prev_frame;
2276   }
2277
2278   /* Now, we're at the bottom.  Frame points to the lowest update
2279    * frame on the stack, and its link actually points to the frame
2280    * above. We have to walk back up the stack, squeezing out empty
2281    * update frames and turning the pointers back around on the way
2282    * back up.
2283    *
2284    * The bottom-most frame (the STOP_FRAME) has not been altered, and
2285    * we never want to eliminate it anyway.  Just walk one step up
2286    * before starting to squeeze. When you get to the topmost frame,
2287    * remember that there are still some words above it that might have
2288    * to be moved.
2289    */
2290
2291   prev_frame = frame;
2292   frame = next_frame;
2293
2294   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
2295
2296   /*
2297    * Loop through all of the frames (everything except the very
2298    * bottom).  Things are complicated by the fact that we have
2299    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
2300    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
2301    */
2302   while (frame != NULL) {
2303     StgPtr sp;
2304     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
2305     rtsBool is_update_frame;
2306
2307     next_frame = frame->link;
2308     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
2309
2310     /* Check to see if
2311      *   1. both the previous and current frame are update frames
2312      *   2. the current frame is empty
2313      */
2314     if (prev_was_update_frame && is_update_frame &&
2315         (P_)prev_frame == frame_bottom + displacement) {
2316
2317       /* Now squeeze out the current frame */
2318       StgClosure *updatee_keep   = prev_frame->updatee;
2319       StgClosure *updatee_bypass = frame->updatee;
2320
2321 #if 0 /* DEBUG */
2322       fprintf(stderr, "squeezing frame at %p\n", frame);
2323 #endif
2324
2325       /* Deal with blocking queues.  If both updatees have blocked
2326        * threads, then we should merge the queues into the update
2327        * frame that we're keeping.
2328        *
2329        * Alternatively, we could just wake them up: they'll just go
2330        * straight to sleep on the proper blackhole!  This is less code
2331        * and probably less bug prone, although it's probably much
2332        * slower --SDM
2333        */
2334 #if 0 /* do it properly... */
2335       if (GET_INFO(updatee_bypass) == BLACKHOLE_info
2336           || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
2337           ) {
2338         /* Sigh.  It has one.  Don't lose those threads! */
2339         if (GET_INFO(updatee_keep) == BLACKHOLE_info
2340             || GET_INFO(updatee_keep) == CAF_BLACKHOLE_info
2341             ) {
2342           /* Urgh.  Two queues.  Merge them. */
2343           P_ keep_tso = ((StgBlackHole *)updatee_keep)->blocking_queue;
2344
2345           while (keep_tso->link != END_TSO_QUEUE) {
2346             keep_tso = keep_tso->link;
2347           }
2348           keep_tso->link = ((StgBlackHole *)updatee_bypass)->blocking_queue;
2349
2350         } else {
2351           /* For simplicity, just swap the BQ for the BH */
2352           P_ temp = updatee_keep;
2353
2354           updatee_keep = updatee_bypass;
2355           updatee_bypass = temp;
2356
2357           /* Record the swap in the kept frame (below) */
2358           prev_frame->updatee = updatee_keep;
2359         }
2360       }
2361 #endif
2362
2363       TICK_UPD_SQUEEZED();
2364       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
2365
2366       sp = (P_)frame - 1;       /* sp = stuff to slide */
2367       displacement += sizeofW(StgUpdateFrame);
2368
2369     } else {
2370       /* No squeeze for this frame */
2371       sp = frame_bottom - 1;    /* Keep the current frame */
2372
2373       /* Do lazy black-holing.
2374        */
2375       if (is_update_frame) {
2376         StgBlackHole *bh = (StgBlackHole *)frame->updatee;
2377         if (bh->header.info != &BLACKHOLE_info
2378             && bh->header.info != &CAF_BLACKHOLE_info
2379             ) {
2380           SET_INFO(bh,&BLACKHOLE_info);
2381           bh->blocking_queue = END_TSO_QUEUE;
2382         }
2383       }
2384
2385       /* Fix the link in the current frame (should point to the frame below) */
2386       frame->link = prev_frame;
2387       prev_was_update_frame = is_update_frame;
2388     }
2389
2390     /* Now slide all words from sp up to the next frame */
2391
2392     if (displacement > 0) {
2393       P_ next_frame_bottom;
2394
2395       if (next_frame != NULL)
2396         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
2397       else
2398         next_frame_bottom = tso->sp - 1;
2399
2400 #if 0 /* DEBUG */
2401       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
2402               displacement);
2403 #endif
2404
2405       while (sp >= next_frame_bottom) {
2406         sp[displacement] = *sp;
2407         sp -= 1;
2408       }
2409     }
2410     (P_)prev_frame = (P_)frame + displacement;
2411     frame = next_frame;
2412   }
2413
2414   tso->sp += displacement;
2415   tso->su = prev_frame;
2416 }
2417
2418 /* -----------------------------------------------------------------------------
2419  * Pausing a thread
2420  *
2421  * We have to prepare for GC - this means doing lazy black holing
2422  * here.  We also take the opportunity to do stack squeezing if it's
2423  * turned on.
2424  * -------------------------------------------------------------------------- */
2425
2426 void
2427 threadPaused(StgTSO *tso)
2428 {
2429   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
2430     threadSqueezeStack(tso);    /* does black holing too */
2431   else
2432     threadLazyBlackHole(tso);
2433 }