ghc/rts/GC.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GC.c,v 1.2 1998/12/02 13:28:23 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         StgLargeBitmap *large_bitmap;
1189         nat i;
1190
1191         large_bitmap = info->layout.large_bitmap;
1192         p++;
1193
1194         for (i=0; i<large_bitmap->size; i++) {
1195           bitmap = large_bitmap->bitmap[i];
1196           while (bitmap != 0) {
1197             if ((bitmap & 1) == 0) {
1198               (StgClosure *)*p = evacuate((StgClosure *)*p);
1199             }
1200             p++;
1201             bitmap = bitmap >> 1;
1202           }
1203         }
1204
1205         /* and don't forget to follow the SRT */
1206         goto follow_srt;
1207       }
1208
1209     default:
1210       barf("scavenge_stack: weird activation record found on stack.\n");
1211     }
1212   }
1213 }
1214
1215 /*-----------------------------------------------------------------------------
1216   scavenge the large object list.
1217   --------------------------------------------------------------------------- */
1218
1219 static void
1220 scavenge_large(void)
1221 {
1222   bdescr *bd;
1223   StgPtr p;
1224   const StgInfoTable* info;
1225
1226   bd = new_large_objects;
1227
1228   for (; bd != NULL; bd = new_large_objects) {
1229
1230     /* take this object *off* the large objects list and put it on
1231      * the scavenged large objects list.  This is so that we can
1232      * treat new_large_objects as a stack and push new objects on
1233      * the front when evacuating.
1234      */
1235     new_large_objects = bd->link;
1236     /* scavenged_large_objects is doubly linked */
1237     bd->link = scavenged_large_objects;
1238     bd->back = NULL;
1239     if (scavenged_large_objects) {
1240       scavenged_large_objects->back = bd;
1241     }
1242     scavenged_large_objects = bd;
1243
1244     p = bd->start;
1245     info  = get_itbl(stgCast(StgClosure*,p));
1246
1247     switch (info->type) {
1248
1249     /* only certain objects can be "large"... */
1250
1251     case ARR_WORDS:
1252     case MUT_ARR_WORDS:
1253       /* nothing to follow */
1254       continue;
1255
1256     case ARR_PTRS:
1257     case MUT_ARR_PTRS:
1258     case MUT_ARR_PTRS_FROZEN:
1259       /* follow everything */
1260       {
1261         StgPtr next;
1262
1263         next = p + arr_ptrs_sizeW(stgCast(StgArrPtrs*,p));
1264         for (p = (P_)((StgArrPtrs *)p)->payload; p < next; p++) {
1265           (StgClosure *)*p = evacuate((StgClosure *)*p);
1266         }
1267         continue;
1268       }
1269
1270     case BCO:
1271       {
1272         StgBCO* bco = stgCast(StgBCO*,p);
1273         nat i;
1274         for (i = 0; i < bco->n_ptrs; i++) {
1275           bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
1276         }
1277         continue;
1278       }
1279
1280     case TSO:
1281       {
1282         StgTSO *tso;
1283
1284         tso = (StgTSO *)p;
1285         /* chase the link field for any TSOs on the same queue */
1286         (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
1287         /* scavenge this thread's stack */
1288         scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1289         continue;
1290       }
1291
1292     default:
1293       barf("scavenge_large: unknown/strange object");
1294     }
1295   }
1296 }
1297 static void
1298 zeroStaticObjectList(StgClosure* first_static)
1299 {
1300   StgClosure* p;
1301   StgClosure* link;
1302   const StgInfoTable *info;
1303
1304   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
1305     info = get_itbl(p);
1306     link = STATIC_LINK(info, p);
1307     STATIC_LINK(info,p) = NULL;
1308   }
1309 }
1310
1311 /* -----------------------------------------------------------------------------
1312    Reverting CAFs
1313
1314    -------------------------------------------------------------------------- */
1315
1316 void RevertCAFs(void)
1317 {
1318     while (enteredCAFs != END_CAF_LIST) {
1319         StgCAF* caf = enteredCAFs;
1320         const StgInfoTable *info = get_itbl(caf);
1321
1322         enteredCAFs = caf->link;
1323         ASSERT(get_itbl(caf)->type == CAF_ENTERED);
1324         SET_INFO(caf,&CAF_UNENTERED_info);
1325         caf->value = stgCast(StgClosure*,0xdeadbeef);
1326         caf->link  = stgCast(StgCAF*,0xdeadbeef);
1327     }
1328 }
1329
1330 void revertDeadCAFs(void)
1331 {
1332     StgCAF* caf = enteredCAFs;
1333     enteredCAFs = END_CAF_LIST;
1334     while (caf != END_CAF_LIST) {
1335         StgCAF* next = caf->link;
1336
1337         switch(GET_INFO(caf)->type) {
1338         case EVACUATED:
1339             {
1340                 /* This object has been evacuated, it must be live. */
1341                 StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
1342                 new->link = enteredCAFs;
1343                 enteredCAFs = new;
1344                 break;
1345             }
1346         case CAF_ENTERED:
1347             {
1348                 SET_INFO(caf,&CAF_UNENTERED_info);
1349                 caf->value = stgCast(StgClosure*,0xdeadbeef);
1350                 caf->link  = stgCast(StgCAF*,0xdeadbeef);
1351                 break;
1352             }
1353         default:
1354                 barf("revertDeadCAFs: enteredCAFs list corrupted");
1355         }
1356         caf = next;
1357     }
1358 }
1359
1360 /* -----------------------------------------------------------------------------
1361    Sanity code for CAF garbage collection.
1362
1363    With DEBUG turned on, we manage a CAF list in addition to the SRT
1364    mechanism.  After GC, we run down the CAF list and blackhole any
1365    CAFs which have been garbage collected.  This means we get an error
1366    whenever the program tries to enter a garbage collected CAF.
1367
1368    Any garbage collected CAFs are taken off the CAF list at the same
1369    time.
1370    -------------------------------------------------------------------------- */
1371
1372 #ifdef DEBUG
1373 static void
1374 gcCAFs(void)
1375 {
1376   StgClosure*  p;
1377   StgClosure** pp;
1378   const StgInfoTable *info;
1379   nat i;
1380
1381   i = 0;
1382   p = caf_list;
1383   pp = &caf_list;
1384
1385   while (p != NULL) {
1386
1387     info = get_itbl(p);
1388
1389     ASSERT(info->type == IND_STATIC);
1390
1391     if (STATIC_LINK(info,p) == NULL) {
1392       IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
1393       /* black hole it */
1394       SET_INFO(p,&BLACKHOLE_info);
1395       p = STATIC_LINK2(info,p);
1396       *pp = p;
1397     }
1398     else {
1399       pp = &STATIC_LINK2(info,p);
1400       p = *pp;
1401       i++;
1402     }
1403
1404   }
1405
1406   /*  fprintf(stderr, "%d CAFs live\n", i); */
1407 }
1408 #endif
1409
1410 /* -----------------------------------------------------------------------------
1411    Lazy black holing.
1412
1413    Whenever a thread returns to the scheduler after possibly doing
1414    some work, we have to run down the stack and black-hole all the
1415    closures referred to by update frames.
1416    -------------------------------------------------------------------------- */
1417
1418 static void
1419 threadLazyBlackHole(StgTSO *tso)
1420 {
1421   StgUpdateFrame *update_frame;
1422   StgBlackHole *bh;
1423   StgPtr stack_end;
1424
1425   stack_end = &tso->stack[tso->stack_size];
1426   update_frame = tso->su;
1427
1428   while (1) {
1429     switch (get_itbl(update_frame)->type) {
1430
1431     case CATCH_FRAME:
1432       update_frame = stgCast(StgCatchFrame*,update_frame)->link;
1433       break;
1434
1435     case UPDATE_FRAME:
1436       bh = stgCast(StgBlackHole*,update_frame->updatee);
1437
1438       /* if the thunk is already blackholed, it means we've also
1439        * already blackholed the rest of the thunks on this stack,
1440        * so we can stop early.
1441        */
1442
1443       /* Don't for now: when we enter a CAF, we create a black hole on
1444        * the heap and make the update frame point to it.  Thus the
1445        * above optimisation doesn't apply.
1446        */
1447       if (bh->header.info != &BLACKHOLE_info
1448           && bh->header.info != &CAF_BLACKHOLE_info) {
1449         SET_INFO(bh,&BLACKHOLE_info);
1450         bh->blocking_queue = stgCast(StgTSO*,&END_TSO_QUEUE_closure);
1451       }
1452
1453       update_frame = update_frame->link;
1454       break;
1455
1456     case SEQ_FRAME:
1457       update_frame = stgCast(StgSeqFrame*,update_frame)->link;
1458       break;
1459
1460     case STOP_FRAME:
1461       return;
1462     default:
1463       barf("threadPaused");
1464     }
1465   }
1466 }
1467
1468 /* -----------------------------------------------------------------------------
1469  * Stack squeezing
1470  *
1471  * Code largely pinched from old RTS, then hacked to bits.  We also do
1472  * lazy black holing here.
1473  *
1474  * -------------------------------------------------------------------------- */
1475
1476 static void
1477 threadSqueezeStack(StgTSO *tso)
1478 {
1479   lnat displacement = 0;
1480   StgUpdateFrame *frame;
1481   StgUpdateFrame *next_frame;                   /* Temporally next */
1482   StgUpdateFrame *prev_frame;                   /* Temporally previous */
1483   StgPtr bottom;
1484   rtsBool prev_was_update_frame;
1485
1486   bottom = &(tso->stack[tso->stack_size]);
1487   frame  = tso->su;
1488
1489   /* There must be at least one frame, namely the STOP_FRAME.
1490    */
1491   ASSERT((P_)frame < bottom);
1492
1493   /* Walk down the stack, reversing the links between frames so that
1494    * we can walk back up as we squeeze from the bottom.  Note that
1495    * next_frame and prev_frame refer to next and previous as they were
1496    * added to the stack, rather than the way we see them in this
1497    * walk. (It makes the next loop less confusing.)
1498    *
1499    * Could stop if we find an update frame pointing to a black hole,
1500    * but see comment in threadLazyBlackHole().
1501    */
1502
1503   next_frame = NULL;
1504   while ((P_)frame < bottom - 1) {  /* bottom - 1 is the STOP_FRAME */
1505     prev_frame = frame->link;
1506     frame->link = next_frame;
1507     next_frame = frame;
1508     frame = prev_frame;
1509   }
1510
1511   /* Now, we're at the bottom.  Frame points to the lowest update
1512    * frame on the stack, and its link actually points to the frame
1513    * above. We have to walk back up the stack, squeezing out empty
1514    * update frames and turning the pointers back around on the way
1515    * back up.
1516    *
1517    * The bottom-most frame (the STOP_FRAME) has not been altered, and
1518    * we never want to eliminate it anyway.  Just walk one step up
1519    * before starting to squeeze. When you get to the topmost frame,
1520    * remember that there are still some words above it that might have
1521    * to be moved.
1522    */
1523
1524   prev_frame = frame;
1525   frame = next_frame;
1526
1527   prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
1528
1529   /*
1530    * Loop through all of the frames (everything except the very
1531    * bottom).  Things are complicated by the fact that we have
1532    * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
1533    * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
1534    */
1535   while (frame != NULL) {
1536     StgPtr sp;
1537     StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
1538     rtsBool is_update_frame;
1539
1540     next_frame = frame->link;
1541     is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
1542
1543     /* Check to see if
1544      *   1. both the previous and current frame are update frames
1545      *   2. the current frame is empty
1546      */
1547     if (prev_was_update_frame && is_update_frame &&
1548         (P_)prev_frame == frame_bottom + displacement) {
1549
1550       /* Now squeeze out the current frame */
1551       StgClosure *updatee_keep   = prev_frame->updatee;
1552       StgClosure *updatee_bypass = frame->updatee;
1553
1554 #if 0 /* DEBUG */
1555       fprintf(stderr, "squeezing frame at %p\n", frame);
1556 #endif
1557
1558       /* Deal with blocking queues.  If both updatees have blocked
1559        * threads, then we should merge the queues into the update
1560        * frame that we're keeping.
1561        *
1562        * Alternatively, we could just wake them up: they'll just go
1563        * straight to sleep on the proper blackhole!  This is less code
1564        * and probably less bug prone, although it's probably much
1565        * slower --SDM
1566        */
1567 #if 0 /* do it properly... */
1568       if (GET_INFO(updatee_bypass) == BLACKHOLE_info
1569           || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
1570           ) {
1571         /* Sigh.  It has one.  Don't lose those threads! */
1572         if (GET_INFO(updatee_keep) == BLACKHOLE_info
1573             || GET_INFO(updatee_keep) == CAF_BLACKHOLE_info
1574             ) {
1575           /* Urgh.  Two queues.  Merge them. */
1576           P_ keep_tso = ((StgBlackHole *)updatee_keep)->blocking_queue;
1577
1578           while (keep_tso->link != END_TSO_QUEUE) {
1579             keep_tso = keep_tso->link;
1580           }
1581           keep_tso->link = ((StgBlackHole *)updatee_bypass)->blocking_queue;
1582
1583         } else {
1584           /* For simplicity, just swap the BQ for the BH */
1585           P_ temp = updatee_keep;
1586
1587           updatee_keep = updatee_bypass;
1588           updatee_bypass = temp;
1589
1590           /* Record the swap in the kept frame (below) */
1591           prev_frame->updatee = updatee_keep;
1592         }
1593       }
1594 #endif
1595
1596       TICK_UPD_SQUEEZED();
1597       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
1598
1599       sp = (P_)frame - 1;       /* sp = stuff to slide */
1600       displacement += sizeofW(StgUpdateFrame);
1601
1602     } else {
1603       /* No squeeze for this frame */
1604       sp = frame_bottom - 1;    /* Keep the current frame */
1605
1606       /* Do lazy black-holing.
1607        */
1608       if (is_update_frame) {
1609         StgBlackHole *bh = (StgBlackHole *)frame->updatee;
1610         if (bh->header.info != &BLACKHOLE_info
1611             && bh->header.info != &CAF_BLACKHOLE_info
1612             ) {
1613           SET_INFO(bh,&BLACKHOLE_info);
1614           bh->blocking_queue = stgCast(StgTSO*,&END_TSO_QUEUE_closure);
1615         }
1616       }
1617
1618       /* Fix the link in the current frame (should point to the frame below) */
1619       frame->link = prev_frame;
1620       prev_was_update_frame = is_update_frame;
1621     }
1622
1623     /* Now slide all words from sp up to the next frame */
1624
1625     if (displacement > 0) {
1626       P_ next_frame_bottom;
1627
1628       if (next_frame != NULL)
1629         next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
1630       else
1631         next_frame_bottom = tso->sp - 1;
1632
1633 #if 0 /* DEBUG */
1634       fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
1635               displacement);
1636 #endif
1637
1638       while (sp >= next_frame_bottom) {
1639         sp[displacement] = *sp;
1640         sp -= 1;
1641       }
1642     }
1643     (P_)prev_frame = (P_)frame + displacement;
1644     frame = next_frame;
1645   }
1646
1647   tso->sp += displacement;
1648   tso->su = prev_frame;
1649 }
1650
1651 /* -----------------------------------------------------------------------------
1652  * Pausing a thread
1653  *
1654  * We have to prepare for GC - this means doing lazy black holing
1655  * here.  We also take the opportunity to do stack squeezing if it's
1656  * turned on.
1657  * -------------------------------------------------------------------------- */
1658
1659 void
1660 threadPaused(StgTSO *tso)
1661 {
1662   if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
1663     threadSqueezeStack(tso);    /* does black holing too */
1664   else
1665     threadLazyBlackHole(tso);
1666 }