rts/sm/Compact.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team 2001-2008
   4  *
   5  * Compacting garbage collector
   6  *
   7  * Documentation on the architecture of the Garbage Collector can be
   8  * found in the online commentary:
   9  *
  10  *   http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
  11  *
  12  * ---------------------------------------------------------------------------*/
  13
  14 #include "PosixSource.h"
  15 #include "Rts.h"
  16
  17 #include "Storage.h"
  18 #include "RtsUtils.h"
  19 #include "BlockAlloc.h"
  20 #include "GC.h"
  21 #include "Compact.h"
  22 #include "Schedule.h"
  23 #include "Apply.h"
  24 #include "Trace.h"
  25 #include "Weak.h"
  26 #include "MarkWeak.h"
  27 #include "Stable.h"
  28
  29 // Turn off inlining when debugging - it obfuscates things
  30 #ifdef DEBUG
  31 # undef  STATIC_INLINE
  32 # define STATIC_INLINE static
  33 #endif
  34
  35 /* ----------------------------------------------------------------------------
  36    Threading / unthreading pointers.
  37
  38    The basic idea here is to chain together all the fields pointing at
  39    a particular object, with the root of the chain in the object's
  40    info table field.  The original contents of the info pointer goes
  41    at the end of the chain.
  42
  43    Adding a new field to the chain is a matter of swapping the
  44    contents of the field with the contents of the object's info table
  45    field.
  46
  47    To unthread the chain, we walk down it updating all the fields on
  48    the chain with the new location of the object.  We stop when we
  49    reach the info pointer at the end.
  50
  51    The main difficulty here is that we need to be able to identify the
  52    info pointer at the end of the chain.  We can't use the low bits of
  53    the pointer for this; they are already being used for
  54    pointer-tagging.  What's more, we need to retain the
  55    pointer-tagging tag bits on each pointer during the
  56    threading/unthreading process.
  57
  58    Our solution is as follows:
  59      - an info pointer (chain length zero) is identified by having tag 0
  60      - in a threaded chain of length > 0:
  61         - the pointer-tagging tag bits are attached to the info pointer
  62         - the first entry in the chain has tag 1
  63         - second and subsequent entries in the chain have tag 2
  64
  65    This exploits the fact that the tag on each pointer to a given
  66    closure is normally the same (if they are not the same, then
  67    presumably the tag is not essential and it therefore doesn't matter
  68    if we throw away some of the tags).
  69    ------------------------------------------------------------------------- */
  70
  71 STATIC_INLINE void
  72 thread (StgClosure **p)
  73 {
  74     StgClosure *q0;
  75     StgPtr q;
  76     StgWord iptr;
  77     bdescr *bd;
  78
  79     q0  = *p;
  80     q   = (StgPtr)UNTAG_CLOSURE(q0);
  81
  82     // It doesn't look like a closure at the moment, because the info
  83     // ptr is possibly threaded:
  84     // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
  85
  86     if (HEAP_ALLOCED(q)) {
  87         bd = Bdescr(q);
  88
  89         if (bd->flags & BF_MARKED)
  90         {
  91             iptr = *q;
  92             switch (GET_CLOSURE_TAG((StgClosure *)iptr))
  93             {
  94             case 0:
  95                 // this is the info pointer; we are creating a new chain.
  96                 // save the original tag at the end of the chain.
  97                 *p = (StgClosure *)((StgWord)iptr + GET_CLOSURE_TAG(q0));
  98                 *q = (StgWord)p + 1;
  99                 break;
 100             case 1:
 101             case 2:
 102                 // this is a chain of length 1 or more
 103                 *p = (StgClosure *)iptr;
 104                 *q = (StgWord)p + 2;
 105                 break;
 106             }
 107         }
 108     }
 109 }
 110
 111 static void
 112 thread_root (void *user STG_UNUSED, StgClosure **p)
 113 {
 114     thread(p);
 115 }
 116
 117 // This version of thread() takes a (void *), used to circumvent
 118 // warnings from gcc about pointer punning and strict aliasing.
 119 STATIC_INLINE void thread_ (void *p) { thread((StgClosure **)p); }
 120
 121 STATIC_INLINE void
 122 unthread( StgPtr p, StgWord free )
 123 {
 124     StgWord q, r;
 125     StgPtr q0;
 126
 127     q = *p;
 128 loop:
 129     switch (GET_CLOSURE_TAG((StgClosure *)q))
 130     {
 131     case 0:
 132         // nothing to do; the chain is length zero
 133         return;
 134     case 1:
 135         q0 = (StgPtr)(q-1);
 136         r = *q0;  // r is the info ptr, tagged with the pointer-tag
 137         *q0 = free;
 138         *p = (StgWord)UNTAG_CLOSURE((StgClosure *)r);
 139         return;
 140     case 2:
 141         q0 = (StgPtr)(q-2);
 142         r = *q0;
 143         *q0 = free;
 144         q = r;
 145         goto loop;
 146     default:
 147         barf("unthread");
 148     }
 149 }
 150
 151 // Traverse a threaded chain and pull out the info pointer at the end.
 152 // The info pointer is also tagged with the appropriate pointer tag
 153 // for this closure, which should be attached to the pointer
 154 // subsequently passed to unthread().
 155 STATIC_INLINE StgWord
 156 get_threaded_info( StgPtr p )
 157 {
 158     StgWord q;
 159
 160     q = (W_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
 161
 162 loop:
 163     switch (GET_CLOSURE_TAG((StgClosure *)q))
 164     {
 165     case 0:
 166         ASSERT(LOOKS_LIKE_INFO_PTR(q));
 167         return q;
 168     case 1:
 169     {
 170         StgWord r = *(StgPtr)(q-1);
 171         ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)UNTAG_CLOSURE((StgClosure *)r)));
 172         return r;
 173     }
 174     case 2:
 175         q = *(StgPtr)(q-2);
 176         goto loop;
 177     default:
 178         barf("get_threaded_info");
 179     }
 180 }
 181
 182 // A word-aligned memmove will be faster for small objects than libc's or gcc's.
 183 // Remember, the two regions *might* overlap, but: to <= from.
 184 STATIC_INLINE void
 185 move(StgPtr to, StgPtr from, nat size)
 186 {
 187     for(; size > 0; --size) {
 188         *to++ = *from++;
 189     }
 190 }
 191
 192 static void
 193 thread_static( StgClosure* p )
 194 {
 195   const StgInfoTable *info;
 196
 197   // keep going until we've threaded all the objects on the linked
 198   // list...
 199   while (p != END_OF_STATIC_LIST) {
 200
 201     info = get_itbl(p);
 202     switch (info->type) {
 203
 204     case IND_STATIC:
 205         thread(&((StgInd *)p)->indirectee);
 206         p = *IND_STATIC_LINK(p);
 207         continue;
 208
 209     case THUNK_STATIC:
 210         p = *THUNK_STATIC_LINK(p);
 211         continue;
 212     case FUN_STATIC:
 213         p = *FUN_STATIC_LINK(p);
 214         continue;
 215     case CONSTR_STATIC:
 216         p = *STATIC_LINK(info,p);
 217         continue;
 218
 219     default:
 220         barf("thread_static: strange closure %d", (int)(info->type));
 221     }
 222
 223   }
 224 }
 225
 226 STATIC_INLINE void
 227 thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
 228 {
 229     nat i, b;
 230     StgWord bitmap;
 231
 232     b = 0;
 233     bitmap = large_bitmap->bitmap[b];
 234     for (i = 0; i < size; ) {
 235         if ((bitmap & 1) == 0) {
 236             thread((StgClosure **)p);
 237         }
 238         i++;
 239         p++;
 240         if (i % BITS_IN(W_) == 0) {
 241             b++;
 242             bitmap = large_bitmap->bitmap[b];
 243         } else {
 244             bitmap = bitmap >> 1;
 245         }
 246     }
 247 }
 248
 249 STATIC_INLINE StgPtr
 250 thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
 251 {
 252     StgPtr p;
 253     StgWord bitmap;
 254     nat size;
 255
 256     p = (StgPtr)args;
 257     switch (fun_info->f.fun_type) {
 258     case ARG_GEN:
 259         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
 260         size = BITMAP_SIZE(fun_info->f.b.bitmap);
 261         goto small_bitmap;
 262     case ARG_GEN_BIG:
 263         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
 264         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 265         p += size;
 266         break;
 267     default:
 268         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 269         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 270     small_bitmap:
 271         while (size > 0) {
 272             if ((bitmap & 1) == 0) {
 273                 thread((StgClosure **)p);
 274             }
 275             p++;
 276             bitmap = bitmap >> 1;
 277             size--;
 278         }
 279         break;
 280     }
 281     return p;
 282 }
 283
 284 static void
 285 thread_stack(StgPtr p, StgPtr stack_end)
 286 {
 287     const StgRetInfoTable* info;
 288     StgWord bitmap;
 289     nat size;
 290
 291     // highly similar to scavenge_stack, but we do pointer threading here.
 292
 293     while (p < stack_end) {
 294
 295         // *p must be the info pointer of an activation
 296         // record.  All activation records have 'bitmap' style layout
 297         // info.
 298         //
 299         info  = get_ret_itbl((StgClosure *)p);
 300
 301         switch (info->i.type) {
 302
 303             // Dynamic bitmap: the mask is stored on the stack
 304         case RET_DYN:
 305         {
 306             StgWord dyn;
 307             dyn = ((StgRetDyn *)p)->liveness;
 308
 309             // traverse the bitmap first
 310             bitmap = RET_DYN_LIVENESS(dyn);
 311             p      = (P_)&((StgRetDyn *)p)->payload[0];
 312             size   = RET_DYN_BITMAP_SIZE;
 313             while (size > 0) {
 314                 if ((bitmap & 1) == 0) {
 315                     thread((StgClosure **)p);
 316                 }
 317                 p++;
 318                 bitmap = bitmap >> 1;
 319                 size--;
 320             }
 321
 322             // skip over the non-ptr words
 323             p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
 324
 325             // follow the ptr words
 326             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 327                 thread((StgClosure **)p);
 328                 p++;
 329             }
 330             continue;
 331         }
 332
 333             // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
 334         case CATCH_RETRY_FRAME:
 335         case CATCH_STM_FRAME:
 336         case ATOMICALLY_FRAME:
 337         case UPDATE_FRAME:
 338         case STOP_FRAME:
 339         case CATCH_FRAME:
 340         case RET_SMALL:
 341             bitmap = BITMAP_BITS(info->i.layout.bitmap);
 342             size   = BITMAP_SIZE(info->i.layout.bitmap);
 343             p++;
 344             // NOTE: the payload starts immediately after the info-ptr, we
 345             // don't have an StgHeader in the same sense as a heap closure.
 346             while (size > 0) {
 347                 if ((bitmap & 1) == 0) {
 348                     thread((StgClosure **)p);
 349                 }
 350                 p++;
 351                 bitmap = bitmap >> 1;
 352                 size--;
 353             }
 354             continue;
 355
 356         case RET_BCO: {
 357             StgBCO *bco;
 358             nat size;
 359
 360             p++;
 361             bco = (StgBCO *)*p;
 362             thread((StgClosure **)p);
 363             p++;
 364             size = BCO_BITMAP_SIZE(bco);
 365             thread_large_bitmap(p, BCO_BITMAP(bco), size);
 366             p += size;
 367             continue;
 368         }
 369
 370             // large bitmap (> 32 entries, or 64 on a 64-bit machine)
 371         case RET_BIG:
 372             p++;
 373             size = GET_LARGE_BITMAP(&info->i)->size;
 374             thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
 375             p += size;
 376             continue;
 377
 378         case RET_FUN:
 379         {
 380             StgRetFun *ret_fun = (StgRetFun *)p;
 381             StgFunInfoTable *fun_info;
 382
 383             fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
 384                            get_threaded_info((StgPtr)ret_fun->fun)));
 385                  // *before* threading it!
 386             thread(&ret_fun->fun);
 387             p = thread_arg_block(fun_info, ret_fun->payload);
 388             continue;
 389         }
 390
 391         default:
 392             barf("thread_stack: weird activation record found on stack: %d",
 393                  (int)(info->i.type));
 394         }
 395     }
 396 }
 397
 398 STATIC_INLINE StgPtr
 399 thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
 400 {
 401     StgPtr p;
 402     StgWord bitmap;
 403     StgFunInfoTable *fun_info;
 404
 405     fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
 406                         get_threaded_info((StgPtr)fun)));
 407     ASSERT(fun_info->i.type != PAP);
 408
 409     p = (StgPtr)payload;
 410
 411     switch (fun_info->f.fun_type) {
 412     case ARG_GEN:
 413         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
 414         goto small_bitmap;
 415     case ARG_GEN_BIG:
 416         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 417         p += size;
 418         break;
 419     case ARG_BCO:
 420         thread_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
 421         p += size;
 422         break;
 423     default:
 424         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 425     small_bitmap:
 426         while (size > 0) {
 427             if ((bitmap & 1) == 0) {
 428                 thread((StgClosure **)p);
 429             }
 430             p++;
 431             bitmap = bitmap >> 1;
 432             size--;
 433         }
 434         break;
 435     }
 436
 437     return p;
 438 }
 439
 440 STATIC_INLINE StgPtr
 441 thread_PAP (StgPAP *pap)
 442 {
 443     StgPtr p;
 444     p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
 445     thread(&pap->fun);
 446     return p;
 447 }
 448
 449 STATIC_INLINE StgPtr
 450 thread_AP (StgAP *ap)
 451 {
 452     StgPtr p;
 453     p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
 454     thread(&ap->fun);
 455     return p;
 456 }
 457
 458 STATIC_INLINE StgPtr
 459 thread_AP_STACK (StgAP_STACK *ap)
 460 {
 461     thread(&ap->fun);
 462     thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
 463     return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
 464 }
 465
 466 static StgPtr
 467 thread_TSO (StgTSO *tso)
 468 {
 469     thread_(&tso->_link);
 470     thread_(&tso->global_link);
 471
 472     if (   tso->why_blocked == BlockedOnMVar
 473         || tso->why_blocked == BlockedOnBlackHole
 474         || tso->why_blocked == BlockedOnException
 475         ) {
 476         thread_(&tso->block_info.closure);
 477     }
 478     thread_(&tso->blocked_exceptions);
 479
 480     thread_(&tso->trec);
 481
 482     thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 483     return (StgPtr)tso + tso_sizeW(tso);
 484 }
 485
 486
 487 static void
 488 update_fwd_large( bdescr *bd )
 489 {
 490   StgPtr p;
 491   const StgInfoTable* info;
 492
 493   for (; bd != NULL; bd = bd->link) {
 494
 495     // nothing to do in a pinned block; it might not even have an object
 496     // at the beginning.
 497     if (bd->flags & BF_PINNED) continue;
 498
 499     p = bd->start;
 500     info  = get_itbl((StgClosure *)p);
 501
 502     switch (info->type) {
 503
 504     case ARR_WORDS:
 505       // nothing to follow
 506       continue;
 507
 508     case MUT_ARR_PTRS_CLEAN:
 509     case MUT_ARR_PTRS_DIRTY:
 510     case MUT_ARR_PTRS_FROZEN:
 511     case MUT_ARR_PTRS_FROZEN0:
 512       // follow everything
 513       {
 514         StgPtr next;
 515
 516         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 517         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 518             thread((StgClosure **)p);
 519         }
 520         continue;
 521       }
 522
 523     case TSO:
 524         thread_TSO((StgTSO *)p);
 525         continue;
 526
 527     case AP_STACK:
 528         thread_AP_STACK((StgAP_STACK *)p);
 529         continue;
 530
 531     case PAP:
 532         thread_PAP((StgPAP *)p);
 533         continue;
 534
 535     case TREC_CHUNK:
 536     {
 537         StgWord i;
 538         StgTRecChunk *tc = (StgTRecChunk *)p;
 539         TRecEntry *e = &(tc -> entries[0]);
 540         thread_(&tc->prev_chunk);
 541         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 542           thread_(&e->tvar);
 543           thread(&e->expected_value);
 544           thread(&e->new_value);
 545         }
 546         continue;
 547     }
 548
 549     default:
 550       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 551     }
 552   }
 553 }
 554
 555 // ToDo: too big to inline
 556 static /* STATIC_INLINE */ StgPtr
 557 thread_obj (StgInfoTable *info, StgPtr p)
 558 {
 559     switch (info->type) {
 560     case THUNK_0_1:
 561         return p + sizeofW(StgThunk) + 1;
 562
 563     case FUN_0_1:
 564     case CONSTR_0_1:
 565         return p + sizeofW(StgHeader) + 1;
 566
 567     case FUN_1_0:
 568     case CONSTR_1_0:
 569         thread(&((StgClosure *)p)->payload[0]);
 570         return p + sizeofW(StgHeader) + 1;
 571
 572     case THUNK_1_0:
 573         thread(&((StgThunk *)p)->payload[0]);
 574         return p + sizeofW(StgThunk) + 1;
 575
 576     case THUNK_0_2:
 577         return p + sizeofW(StgThunk) + 2;
 578
 579     case FUN_0_2:
 580     case CONSTR_0_2:
 581         return p + sizeofW(StgHeader) + 2;
 582
 583     case THUNK_1_1:
 584         thread(&((StgThunk *)p)->payload[0]);
 585         return p + sizeofW(StgThunk) + 2;
 586
 587     case FUN_1_1:
 588     case CONSTR_1_1:
 589         thread(&((StgClosure *)p)->payload[0]);
 590         return p + sizeofW(StgHeader) + 2;
 591
 592     case THUNK_2_0:
 593         thread(&((StgThunk *)p)->payload[0]);
 594         thread(&((StgThunk *)p)->payload[1]);
 595         return p + sizeofW(StgThunk) + 2;
 596
 597     case FUN_2_0:
 598     case CONSTR_2_0:
 599         thread(&((StgClosure *)p)->payload[0]);
 600         thread(&((StgClosure *)p)->payload[1]);
 601         return p + sizeofW(StgHeader) + 2;
 602
 603     case BCO: {
 604         StgBCO *bco = (StgBCO *)p;
 605         thread_(&bco->instrs);
 606         thread_(&bco->literals);
 607         thread_(&bco->ptrs);
 608         return p + bco_sizeW(bco);
 609     }
 610
 611     case THUNK:
 612     {
 613         StgPtr end;
 614
 615         end = (P_)((StgThunk *)p)->payload +
 616             info->layout.payload.ptrs;
 617         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
 618             thread((StgClosure **)p);
 619         }
 620         return p + info->layout.payload.nptrs;
 621     }
 622
 623     case FUN:
 624     case CONSTR:
 625     case STABLE_NAME:
 626     case IND_PERM:
 627     case MUT_VAR_CLEAN:
 628     case MUT_VAR_DIRTY:
 629     case CAF_BLACKHOLE:
 630     case BLACKHOLE:
 631     {
 632         StgPtr end;
 633
 634         end = (P_)((StgClosure *)p)->payload +
 635             info->layout.payload.ptrs;
 636         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 637             thread((StgClosure **)p);
 638         }
 639         return p + info->layout.payload.nptrs;
 640     }
 641
 642     case WEAK:
 643     {
 644         StgWeak *w = (StgWeak *)p;
 645         thread(&w->cfinalizer);
 646         thread(&w->key);
 647         thread(&w->value);
 648         thread(&w->finalizer);
 649         if (w->link != NULL) {
 650             thread_(&w->link);
 651         }
 652         return p + sizeofW(StgWeak);
 653     }
 654
 655     case MVAR_CLEAN:
 656     case MVAR_DIRTY:
 657     {
 658         StgMVar *mvar = (StgMVar *)p;
 659         thread_(&mvar->head);
 660         thread_(&mvar->tail);
 661         thread(&mvar->value);
 662         return p + sizeofW(StgMVar);
 663     }
 664
 665     case IND_OLDGEN:
 666     case IND_OLDGEN_PERM:
 667         thread(&((StgInd *)p)->indirectee);
 668         return p + sizeofW(StgInd);
 669
 670     case THUNK_SELECTOR:
 671     {
 672         StgSelector *s = (StgSelector *)p;
 673         thread(&s->selectee);
 674         return p + THUNK_SELECTOR_sizeW();
 675     }
 676
 677     case AP_STACK:
 678         return thread_AP_STACK((StgAP_STACK *)p);
 679
 680     case PAP:
 681         return thread_PAP((StgPAP *)p);
 682
 683     case AP:
 684         return thread_AP((StgAP *)p);
 685
 686     case ARR_WORDS:
 687         return p + arr_words_sizeW((StgArrWords *)p);
 688
 689     case MUT_ARR_PTRS_CLEAN:
 690     case MUT_ARR_PTRS_DIRTY:
 691     case MUT_ARR_PTRS_FROZEN:
 692     case MUT_ARR_PTRS_FROZEN0:
 693         // follow everything
 694     {
 695         StgPtr next;
 696
 697         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 698         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 699             thread((StgClosure **)p);
 700         }
 701         return p;
 702     }
 703
 704     case TSO:
 705         return thread_TSO((StgTSO *)p);
 706
 707     case TVAR_WATCH_QUEUE:
 708     {
 709         StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
 710         thread_(&wq->closure);
 711         thread_(&wq->next_queue_entry);
 712         thread_(&wq->prev_queue_entry);
 713         return p + sizeofW(StgTVarWatchQueue);
 714     }
 715
 716     case TVAR:
 717     {
 718         StgTVar *tvar = (StgTVar *)p;
 719         thread((void *)&tvar->current_value);
 720         thread((void *)&tvar->first_watch_queue_entry);
 721         return p + sizeofW(StgTVar);
 722     }
 723
 724     case TREC_HEADER:
 725     {
 726         StgTRecHeader *trec = (StgTRecHeader *)p;
 727         thread_(&trec->enclosing_trec);
 728         thread_(&trec->current_chunk);
 729         thread_(&trec->invariants_to_check);
 730         return p + sizeofW(StgTRecHeader);
 731     }
 732
 733     case TREC_CHUNK:
 734     {
 735         StgWord i;
 736         StgTRecChunk *tc = (StgTRecChunk *)p;
 737         TRecEntry *e = &(tc -> entries[0]);
 738         thread_(&tc->prev_chunk);
 739         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 740           thread_(&e->tvar);
 741           thread(&e->expected_value);
 742           thread(&e->new_value);
 743         }
 744         return p + sizeofW(StgTRecChunk);
 745     }
 746
 747     case ATOMIC_INVARIANT:
 748     {
 749         StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
 750         thread_(&invariant->code);
 751         thread_(&invariant->last_execution);
 752         return p + sizeofW(StgAtomicInvariant);
 753     }
 754
 755     case INVARIANT_CHECK_QUEUE:
 756     {
 757         StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p;
 758         thread_(&queue->invariant);
 759         thread_(&queue->my_execution);
 760         thread_(&queue->next_queue_entry);
 761         return p + sizeofW(StgInvariantCheckQueue);
 762     }
 763
 764     default:
 765         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 766         return NULL;
 767     }
 768 }
 769
 770 static void
 771 update_fwd( bdescr *blocks )
 772 {
 773     StgPtr p;
 774     bdescr *bd;
 775     StgInfoTable *info;
 776
 777     bd = blocks;
 778
 779     // cycle through all the blocks in the step
 780     for (; bd != NULL; bd = bd->link) {
 781         p = bd->start;
 782
 783         // linearly scan the objects in this block
 784         while (p < bd->free) {
 785             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 786             info = get_itbl((StgClosure *)p);
 787             p = thread_obj(info, p);
 788         }
 789     }
 790 }
 791
 792 static void
 793 update_fwd_compact( bdescr *blocks )
 794 {
 795     StgPtr p, q, free;
 796 #if 0
 797     StgWord m;
 798 #endif
 799     bdescr *bd, *free_bd;
 800     StgInfoTable *info;
 801     nat size;
 802     StgWord iptr;
 803
 804     bd = blocks;
 805     free_bd = blocks;
 806     free = free_bd->start;
 807
 808     // cycle through all the blocks in the step
 809     for (; bd != NULL; bd = bd->link) {
 810         p = bd->start;
 811
 812         while (p < bd->free ) {
 813
 814             while ( p < bd->free && !is_marked(p,bd) ) {
 815                 p++;
 816             }
 817             if (p >= bd->free) {
 818                 break;
 819             }
 820
 821 #if 0
 822     next:
 823         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 824         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 825
 826         while ( p < bd->free ) {
 827
 828             if ((m & 1) == 0) {
 829                 m >>= 1;
 830                 p++;
 831                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 832                     goto next;
 833                 } else {
 834                     continue;
 835                 }
 836             }
 837 #endif
 838
 839             // Problem: we need to know the destination for this cell
 840             // in order to unthread its info pointer.  But we can't
 841             // know the destination without the size, because we may
 842             // spill into the next block.  So we have to run down the
 843             // threaded list and get the info ptr first.
 844             //
 845             // ToDo: one possible avenue of attack is to use the fact
 846             // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
 847             // definitely have enough room.  Also see bug #1147.
 848             iptr = get_threaded_info(p);
 849             info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
 850
 851             q = p;
 852
 853             p = thread_obj(info, p);
 854
 855             size = p - q;
 856             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 857                 // unset the next bit in the bitmap to indicate that
 858                 // this object needs to be pushed into the next
 859                 // block.  This saves us having to run down the
 860                 // threaded info pointer list twice during the next pass.
 861                 unmark(q+1,bd);
 862                 free_bd = free_bd->link;
 863                 free = free_bd->start;
 864             } else {
 865                 ASSERT(is_marked(q+1,bd));
 866             }
 867
 868             unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
 869             free += size;
 870 #if 0
 871             goto next;
 872 #endif
 873         }
 874     }
 875 }
 876
 877 static nat
 878 update_bkwd_compact( step *stp )
 879 {
 880     StgPtr p, free;
 881 #if 0
 882     StgWord m;
 883 #endif
 884     bdescr *bd, *free_bd;
 885     StgInfoTable *info;
 886     nat size, free_blocks;
 887     StgWord iptr;
 888
 889     bd = free_bd = stp->old_blocks;
 890     free = free_bd->start;
 891     free_blocks = 1;
 892
 893     // cycle through all the blocks in the step
 894     for (; bd != NULL; bd = bd->link) {
 895         p = bd->start;
 896
 897         while (p < bd->free ) {
 898
 899             while ( p < bd->free && !is_marked(p,bd) ) {
 900                 p++;
 901             }
 902             if (p >= bd->free) {
 903                 break;
 904             }
 905
 906 #if 0
 907     next:
 908         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 909         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 910
 911         while ( p < bd->free ) {
 912
 913             if ((m & 1) == 0) {
 914                 m >>= 1;
 915                 p++;
 916                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 917                     goto next;
 918                 } else {
 919                     continue;
 920                 }
 921             }
 922 #endif
 923
 924             if (!is_marked(p+1,bd)) {
 925                 // don't forget to update the free ptr in the block desc.
 926                 free_bd->free = free;
 927                 free_bd = free_bd->link;
 928                 free = free_bd->start;
 929                 free_blocks++;
 930             }
 931
 932             iptr = get_threaded_info(p);
 933             unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
 934             ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
 935             info = get_itbl((StgClosure *)p);
 936             size = closure_sizeW_((StgClosure *)p,info);
 937
 938             if (free != p) {
 939                 move(free,p,size);
 940             }
 941
 942             // relocate TSOs
 943             if (info->type == TSO) {
 944                 move_TSO((StgTSO *)p, (StgTSO *)free);
 945             }
 946
 947             free += size;
 948             p += size;
 949 #if 0
 950             goto next;
 951 #endif
 952         }
 953     }
 954
 955     // free the remaining blocks and count what's left.
 956     free_bd->free = free;
 957     if (free_bd->link != NULL) {
 958         freeChain(free_bd->link);
 959         free_bd->link = NULL;
 960     }
 961
 962     return free_blocks;
 963 }
 964
 965 void
 966 compact(StgClosure *static_objects)
 967 {
 968     nat g, s, blocks;
 969     step *stp;
 970
 971     // 1. thread the roots
 972     markCapabilities((evac_fn)thread_root, NULL);
 973
 974     // the weak pointer lists...
 975     if (weak_ptr_list != NULL) {
 976         thread((void *)&weak_ptr_list);
 977     }
 978     if (old_weak_ptr_list != NULL) {
 979         thread((void *)&old_weak_ptr_list); // tmp
 980     }
 981
 982     // mutable lists
 983     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 984         bdescr *bd;
 985         StgPtr p;
 986         nat n;
 987         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 988             for (p = bd->start; p < bd->free; p++) {
 989                 thread((StgClosure **)p);
 990             }
 991         }
 992         for (n = 0; n < n_capabilities; n++) {
 993             for (bd = capabilities[n].mut_lists[g];
 994                  bd != NULL; bd = bd->link) {
 995                 for (p = bd->start; p < bd->free; p++) {
 996                     thread((StgClosure **)p);
 997                 }
 998             }
 999         }
