ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.5 1999/01/06 12:27:47 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 P_ toHp;                 /* to-space heap pointer */
  27 static P_ toHpLim;              /* end of current to-space block */
  28 static bdescr *toHp_bd;         /* descriptor of current to-space block  */
  29 static nat blocks = 0;          /* number of to-space blocks allocated */
  30 static bdescr *old_to_space = NULL; /* to-space from the last GC */
  31 static nat old_to_space_blocks = 0; /* size of previous to-space */
  32
  33 /* STATIC OBJECT LIST.
  34  *
  35  * We maintain a linked list of static objects that are still live.
  36  * The requirements for this list are:
  37  *
  38  *  - we need to scan the list while adding to it, in order to
  39  *    scavenge all the static objects (in the same way that
  40  *    breadth-first scavenging works for dynamic objects).
  41  *
  42  *  - we need to be able to tell whether an object is already on
  43  *    the list, to break loops.
  44  *
  45  * Each static object has a "static link field", which we use for
  46  * linking objects on to the list.  We use a stack-type list, consing
  47  * objects on the front as they are added (this means that the
  48  * scavenge phase is depth-first, not breadth-first, but that
  49  * shouldn't matter).
  50  *
  51  * A separate list is kept for objects that have been scavenged
  52  * already - this is so that we can zero all the marks afterwards.
  53  *
  54  * An object is on the list if its static link field is non-zero; this
  55  * means that we have to mark the end of the list with '1', not NULL.
  56  */
  57 #define END_OF_STATIC_LIST stgCast(StgClosure*,1)
  58 static StgClosure* static_objects;
  59 static StgClosure* scavenged_static_objects;
  60
  61 /* WEAK POINTERS
  62  */
  63 static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
  64 static rtsBool weak_done;       /* all done for this pass */
  65
  66 /* LARGE OBJECTS.
  67  */
  68 static bdescr *new_large_objects; /* large objects evacuated so far */
  69 static bdescr *scavenged_large_objects; /* large objects scavenged */
  70
  71 /* -----------------------------------------------------------------------------
  72    Static function declarations
  73    -------------------------------------------------------------------------- */
  74
  75 static StgClosure *evacuate(StgClosure *q);
  76 static void    zeroStaticObjectList(StgClosure* first_static);
  77 static void    scavenge_stack(StgPtr p, StgPtr stack_end);
  78 static void    scavenge_static(void);
  79 static void    scavenge_large(void);
  80 static StgPtr  scavenge(StgPtr to_scan);
  81 static rtsBool traverse_weak_ptr_list(void);
  82 static void    revertDeadCAFs(void);
  83
  84 #ifdef DEBUG
  85 static void gcCAFs(void);
  86 #endif
  87
  88 /* -----------------------------------------------------------------------------
  89    GarbageCollect
  90
  91    This function performs a full copying garbage collection.
  92    -------------------------------------------------------------------------- */
  93
  94 void GarbageCollect(void (*get_roots)(void))
  95 {
  96   bdescr *bd, *scan_bd, *to_space;
  97   StgPtr scan;
  98   lnat allocated, live;
  99   nat old_nursery_blocks = nursery_blocks;       /* for stats */
 100   nat old_live_blocks    = old_to_space_blocks;  /* ditto */
 101 #ifdef PROFILING
 102   CostCentreStack *prev_CCS;
 103 #endif
 104
 105   /* tell the stats department that we've started a GC */
 106   stat_startGC();
 107
 108   /* attribute any costs to CCS_GC */
 109 #ifdef PROFILING
 110   prev_CCS = CCCS;
 111   CCCS = CCS_GC;
 112 #endif
 113
 114   /* We might have been called from Haskell land by _ccall_GC, in
 115    * which case we need to call threadPaused() because the scheduler
 116    * won't have done it.
 117    */
 118   if (CurrentTSO)
 119     threadPaused(CurrentTSO);
 120
 121   /* Approximate how much we allocated: number of blocks in the
 122    * nursery + blocks allocated via allocate() - unused nusery blocks.
 123    * This leaves a little slop at the end of each block, and doesn't
 124    * take into account large objects (ToDo).
 125    */
 126   allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
 127   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
 128     allocated -= BLOCK_SIZE_W;
 129   }
 130
 131   /* check stack sanity *before* GC (ToDo: check all threads) */
 132   /*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
 133   IF_DEBUG(sanity, checkFreeListSanity());
 134
 135   static_objects = END_OF_STATIC_LIST;
 136   scavenged_static_objects = END_OF_STATIC_LIST;
 137
 138   new_large_objects = NULL;
 139   scavenged_large_objects = NULL;
 140
 141   /* Get a free block for to-space.  Extra blocks will be chained on
 142    * as necessary.
 143    */
 144   bd = allocBlock();
 145   bd->step = 1;                 /* step 1 identifies to-space */
 146   toHp = bd->start;
 147   toHpLim = toHp + BLOCK_SIZE_W;
 148   toHp_bd = bd;
 149   to_space = bd;
 150   blocks = 0;
 151
 152   scan = toHp;
 153   scan_bd = bd;
 154
 155   /* follow all the roots that the application knows about */
 156   get_roots();
 157
 158   /* And don't forget to mark the TSO if we got here direct from
 159    * Haskell! */
 160   if (CurrentTSO) {
 161     CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
 162   }
 163
 164   /* Mark the weak pointer list, and prepare to detect dead weak
 165    * pointers.
 166    */
 167   markWeakList();
 168   old_weak_ptr_list = weak_ptr_list;
 169   weak_ptr_list = NULL;
 170   weak_done = rtsFalse;
 171
 172 #ifdef INTERPRETER
 173   {
 174       /* ToDo: To fix the caf leak, we need to make the commented out
 175        * parts of this code do something sensible - as described in
 176        * the CAF document.
 177        */
 178       extern void markHugsObjects(void);
 179 #if 0
 180       /* ToDo: This (undefined) function should contain the scavenge
 181        * loop immediately below this block of code - but I'm not sure
 182        * enough of the details to do this myself.
 183        */
 184       scavengeEverything();
 185       /* revert dead CAFs and update enteredCAFs list */
 186       revertDeadCAFs();
 187 #endif
 188       markHugsObjects();
 189 #if 0
 190       /* This will keep the CAFs and the attached BCOs alive
 191        * but the values will have been reverted
 192        */
 193       scavengeEverything();
 194 #endif
 195   }
 196 #endif
 197
 198   /* Then scavenge all the objects we picked up on the first pass.
 199    * We may require multiple passes to find all the static objects,
 200    * large objects and normal objects.
 201    */
 202   {
 203   loop:
 204     if (static_objects != END_OF_STATIC_LIST) {
 205       scavenge_static();
 206     }
 207     if (toHp_bd != scan_bd || scan < toHp) {
 208       scan = scavenge(scan);
 209       scan_bd = Bdescr(scan);
 210       goto loop;
 211     }
 212     if (new_large_objects != NULL) {
 213       scavenge_large();
 214       goto loop;
 215     }
 216     /* must be last... */
 217     if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
 218       goto loop;
 219     }
 220   }
 221
 222   /* tidy up the end of the to-space chain */
 223   toHp_bd->free = toHp;
 224   toHp_bd->link = NULL;
 225
 226   /* revert dead CAFs and update enteredCAFs list */
 227   revertDeadCAFs();
 228
 229   /* mark the garbage collected CAFs as dead */
 230 #ifdef DEBUG
 231   gcCAFs();
 232 #endif
 233
 234   zeroStaticObjectList(scavenged_static_objects);
 235
 236   /* approximate amount of live data (doesn't take into account slop
 237    * at end of each block).  ToDo: this more accurately.
 238    */
 239   live = blocks * BLOCK_SIZE_W + ((lnat)toHp_bd->free -
 240                                   (lnat)toHp_bd->start) / sizeof(W_);
 241
 242   /* Free the to-space from the last GC, as it has now been collected.
 243    * we may be able to re-use these blocks in creating a new nursery,
 244    * below.  If not, the blocks will probably be re-used for to-space
 245    * in the next GC.
 246    */
 247   if (old_to_space != NULL) {
 248     freeChain(old_to_space);
 249   }
 250   old_to_space = to_space;
 251   old_to_space_blocks = blocks;
 252
 253   /* Free the small objects allocated via allocate(), since this will
 254    * all have been copied into to-space now.
 255    */
 256   if (small_alloc_list != NULL) {
 257     freeChain(small_alloc_list);
 258   }
 259   small_alloc_list = NULL;
 260   alloc_blocks = 0;
 261   alloc_blocks_lim = stg_max(blocks,RtsFlags.GcFlags.minAllocAreaSize);
 262
 263   /* LARGE OBJECTS.  The current live large objects are chained on
 264    * scavenged_large_objects, having been moved during garbage
 265    * collection from large_alloc_list.  Any objects left on
 266    * large_alloc list are therefore dead, so we free them here.
 267    */
 268   {
 269     bdescr *bd, *next;
 270     bd = large_alloc_list;
 271     while (bd != NULL) {
 272       next = bd->link;
 273       freeGroup(bd);
 274       bd = next;
 275     }
 276     large_alloc_list = scavenged_large_objects;
 277   }
 278
 279
 280   /* check sanity after GC */
 281   IF_DEBUG(sanity, checkHeap(to_space,1));
 282   /*IF_DEBUG(sanity, checkTSO(MainTSO,1)); */
 283   IF_DEBUG(sanity, checkFreeListSanity());
 284
 285 #ifdef DEBUG
 286   /* symbol-table based profiling */
 287   heapCensus(to_space);
 288 #endif
 289
 290   /* set up a new nursery.  Allocate a nursery size based on a
 291    * function of the amount of live data (currently a factor of 2,
 292    * should be configurable (ToDo)).  Use the blocks from the old
 293    * nursery if possible, freeing up any left over blocks.
 294    *
 295    * If we get near the maximum heap size, then adjust our nursery
 296    * size accordingly.  If the nursery is the same size as the live
 297    * data (L), then we need 3L bytes.  We can reduce the size of the
 298    * nursery to bring the required memory down near 2L bytes.
 299    *
 300    * A normal 2-space collector would need 4L bytes to give the same
 301    * performance we get from 3L bytes, reducing to the same
 302    * performance at 2L bytes.
 303    */
 304   if ( blocks * 4 > RtsFlags.GcFlags.maxHeapSize ) {
 305     int adjusted_blocks;  /* signed on purpose */
 306     int pc_free;
 307
 308     adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
 309     IF_DEBUG(gc, fprintf(stderr, "Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %d\n", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
 310     pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
 311     if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
 312       heapOverflow();
 313     }
 314     blocks = adjusted_blocks;
 315
 316   } else {
 317     blocks *= 2;
 318     if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
 319      blocks = RtsFlags.GcFlags.minAllocAreaSize;
 320     }
 321   }
 322
 323   if (nursery_blocks < blocks) {
 324     IF_DEBUG(gc, fprintf(stderr, "Increasing size of nursery to %d blocks\n",
 325                          blocks));
 326     nursery = allocNursery(nursery,blocks-nursery_blocks);
 327   } else {
 328     bdescr *next_bd = nursery;
 329
 330     IF_DEBUG(gc, fprintf(stderr, "Decreasing size of nursery to %d blocks\n",
 331                          blocks));
 332     for (bd = nursery; nursery_blocks > blocks; nursery_blocks--) {
 333       next_bd = bd->link;
 334       freeGroup(bd);
 335       bd = next_bd;
 336     }
 337     nursery = bd;
 338   }
 339
 340   current_nursery = nursery;
 341   nursery_blocks = blocks;
 342
 343   /* set the step number for each block in the nursery to zero */
 344   for (bd = nursery; bd != NULL; bd = bd->link) {
 345     bd->step = 0;
 346     bd->free = bd->start;
 347   }
 348   for (bd = to_space; bd != NULL; bd = bd->link) {
 349     bd->step = 0;
 350   }
 351   for (bd = large_alloc_list; bd != NULL; bd = bd->link) {
 352     bd->step = 0;
 353   }
 354
 355 #ifdef DEBUG
 356   /* check that we really have the right number of blocks in the
 357    * nursery, or things could really get screwed up.
 358    */
 359   {
 360     nat i = 0;
 361     for (bd = nursery; bd != NULL; bd = bd->link) {
 362       ASSERT(bd->free == bd->start);
 363       ASSERT(bd->step == 0);
 364       i++;
 365     }
 366     ASSERT(i == nursery_blocks);
 367   }
 368 #endif
 369
 370   /* start any pending finalisers */
 371   scheduleFinalisers(old_weak_ptr_list);
 372
 373   /* restore enclosing cost centre */
 374 #ifdef PROFILING
 375   CCCS = prev_CCS;
 376 #endif
 377
 378   /* ok, GC over: tell the stats department what happened. */
 379   stat_endGC(allocated,
 380              (old_nursery_blocks + old_live_blocks) * BLOCK_SIZE_W,
 381              live, "");
 382 }
 383
 384 /* -----------------------------------------------------------------------------
 385    Weak Pointers
 386
 387    traverse_weak_ptr_list is called possibly many times during garbage
 388    collection.  It returns a flag indicating whether it did any work
 389    (i.e. called evacuate on any live pointers).
 390
 391    Invariant: traverse_weak_ptr_list is called when the heap is in an
 392    idempotent state.  That means that there are no pending
 393    evacuate/scavenge operations.  This invariant helps the weak
 394    pointer code decide which weak pointers are dead - if there are no
 395    new live weak pointers, then all the currently unreachable ones are
 396    dead.
 397    -------------------------------------------------------------------------- */
 398
 399 static rtsBool
 400 traverse_weak_ptr_list(void)
 401 {
 402   StgWeak *w, **last_w, *next_w;
 403   StgClosure *target;
 404   const StgInfoTable *info;
 405   rtsBool flag = rtsFalse;
 406
 407   if (weak_done) { return rtsFalse; }
 408
 409   last_w = &old_weak_ptr_list;
 410   for (w = old_weak_ptr_list; w; w = next_w) {
 411     target = w->key;
 412   loop:
 413     info = get_itbl(target);
 414     switch (info->type) {
 415
 416     case IND:
 417     case IND_STATIC:
 418     case IND_PERM:
 419     case IND_OLDGEN:
 420     case IND_OLDGEN_PERM:
 421       /* follow indirections */
 422       target = ((StgInd *)target)->indirectee;
 423       goto loop;
 424
 425     case EVACUATED:
 426       /* If key is alive, evacuate value and finaliser and
 427        * place weak ptr on new weak ptr list.
 428        */
 429       IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p\n", w));
 430       w->key = ((StgEvacuated *)target)->evacuee;
 431       w->value = evacuate(w->value);
 432       w->finaliser = evacuate(w->finaliser);
 433
 434       /* remove this weak ptr from the old_weak_ptr list */
 435       *last_w = w->link;
 436
 437       /* and put it on the new weak ptr list */
 438       next_w  = w->link;
 439       w->link = weak_ptr_list;
 440       weak_ptr_list = w;
 441       flag = rtsTrue;
 442       break;
 443
 444     default:                    /* key is dead */
 445       last_w = &(w->link);
 446       next_w = w->link;
 447       break;
 448     }
 449   }
 450
 451   /* If we didn't make any changes, then we can go round and kill all
 452    * the dead weak pointers.  The old_weak_ptr list is used as a list
 453    * of pending finalisers later on.
 454    */
 455   if (flag == rtsFalse) {
 456     for (w = old_weak_ptr_list; w; w = w->link) {
 457       w->value = evacuate(w->value);
 458       w->finaliser = evacuate(w->finaliser);
 459     }
 460     weak_done = rtsTrue;
 461   }
 462
 463   return rtsTrue;
 464 }
 465
 466 StgClosure *MarkRoot(StgClosure *root)
 467 {
 468   root = evacuate(root);
 469   return root;
 470 }
 471
 472 static __inline__ StgClosure *copy(StgClosure *src, W_ size)
 473 {
 474   P_ to, from, dest;
 475
 476   if (toHp + size >= toHpLim) {
 477     bdescr *bd = allocBlock();
 478     toHp_bd->free = toHp;
 479     toHp_bd->link = bd;
 480     bd->step = 1;               /* step 1 identifies to-space */
 481     toHp = bd->start;
 482     toHpLim = toHp + BLOCK_SIZE_W;
 483     toHp_bd = bd;
 484     blocks++;
 485   }
 486
 487   dest = toHp;
 488   toHp += size;
 489   for(to = dest, from = (P_)src; size>0; --size) {
 490     *to++ = *from++;
 491   }
 492   return (StgClosure *)dest;
 493 }
 494
 495 static __inline__ void upd_evacuee(StgClosure *p, StgClosure *dest)
 496 {
 497   StgEvacuated *q = (StgEvacuated *)p;
 498
 499   SET_INFO(q,&EVACUATED_info);
 500   q->evacuee = dest;
 501 }
 502
 503 /* -----------------------------------------------------------------------------
 504    Evacuate a large object
 505
 506    This just consists of removing the object from the (doubly-linked)
 507    large_alloc_list, and linking it on to the (singly-linked)
 508    new_large_objects list, from where it will be scavenged later.
 509    -------------------------------------------------------------------------- */
 510
 511 static inline void evacuate_large(StgPtr p)
 512 {
 513   bdescr *bd = Bdescr(p);
 514
 515   /* should point to the beginning of the block */
 516   ASSERT(((W_)p & BLOCK_MASK) == 0);
 517
 518   /* already evacuated? */
 519   if (bd->step == 1) {
 520     return;
 521   }
 522
 523   /* remove from large_alloc_list */
 524   if (bd->back) {
 525     bd->back->link = bd->link;
 526   } else { /* first object in the list */
 527     large_alloc_list = bd->link;
 528   }
 529   if (bd->link) {
 530     bd->link->back = bd->back;
 531   }
 532
 533   /* link it on to the evacuated large object list */
 534   bd->link = new_large_objects;
 535   new_large_objects = bd;
 536   bd->step = 1;
 537 }
 538
 539 /* -----------------------------------------------------------------------------
 540    Evacuate
 541
 542    This is called (eventually) for every live object in the system.
 543    -------------------------------------------------------------------------- */
 544
 545 static StgClosure *evacuate(StgClosure *q)
 546 {
 547   StgClosure *to;
 548   const StgInfoTable *info;
 549
 550 loop:
 551   /* make sure the info pointer is into text space */
 552   ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
 553                || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
 554
 555   info = get_itbl(q);
 556   switch (info -> type) {
 557
 558   case BCO:
 559     to = copy(q,bco_sizeW(stgCast(StgBCO*,q)));
 560     upd_evacuee(q,to);
 561     return to;
 562
 563   case FUN:
 564   case THUNK:
 565   case CONSTR:
 566   case IND_PERM:
 567   case IND_OLDGEN_PERM:
 568   case CAF_UNENTERED:
 569   case CAF_ENTERED:
 570   case WEAK:
 571   case FOREIGN:
 572   case MUT_VAR:
 573   case MVAR:
 574     to = copy(q,sizeW_fromITBL(info));
 575     upd_evacuee(q,to);
 576     return to;
 577
 578   case CAF_BLACKHOLE:
 579   case BLACKHOLE:
 580     to = copy(q,BLACKHOLE_sizeW());
 581     upd_evacuee(q,to);
 582     return to;
 583
 584   case THUNK_SELECTOR:
 585     {
 586       const StgInfoTable* selectee_info;
 587       StgClosure* selectee = stgCast(StgSelector*,q)->selectee;
 588
 589     selector_loop:
 590       selectee_info = get_itbl(selectee);
 591       switch (selectee_info->type) {
 592       case CONSTR:
 593       case CONSTR_STATIC:
 594         {
 595           StgNat32 offset = info->layout.selector_offset;
 596
 597           /* check that the size is in range */
 598           ASSERT(offset <
 599                  (StgNat32)(selectee_info->layout.payload.ptrs +
 600                             selectee_info->layout.payload.nptrs));
 601
 602           /* perform the selection! */
 603           q = selectee->payload[offset];
 604
 605           /* if we're already in to-space, there's no need to continue
 606            * with the evacuation, just update the source address with
 607            * a pointer to the (evacuated) constructor field.
 608            */
 609           if (IS_USER_PTR(q) && Bdescr((P_)q)->step == 1) {
 610             return q;
 611           }
 612
 613           /* otherwise, carry on and evacuate this constructor field,
 614            * (but not the constructor itself)
 615            */
 616           goto loop;
 617         }
 618
 619       case IND:
 620       case IND_STATIC:
 621       case IND_PERM:
 622       case IND_OLDGEN:
 623       case IND_OLDGEN_PERM:
 624         selectee = stgCast(StgInd *,selectee)->indirectee;
 625         goto selector_loop;
 626
 627       case CAF_ENTERED:
 628         selectee = stgCast(StgCAF *,selectee)->value;
 629         goto selector_loop;
 630
 631       case EVACUATED:
 632         selectee = stgCast(StgEvacuated*,selectee)->evacuee;
 633         goto selector_loop;
 634
 635       case THUNK:
 636       case THUNK_STATIC:
 637       case THUNK_SELECTOR:
 638         /* aargh - do recursively???? */
 639       case CAF_UNENTERED:
 640       case CAF_BLACKHOLE:
 641       case BLACKHOLE:
 642         /* not evaluated yet */
 643         break;
 644
 645       default:
 646         barf("evacuate: THUNK_SELECTOR: strange selectee");
 647       }
 648     }
 649     to = copy(q,THUNK_SELECTOR_sizeW());
 650     upd_evacuee(q,to);
 651     return to;
 652
 653   case IND:
 654   case IND_OLDGEN:
 655     /* follow chains of indirections, don't evacuate them */
 656     q = stgCast(StgInd*,q)->indirectee;
 657     goto loop;
 658
 659   case CONSTR_STATIC:
 660   case THUNK_STATIC:
 661   case FUN_STATIC:
 662   case IND_STATIC:
 663     /* don't want to evacuate these, but we do want to follow pointers
 664      * from SRTs  - see scavenge_static.
 665      */
 666
 667     /* put the object on the static list, if necessary.
 668      */
 669     if (STATIC_LINK(info,(StgClosure *)q) == NULL) {
 670       STATIC_LINK(info,(StgClosure *)q) = static_objects;
 671       static_objects = (StgClosure *)q;
 672     }
 673     /* fall through */
 674
 675   case CONSTR_INTLIKE:
 676   case CONSTR_CHARLIKE:
 677   case CONSTR_NOCAF_STATIC:
 678     /* no need to put these on the static linked list, they don't need
 679      * to be scavenged.
 680      */
 681     return q;
 682
 683   case RET_BCO:
 684   case RET_SMALL:
 685   case RET_VEC_SMALL:
 686   case RET_BIG:
 687   case RET_VEC_BIG:
 688   case RET_DYN:
 689   case UPDATE_FRAME:
 690   case STOP_FRAME:
 691   case CATCH_FRAME:
 692   case SEQ_FRAME:
 693     /* shouldn't see these */
 694     barf("evacuate: stack frame\n");
 695
 696   case AP_UPD:
 697   case PAP:
 698     /* these are special - the payload is a copy of a chunk of stack,
 699        tagging and all. */
 700     to = copy(q,pap_sizeW(stgCast(StgPAP*,q)));
 701     upd_evacuee(q,to);
 702     return to;
 703
 704   case EVACUATED:
 705     /* Already evacuated, just return the forwarding address */
 706     return stgCast(StgEvacuated*,q)->evacuee;
 707
 708   case MUT_ARR_WORDS:
 709   case ARR_WORDS:
 710   case MUT_ARR_PTRS:
 711   case MUT_ARR_PTRS_FROZEN:
 712   case ARR_PTRS:
 713     {
 714       nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
 715
 716       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 717         evacuate_large((P_)q);
 718         return q;
 719       } else {
 720         /* just copy the block */
 721         to = copy(q,size);
 722         upd_evacuee(q,to);
 723         return to;
 724       }
 725     }
 726
 727   case TSO:
 728     {
 729       StgTSO *tso = stgCast(StgTSO *,q);
 730       nat size = tso_sizeW(tso);
 731       int diff;
 732
 733       /* Large TSOs don't get moved, so no relocation is required.
 734        */
 735       if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 736         evacuate_large((P_)q);
 737         return q;
 738
 739       /* To evacuate a small TSO, we need to relocate the update frame
 740        * list it contains.
 741        */
 742       } else {
 743         StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso));
 744
 745         diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
 746
 747         /* relocate the stack pointers... */
 748         new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
 749         new_tso->sp = (StgPtr)new_tso->sp + diff;
 750         new_tso->splim = (StgPtr)new_tso->splim + diff;
 751
 752         relocate_TSO(tso, new_tso);
 753         upd_evacuee(q,(StgClosure *)new_tso);
 754         return (StgClosure *)new_tso;
 755       }
 756     }
 757
 758   case BLOCKED_FETCH:
 759   case FETCH_ME:
 760     fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
 761     return q;
 762
 763   default:
 764     barf("evacuate: strange closure type");
 765   }
 766
 767   barf("evacuate");
 768 }
 769
 770 /* -----------------------------------------------------------------------------
 771    relocate_TSO is called just after a TSO has been copied from src to
 772    dest.  It adjusts the update frame list for the new location.
 773    -------------------------------------------------------------------------- */
 774
 775 StgTSO *
 776 relocate_TSO(StgTSO *src, StgTSO *dest)
 777 {
 778   StgUpdateFrame *su;
 779   StgCatchFrame  *cf;
 780   StgSeqFrame    *sf;
 781   int diff;
 782
 783   diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
 784
 785   su = dest->su;
 786
 787   while ((P_)su < dest->stack + dest->stack_size) {
 788     switch (get_itbl(su)->type) {
 789
 790       /* GCC actually manages to common up these three cases! */
 791
 792     case UPDATE_FRAME:
 793       su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
 794       su = su->link;
 795       continue;
 796
 797     case CATCH_FRAME:
 798       cf = (StgCatchFrame *)su;
 799       cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
 800       su = cf->link;
 801       continue;
 802
 803     case SEQ_FRAME:
 804       sf = (StgSeqFrame *)su;
 805       sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
 806       su = sf->link;
 807       continue;
 808
 809     case STOP_FRAME:
 810       /* all done! */
 811       break;
 812
 813     default:
 814       barf("relocate_TSO");
 815     }
 816     break;
 817   }
 818
 819   return dest;
 820 }
 821
 822 static inline void
 823 evacuate_srt(const StgInfoTable *info)
 824 {
 825   StgClosure **srt, **srt_end;
 826
 827   /* evacuate the SRT.  If srt_len is zero, then there isn't an
 828    * srt field in the info table.  That's ok, because we'll
 829    * never dereference it.
 830    */
 831   srt = stgCast(StgClosure **,info->srt);
 832   srt_end = srt + info->srt_len;
 833   for (; srt < srt_end; srt++) {
 834     evacuate(*srt);
 835   }
 836 }
 837
 838 static StgPtr
 839 scavenge(StgPtr to_scan)
 840 {
 841   StgPtr p;
 842   const StgInfoTable *info;
 843   bdescr *bd;
 844
 845   p = to_scan;
 846   bd = Bdescr((P_)p);
 847
 848   /* scavenge phase - standard breadth-first scavenging of the
 849    * evacuated objects
 850    */
 851
 852   while (bd != toHp_bd || p < toHp) {
 853
 854     /* If we're at the end of this block, move on to the next block */
 855     if (bd != toHp_bd && p == bd->free) {
 856       bd = bd->link;
 857       p = bd->start;
 858       continue;
 859     }
 860
 861     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
 862                  || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
 863
 864     info = get_itbl((StgClosure *)p);
 865     switch (info -> type) {
 866
 867     case BCO:
 868       {
 869         StgBCO* bco = stgCast(StgBCO*,p);
 870         nat i;
 871         for (i = 0; i < bco->n_ptrs; i++) {
 872           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
 873         }
 874         p += bco_sizeW(bco);
 875         continue;
 876       }
 877
 878     case FUN:
 879     case THUNK:
 880       evacuate_srt(info);
 881       /* fall through */
 882
 883     case CONSTR:
 884     case WEAK:
 885     case FOREIGN:
 886     case MVAR:
 887     case MUT_VAR:
 888     case IND_PERM:
 889     case IND_OLDGEN_PERM:
 890     case CAF_UNENTERED:
 891     case CAF_ENTERED:
 892       {
 893         StgPtr end;
 894
 895         end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
 896         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 897           (StgClosure *)*p = evacuate((StgClosure *)*p);
 898         }
 899         p += info->layout.payload.nptrs;
 900         continue;
 901       }
 902
 903     case CAF_BLACKHOLE:
 904     case BLACKHOLE:
 905       {
 906         StgBlackHole *bh = (StgBlackHole *)p;
 907         (StgClosure *)bh->blocking_queue =
 908           evacuate((StgClosure *)bh->blocking_queue);
 909         p += BLACKHOLE_sizeW();
 910         continue;
 911       }
 912
 913     case THUNK_SELECTOR:
 914       {
 915         StgSelector *s = (StgSelector *)p;
 916         s->selectee = evacuate(s->selectee);
 917         p += THUNK_SELECTOR_sizeW();
 918         continue;
 919       }
 920
 921     case IND:
 922     case IND_OLDGEN:
 923       barf("scavenge:IND???\n");
 924
 925     case CONSTR_INTLIKE:
 926     case CONSTR_CHARLIKE:
 927     case CONSTR_STATIC:
 928     case CONSTR_NOCAF_STATIC:
 929     case THUNK_STATIC:
 930     case FUN_STATIC:
 931     case IND_STATIC:
 932       /* Shouldn't see a static object here. */
 933       barf("scavenge: STATIC object\n");
 934
 935     case RET_BCO:
 936     case RET_SMALL:
 937     case RET_VEC_SMALL:
 938     case RET_BIG:
 939     case RET_VEC_BIG:
 940     case RET_DYN:
 941     case UPDATE_FRAME:
 942     case STOP_FRAME:
 943     case CATCH_FRAME:
 944     case SEQ_FRAME:
 945       /* Shouldn't see stack frames here. */
 946       barf("scavenge: stack frame\n");
 947
 948     case AP_UPD: /* same as PAPs */
 949     case PAP:
 950       /* Treat a PAP just like a section of stack, not forgetting to
 951        * evacuate the function pointer too...
 952        */
 953       {
 954         StgPAP* pap = stgCast(StgPAP*,p);
 955
 956         pap->fun = evacuate(pap->fun);
 957         scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
 958         p += pap_sizeW(pap);
 959         continue;
 960       }
 961
 962     case ARR_WORDS:
 963     case MUT_ARR_WORDS:
 964       /* nothing to follow */
 965       p += arr_words_sizeW(stgCast(StgArrWords*,p));
 966       continue;
 967
 968     case ARR_PTRS:
 969     case MUT_ARR_PTRS:
 970     case MUT_ARR_PTRS_FROZEN:
 971       /* follow everything */
 972       {
 973         StgPtr next;
 974
 975         next = p + arr_ptrs_sizeW(stgCast(StgArrPtrs*,p));
 976         for (p = (P_)((StgArrPtrs *)p)->payload; p < next; p++) {
 977           (StgClosure *)*p = evacuate((StgClosure *)*p);
 978         }
 979         continue;
 980       }
 981
 982     case TSO:
 983       {
 984         StgTSO *tso;
 985
 986         tso = (StgTSO *)p;
 987         /* chase the link field for any TSOs on the same queue */
 988         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
 989         /* scavenge this thread's stack */
 990         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
 991         p += tso_sizeW(tso);
 992         continue;
 993       }
 994
 995     case BLOCKED_FETCH:
 996     case FETCH_ME:
 997     case EVACUATED:
 998       barf("scavenge: unimplemented/strange closure type\n");
 999
1000     default:
1001       barf("scavenge");
1002     }
1003   }
1004   return (P_)p;
1005 }
1006
1007 /* scavenge_static is the scavenge code for a static closure.
1008  */
1009
1010 static void
1011 scavenge_static(void)
1012 {
1013   StgClosure* p = static_objects;
1014   const StgInfoTable *info;
1015
1016   /* keep going until we've scavenged all the objects on the linked
1017      list... */
1018   while (p != END_OF_STATIC_LIST) {
1019
1020     /* make sure the info pointer is into text space */
1021     ASSERT(p && LOOKS_LIKE_GHC_INFO(GET_INFO(p)));
1022     ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
1023                  || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
1024
1025     info = get_itbl(p);
1026
1027     /* Take this object *off* the static_objects list,
1028      * and put it on the scavenged_static_objects list.
1029      */
1030     static_objects = STATIC_LINK(info,p);
1031     STATIC_LINK(info,p) = scavenged_static_objects;
1032     scavenged_static_objects = p;
1033
1034     switch (info -> type) {
1035
1036     case IND_STATIC:
1037       {
1038         StgInd *ind = (StgInd *)p;
1039         ind->indirectee = evacuate(ind->indirectee);
1040         break;
1041       }
1042
1043     case THUNK_STATIC:
1044     case FUN_STATIC:
1045       evacuate_srt(info);
1046       /* fall through */
1047
1048     case CONSTR_STATIC:
1049       {
1050         StgPtr q, next;
1051
1052         next = (P_)p->payload + info->layout.payload.ptrs;
1053         /* evacuate the pointers */
1054         for (q = (P_)p->payload; q < next; q++) {
1055           (StgClosure *)*q = evacuate((StgClosure *)*q);
1056         }
1057         break;
1058       }
1059
1060     default:
1061       barf("scavenge_static");
1062     }
1063
1064     /* get the next static object from the list.  Remeber, there might
1065      * be more stuff on this list now that we've done some evacuating!
1066      * (static_objects is a global)
1067      */
1068     p = static_objects;
1069   }
1070 }
1071
1072 /* -----------------------------------------------------------------------------
1073    scavenge_stack walks over a section of stack and evacuates all the
1074    objects pointed to by it.  We can use the same code for walking
1075    PAPs, since these are just sections of copied stack.
1076    -------------------------------------------------------------------------- */
1077
1078 static void
1079 scavenge_stack(StgPtr p, StgPtr stack_end)
1080 {
1081   StgPtr q;
1082   const StgInfoTable* info;
1083   StgNat32 bitmap;
1084
1085   /*
1086    * Each time around this loop, we are looking at a chunk of stack
1087    * that starts with either a pending argument section or an
1088    * activation record.
1089    */
1090
1091   while (p < stack_end) {
1092     q = *stgCast(StgPtr*,p);
1093
1094     /* If we've got a tag, skip over that many words on the stack */
1095     if (IS_ARG_TAG(stgCast(StgWord,q))) {
1096       p += ARG_SIZE(q);
1097       p++; continue;
1098     }
1099
1100     /* Is q a pointer to a closure?
1101      */
1102     if (! LOOKS_LIKE_GHC_INFO(q)) {
1103
1104 #ifdef DEBUG
1105       if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
1106         ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
1107       }
1108       /* otherwise, must be a pointer into the allocation space.
1109        */
1110 #endif
1111
1112       (StgClosure *)*p = evacuate((StgClosure *)q);
1113       p++;
1114       continue;
1115     }
1116
1117     /*
1118      * Otherwise, q must be the info pointer of an activation
1119      * record.  All activation records have 'bitmap' style layout
1120      * info.
1121      */
1122     info  = get_itbl(stgCast(StgClosure*,p));
1123
1124     switch (info->type) {
1125
1126       /* Dynamic bitmap: the mask is stored on the stack */
1127     case RET_DYN:
1128       bitmap = stgCast(StgRetDyn*,p)->liveness;
1129       p      = &payloadWord(stgCast(StgRetDyn*,p),0);
1130       goto small_bitmap;
1131
1132       /* probably a slow-entry point return address: */
1133     case FUN:
1134     case FUN_STATIC:
1135       p++;
1136       goto follow_srt;
1137
1138       /* Specialised code for update frames, since they're so common.
1139        * We *know* the updatee points to a BLACKHOLE or CAF_BLACKHOLE,
1140        * so just inline the code to evacuate it here.
1141        */
1142     case UPDATE_FRAME:
1143       {
1144         StgUpdateFrame *frame = (StgUpdateFrame *)p;
1145         StgClosure *to;
1146         StgClosureType type = get_itbl(frame->updatee)->type;
1147
1148         if (type == EVACUATED) {
1149           frame->updatee = evacuate(frame->updatee);
1150           p += sizeofW(StgUpdateFrame);
1151           continue;
1152         } else {
1153           ASSERT(type == BLACKHOLE || type == CAF_BLACKHOLE);
1154           to = copy(frame->updatee, BLACKHOLE_sizeW());
1155           upd_evacuee(frame->updatee,to);
1156           frame->updatee = to;
1157           p += sizeofW(StgUpdateFrame);
1158           continue;
1159         }
1160       }
1161
1162       /* small bitmap (< 32 entries) */
1163     case RET_BCO:
1164     case RET_SMALL:
1165     case RET_VEC_SMALL:
1166     case STOP_FRAME:
1167     case CATCH_FRAME:
1168     case SEQ_FRAME:
1169       bitmap = info->layout.bitmap;
1170       p++;
1171     small_bitmap:
1172       while (bitmap != 0) {
1173         if ((bitmap & 1) == 0) {
1174           (StgClosure *)*p = evacuate((StgClosure *)*p);
1175         }
1176         p++;
1177         bitmap = bitmap >> 1;
1178       }
1179
1180     follow_srt:
1181       evacuate_srt(info);
1182       continue;
1183
1184       /* large bitmap (> 32 entries) */
1185     case RET_BIG:
1186     case RET_VEC_BIG:
1187       {
1188         StgPtr q;
1189         StgLargeBitmap *large_bitmap;
1190         nat i;
1191
1192         large_bitmap = info->layout.large_bitmap;
1193         p++;
1194
1195         for (i=0; i<large_bitmap->size; i++) {
1196           bitmap = large_bitmap->bitmap[i];
1197           q = p + sizeof(W_) * 8;
1198           while (bitmap != 0) {
1199             if ((bitmap & 1) == 0) {
1200               (StgClosure *)*p = evacuate((StgClosure *)*p);
1201             }
1202             p++;
1203             bitmap = bitmap >> 1;
1204           }
1205           if (i+1 < large_bitmap->size) {
1206             while (p < q) {
1207               (StgClosure *)*p = evacuate((StgClosure *)*p);
1208               p++;
1209             }
1210           }
1211         }
1212
1213         /* and don't forget to follow the SRT */
1214         goto follow_srt;
1215       }
1216
1217     default:
1218       barf("scavenge_stack: weird activation record found on stack.\n");
1219     }
1220   }
1221 }
1222
1223 /*-----------------------------------------------------------------------------
1224   scavenge the large object list.
1225   --------------------------------------------------------------------------- */
1226
1227 static void
1228 scavenge_large(void)
1229 {
1230   bdescr *bd;
1231   StgPtr p;
1232   const StgInfoTable* info;
1233
1234   bd = new_large_objects;
1235
1236   for (; bd != NULL; bd = new_large_objects) {
1237
1238     /* take this object *off* the large objects list and put it on
1239      * the scavenged large objects list.  This is so that we can
1240      * treat new_large_objects as a stack and push new objects on
1241      * the front when evacuating.
1242      */
1243     new_large_objects = bd->link;
1244     /* scavenged_large_objects is doubly linked */
1245     bd->link = scavenged_large_objects;
1246     bd->back = NULL;
1247     if (scavenged_large_objects) {
1248       scavenged_large_objects->back = bd;
1249     }
1250     scavenged_large_objects = bd;
1251
1252     p = bd->start;
1253     info  = get_itbl(stgCast(StgClosure*,p));
1254
1255     switch (info->type) {
1256
1257     /* only certain objects can be "large"... */
1258
1259     case ARR_WORDS:
1260     case MUT_ARR_WORDS:
1261       /* nothing to follow */
1262       continue;
1263
1264     case ARR_PTRS:
1265     case MUT_ARR_PTRS:
1266     case MUT_ARR_PTRS_FROZEN:
1267       /* follow everything */
1268       {
1269         StgPtr next;
1270
1271         next = p + arr_ptrs_sizeW(stgCast(StgArrPtrs*,p));
1272         for (p = (P_)((StgArrPtrs *)p)->payload; p < next; p++) {
1273           (StgClosure *)*p = evacuate((StgClosure *)*p);
1274         }
1275         continue;
1276       }
1277
1278     case BCO:
1279       {
1280         StgBCO* bco = stgCast(StgBCO*,p);
1281         nat i;
1282         for (i = 0; i < bco->n_ptrs; i++) {
1283           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1284         }
1285         continue;
1286       }
1287
1288     case TSO:
1289       {
1290         StgTSO *tso;
1291
1292         tso = (StgTSO *)p;
1293         /* chase the link field for any TSOs on the same queue */
1294         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1295         /* scavenge this thread's stack */
1296         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1297         continue;
1298       }
1299
1300     default:
1301       barf("scavenge_large: unknown/strange object");
1302     }
1303   }
1304 }
1305 static void
1306 zeroStaticObjectList(StgClosure* first_static)
1307 {
1308   StgClosure* p;
1309   StgClosure* link;
1310   const StgInfoTable *info;
1311
1312   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
1313     info = get_itbl(p);
1314     link = STATIC_LINK(info, p);
1315     STATIC_LINK(info,p) = NULL;
1316   }
1317 }
1318
1319 /* -----------------------------------------------------------------------------
1320    Reverting CAFs
1321
1322    -------------------------------------------------------------------------- */
1323
1324 void RevertCAFs(void)
1325 {
1326     while (enteredCAFs != END_CAF_LIST) {
1327         StgCAF* caf = enteredCAFs;
1328         const StgInfoTable *info = get_itbl(caf);
1329
1330         enteredCAFs = caf->link;
1331         ASSERT(get_itbl(caf)->type == CAF_ENTERED);
1332         SET_INFO(caf,&CAF_UNENTERED_info);
1333         caf->value = stgCast(StgClosure*,0xdeadbeef);
1334         caf->link  = stgCast(StgCAF*,0xdeadbeef);
1335     }
1336 }
1337
1338 void revertDeadCAFs(void)
1339 {
1340     StgCAF* caf = enteredCAFs;
1341     enteredCAFs = END_CAF_LIST;
1342     while (caf != END_CAF_LIST) {
1343         StgCAF* next = caf->link;
1344
1345         switch(GET_INFO(caf)->type) {
1346         case EVACUATED:
1347             {
1348                 /* This object has been evacuated, it must be live. */
1349                 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
1350                 new->link = enteredCAFs;
1351                 enteredCAFs = new;
1352                 break;
1353             }
1354         case CAF_ENTERED:
1355             {
1356                 SET_INFO(caf,&CAF_UNENTERED_info);
1357                 caf->value = stgCast(StgClosure*,0xdeadbeef);
1358                 caf->link  = stgCast(StgCAF*,0xdeadbeef);
1359                 break;
1360             }
1361         default:
1362                 barf("revertDeadCAFs: enteredCAFs list corrupted");
1363         }
1364         caf = next;
1365     }
1366 }
1367
1368 /* -----------------------------------------------------------------------------
1369    Sanity code for CAF garbage collection.
1370
1371    With DEBUG turned on, we manage a CAF list in addition to the SRT
1372    mechanism.  After GC, we run down the CAF list and blackhole any
1373    CAFs which have been garbage collected.  This means we get an error
1374    whenever the program tries to enter a garbage collected CAF.
1375
1376    Any garbage collected CAFs are taken off the CAF list at the same
1377    time.
1378    -------------------------------------------------------------------------- */
1379
1380 #ifdef DEBUG
1381 static void
1382 gcCAFs(void)
1383 {
1384   StgClosure*  p;
1385   StgClosure** pp;
1386   const StgInfoTable *info;
1387   nat i;
1388
1389   i = 0;
1390   p = caf_list;
1391   pp = &caf_list;
1392
1393   while (p != NULL) {
1394
1395     info = get_itbl(p);
1396
1397     ASSERT(info->type == IND_STATIC);
1398
1399     if (STATIC_LINK(info,p) == NULL) {
1400       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
1401       /* black hole it */
1402       SET_INFO(p,&BLACKHOLE_info);
1403       p = STATIC_LINK2(info,p);
1404       *pp = p;
1405     }
1406     else {
1407       pp = &STATIC_LINK2(info,p);
1408       p = *pp;
1409       i++;
1410     }
1411
1412   }
1413
1414   /*  fprintf(stderr, "%d CAFs live\n", i); */
1415 }
1416 #endif
1417
1418 /* -----------------------------------------------------------------------------
1419    Lazy black holing.
1420
1421    Whenever a thread returns to the scheduler after possibly doing
1422    some work, we have to run down the stack and black-hole all the
1423    closures referred to by update frames.
1424    -------------------------------------------------------------------------- */
1425
1426 static void
1427 threadLazyBlackHole(StgTSO *tso)
1428 {
1429   StgUpdateFrame *update_frame;
1430   StgBlackHole *bh;
1431   StgPtr stack_end;
1432
1433   stack_end = &tso->stack[tso->stack_size];
1434   update_frame = tso->su;
1435
1436   while (1) {
1437     switch (get_itbl(update_frame)->type) {
1438
1439     case CATCH_FRAME:
1440       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
1441       break;
1442
1443     case UPDATE_FRAME:
1444       bh = stgCast(StgBlackHole*,update_frame->updatee);
1445
1446       /* if the thunk is already blackholed, it means we've also
1447        * already blackholed the rest of the thunks on this stack,
1448        * so we can stop early.
1449        */
1450
1451       /* Don't for now: when we enter a CAF, we create a black hole on
1452        * the heap and make the update frame point to it.  Thus the
1453        * above optimisation doesn't apply.
1454        */
1455       if (bh->header.info != &BLACKHOLE_info
1456           && bh->header.info != &CAF_BLACKHOLE_info) {
1457         SET_INFO(bh,&BLACKHOLE_info);
1458         bh->blocking_queue = stgCast(StgTSO*,&END_TSO_QUEUE_closure);
1459       }
1460
1461       update_frame = update_frame->link;
1462       break;
1463
1464     case SEQ_FRAME:
1465       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
1466       break;
1467
1468     case STOP_FRAME:
1469       return;
1470     default:
1471       barf("threadPaused");
1472     }
1473   }
1474 }
1475
1476 /* -----------------------------------------------------------------------------
1477  * Stack squeezing
1478  *
1479  * Code largely pinched from old RTS, then hacked to bits.  We also do
1480  * lazy black holing here.
1481  *
1482  * -------------------------------------------------------------------------- */
1483
1484 static void
1485 threadSqueezeStack(StgTSO *tso)
1486 {
1487   lnat displacement = 0;
1488   StgUpdateFrame *frame;
1489   StgUpdateFrame *next_frame;                   /* Temporally next */
1490   StgUpdateFrame *prev_frame;                   /* Temporally previous */
1491   StgPtr bottom;
1492   rtsBool prev_was_update_frame;
1493
1494   bottom = &(tso->stack[tso->stack_size]);
1495   frame  = tso->su;
1496
1497   /* There must be at least one frame, namely the STOP_FRAME.
1498    */
1499   ASSERT((P_)frame < bottom);
1500
1501   /* Walk down the stack, reversing the links between frames so that
1502    * we can walk back up as we squeeze from the bottom.  Note that
1503    * next_frame and prev_frame refer to next and previous as they were
1504    * added to the stack, rather than the way we see them in this
1505    * walk. (It makes the next loop less confusing.)
1506    *
1507    * Could stop if we find an update frame pointing to a black hole,
1508    * but see comment in threadLazyBlackHole().
1509    */
1510
1511   next_frame = NULL;
1512   while ((P_)frame < bottom - 1) {  /* bottom - 1 is the STOP_FRAME */
1513     prev_frame = frame->link;
1514     frame->link = next_frame;
1515     next_frame = frame;
1516     frame = prev_frame;
1517   }
1518
1519   /* Now, we're at the bottom.  Frame points to the lowest update
1520    * frame on the stack, and its link actually points to the frame
1521    * above. We have to walk back up the stack, squeezing out empty
1522    * update frames and turning the pointers back around on the way
1523    * back up.
1524    *
1525    * The bottom-most frame (the STOP_FRAME) has not been altered, and
1526    * we never want to eliminate it anyway.  Just walk one step up
1527    * before starting to squeeze. When you get to the topmost frame,
1528    * remember that there are still some words above it that might have
1529    * to be moved.
1530    */
1531
1532   prev_frame = frame;
1533   frame = next_frame;
1534
1535   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
1536
1537   /*
1538    * Loop through all of the frames (everything except the very
1539    * bottom).  Things are complicated by the fact that we have
1540    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
1541    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
1542    */
1543   while (frame != NULL) {
1544     StgPtr sp;
1545     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
1546     rtsBool is_update_frame;
1547
1548     next_frame = frame->link;
1549     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
1550
1551     /* Check to see if
1552      *   1. both the previous and current frame are update frames
1553      *   2. the current frame is empty
1554      */
1555     if (prev_was_update_frame && is_update_frame &&
1556         (P_)prev_frame == frame_bottom + displacement) {
1557
1558       /* Now squeeze out the current frame */
1559       StgClosure *updatee_keep   = prev_frame->updatee;
1560       StgClosure *updatee_bypass = frame->updatee;
1561
1562 #if 0 /* DEBUG */
1563       fprintf(stderr, "squeezing frame at %p\n", frame);
1564 #endif
1565
1566       /* Deal with blocking queues.  If both updatees have blocked
1567        * threads, then we should merge the queues into the update
1568        * frame that we're keeping.
1569        *
1570        * Alternatively, we could just wake them up: they'll just go
1571        * straight to sleep on the proper blackhole!  This is less code
1572        * and probably less bug prone, although it's probably much
1573        * slower --SDM
1574        */
1575 #if 0 /* do it properly... */
1576       if (GET_INFO(updatee_bypass) == BLACKHOLE_info
1577           || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
1578           ) {
1579         /* Sigh.  It has one.  Don't lose those threads! */
1580         if (GET_INFO(updatee_keep) == BLACKHOLE_info
1581             || GET_INFO(updatee_keep) == CAF_BLACKHOLE_info
1582             ) {
1583           /* Urgh.  Two queues.  Merge them. */
1584           P_ keep_tso = ((StgBlackHole *)updatee_keep)->blocking_queue;
1585
1586           while (keep_tso->link != END_TSO_QUEUE) {
1587             keep_tso = keep_tso->link;
1588           }
1589           keep_tso->link = ((StgBlackHole *)updatee_bypass)->blocking_queue;
1590
1591         } else {
1592           /* For simplicity, just swap the BQ for the BH */
1593           P_ temp = updatee_keep;
1594
1595           updatee_keep = updatee_bypass;
1596           updatee_bypass = temp;
1597
1598           /* Record the swap in the kept frame (below) */
1599           prev_frame->updatee = updatee_keep;
1600         }
1601       }
1602 #endif
1603
1604       TICK_UPD_SQUEEZED();
1605       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
1606
1607       sp = (P_)frame - 1;       /* sp = stuff to slide */
1608       displacement += sizeofW(StgUpdateFrame);
1609
1610     } else {
1611       /* No squeeze for this frame */
1612       sp = frame_bottom - 1;    /* Keep the current frame */
1613
1614       /* Do lazy black-holing.
1615        */
1616       if (is_update_frame) {
1617         StgBlackHole *bh = (StgBlackHole *)frame->updatee;
1618         if (bh->header.info != &BLACKHOLE_info
1619             && bh->header.info != &CAF_BLACKHOLE_info
1620             ) {
1621           SET_INFO(bh,&BLACKHOLE_info);
1622           bh->blocking_queue = stgCast(StgTSO*,&END_TSO_QUEUE_closure);
1623         }
1624       }
1625
1626       /* Fix the link in the current frame (should point to the frame below) */
1627       frame->link = prev_frame;
1628       prev_was_update_frame = is_update_frame;
1629     }
1630
1631     /* Now slide all words from sp up to the next frame */
1632
1633     if (displacement > 0) {
1634       P_ next_frame_bottom;
1635
1636       if (next_frame != NULL)
1637         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
1638       else
1639         next_frame_bottom = tso->sp - 1;
1640
1641 #if 0 /* DEBUG */
1642       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
1643               displacement);
1644 #endif
1645
1646       while (sp >= next_frame_bottom) {
1647         sp[displacement] = *sp;
1648         sp -= 1;
1649       }
1650     }
1651     (P_)prev_frame = (P_)frame + displacement;
1652     frame = next_frame;
1653   }
1654
1655   tso->sp += displacement;
1656   tso->su = prev_frame;
1657 }
1658
1659 /* -----------------------------------------------------------------------------
1660  * Pausing a thread
1661  *
1662  * We have to prepare for GC - this means doing lazy black holing
1663  * here.  We also take the opportunity to do stack squeezing if it's
1664  * turned on.
1665  * -------------------------------------------------------------------------- */
1666
1667 void
1668 threadPaused(StgTSO *tso)
1669 {
1670   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
1671     threadSqueezeStack(tso);    /* does black holing too */
1672   else
1673     threadLazyBlackHole(tso);
1674 }