ghc/rts/GC.c

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