1000     }
1001
1002     // the global thread list
1003     for (s = 0; s < total_steps; s++) {
1004         thread((void *)&all_steps[s].threads);
1005     }
1006
1007     // any threads resurrected during this GC
1008     thread((void *)&resurrected_threads);
1009
1010     // the blackhole queue
1011     thread((void *)&blackhole_queue);
1012
1013     // the task list
1014     {
1015         Task *task;
1016         for (task = all_tasks; task != NULL; task = task->all_link) {
1017             if (task->tso) {
1018                 thread_(&task->tso);
1019             }
1020         }
1021     }
1022
1023     // the static objects
1024     thread_static(static_objects /* ToDo: ok? */);
1025
1026     // the stable pointer table
1027     threadStablePtrTable((evac_fn)thread_root, NULL);
1028
1029     // the CAF list (used by GHCi)
1030     markCAFs((evac_fn)thread_root, NULL);
1031
1032     // 2. update forward ptrs
1033     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1034         for (s = 0; s < generations[g].n_steps; s++) {
1035             if (g==0 && s ==0) continue;
1036             stp = &generations[g].steps[s];
1037             debugTrace(DEBUG_gc, "update_fwd:  %d.%d",
1038                        stp->gen->no, stp->no);
1039
1040             update_fwd(stp->blocks);
1041             update_fwd_large(stp->scavenged_large_objects);
1042             if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
1043                 debugTrace(DEBUG_gc, "update_fwd:  %d.%d (compact)",
1044                            stp->gen->no, stp->no);
1045                 update_fwd_compact(stp->old_blocks);
1046             }
1047         }
1048     }
1049
1050     // 3. update backward ptrs
1051     stp = &oldest_gen->steps[0];
1052     if (stp->old_blocks != NULL) {
1053         blocks = update_bkwd_compact(stp);
1054         debugTrace(DEBUG_gc,
1055                    "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
1056                    stp->gen->no, stp->no,
1057                    stp->n_old_blocks, blocks);
1058         stp->n_old_blocks = blocks;
1059     }
1060 }