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           StgMutArrPtrs *a;
 515
 516           a = (StgMutArrPtrs*)p;
 517           for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; 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         StgMutArrPtrs *a;
 696
 697         a = (StgMutArrPtrs *)p;
 698         for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
 699             thread((StgClosure **)p);
 700         }
 701
 702         return (StgPtr)a + mut_arr_ptrs_sizeW(a);
 703     }
 704
 705     case TSO:
 706         return thread_TSO((StgTSO *)p);
 707
 708     case TVAR_WATCH_QUEUE:
 709     {
 710         StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
 711         thread_(&wq->closure);
 712         thread_(&wq->next_queue_entry);
 713         thread_(&wq->prev_queue_entry);
 714         return p + sizeofW(StgTVarWatchQueue);
 715     }
 716
 717     case TVAR:
 718     {
 719         StgTVar *tvar = (StgTVar *)p;
 720         thread((void *)&tvar->current_value);
 721         thread((void *)&tvar->first_watch_queue_entry);
 722         return p + sizeofW(StgTVar);
 723     }
 724
 725     case TREC_HEADER:
 726     {
 727         StgTRecHeader *trec = (StgTRecHeader *)p;
 728         thread_(&trec->enclosing_trec);
 729         thread_(&trec->current_chunk);
 730         thread_(&trec->invariants_to_check);
 731         return p + sizeofW(StgTRecHeader);
 732     }
 733
 734     case TREC_CHUNK:
 735     {
 736         StgWord i;
 737         StgTRecChunk *tc = (StgTRecChunk *)p;
 738         TRecEntry *e = &(tc -> entries[0]);
 739         thread_(&tc->prev_chunk);
 740         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 741           thread_(&e->tvar);
 742           thread(&e->expected_value);
 743           thread(&e->new_value);
 744         }
 745         return p + sizeofW(StgTRecChunk);
 746     }
 747
 748     case ATOMIC_INVARIANT:
 749     {
 750         StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
 751         thread_(&invariant->code);
 752         thread_(&invariant->last_execution);
 753         return p + sizeofW(StgAtomicInvariant);
 754     }
 755
 756     case INVARIANT_CHECK_QUEUE:
 757     {
 758         StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p;
 759         thread_(&queue->invariant);
 760         thread_(&queue->my_execution);
 761         thread_(&queue->next_queue_entry);
 762         return p + sizeofW(StgInvariantCheckQueue);
 763     }
 764
 765     default:
 766         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 767         return NULL;
 768     }
 769 }
 770
 771 static void
 772 update_fwd( bdescr *blocks )
 773 {
 774     StgPtr p;
 775     bdescr *bd;
 776     StgInfoTable *info;
 777
 778     bd = blocks;
 779
 780     // cycle through all the blocks in the step
 781     for (; bd != NULL; bd = bd->link) {
 782         p = bd->start;
 783
 784         // linearly scan the objects in this block
 785         while (p < bd->free) {
 786             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 787             info = get_itbl((StgClosure *)p);
 788             p = thread_obj(info, p);
 789         }
 790     }
 791 }
 792
 793 static void
 794 update_fwd_compact( bdescr *blocks )
 795 {
 796     StgPtr p, q, free;
 797 #if 0
 798     StgWord m;
 799 #endif
 800     bdescr *bd, *free_bd;
 801     StgInfoTable *info;
 802     nat size;
 803     StgWord iptr;
 804
 805     bd = blocks;
 806     free_bd = blocks;
 807     free = free_bd->start;
 808
 809     // cycle through all the blocks in the step
 810     for (; bd != NULL; bd = bd->link) {
 811         p = bd->start;
 812
 813         while (p < bd->free ) {
 814
 815             while ( p < bd->free && !is_marked(p,bd) ) {
 816                 p++;
 817             }
 818             if (p >= bd->free) {
 819                 break;
 820             }
 821
 822 #if 0
 823     next:
 824         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 825         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 826
 827         while ( p < bd->free ) {
 828
 829             if ((m & 1) == 0) {
 830                 m >>= 1;
 831                 p++;
 832                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 833                     goto next;
 834                 } else {
 835                     continue;
 836                 }
 837             }
 838 #endif
 839
 840             // Problem: we need to know the destination for this cell
 841             // in order to unthread its info pointer.  But we can't
 842             // know the destination without the size, because we may
 843             // spill into the next block.  So we have to run down the
 844             // threaded list and get the info ptr first.
 845             //
 846             // ToDo: one possible avenue of attack is to use the fact
 847             // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
 848             // definitely have enough room.  Also see bug #1147.
 849             iptr = get_threaded_info(p);
 850             info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
 851
 852             q = p;
 853
 854             p = thread_obj(info, p);
 855
 856             size = p - q;
 857             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 858                 // set the next bit in the bitmap to indicate that
 859                 // this object needs to be pushed into the next
 860                 // block.  This saves us having to run down the
 861                 // threaded info pointer list twice during the next pass.
 862                 mark(q+1,bd);
 863                 free_bd = free_bd->link;
 864                 free = free_bd->start;
 865             } else {
 866                 ASSERT(!is_marked(q+1,bd));
 867             }
 868
 869             unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
 870             free += size;
 871 #if 0
 872             goto next;
 873 #endif
 874         }
 875     }
 876 }
 877
 878 static nat
 879 update_bkwd_compact( generation *gen )
 880 {
 881     StgPtr p, free;
 882 #if 0
 883     StgWord m;
 884 #endif
 885     bdescr *bd, *free_bd;
 886     StgInfoTable *info;
 887     nat size, free_blocks;
 888     StgWord iptr;
 889
 890     bd = free_bd = gen->old_blocks;
 891     free = free_bd->start;
 892     free_blocks = 1;
 893
 894     // cycle through all the blocks in the step
 895     for (; bd != NULL; bd = bd->link) {
 896         p = bd->start;
 897
 898         while (p < bd->free ) {
 899
 900             while ( p < bd->free && !is_marked(p,bd) ) {
 901                 p++;
 902             }
 903             if (p >= bd->free) {
 904                 break;
 905             }
 906
 907 #if 0
 908     next:
 909         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 910         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 911
 912         while ( p < bd->free ) {
 913
 914             if ((m & 1) == 0) {
 915                 m >>= 1;
 916                 p++;
 917                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 918                     goto next;
 919                 } else {
 920                     continue;
 921                 }
 922             }
 923 #endif
 924
 925             if (is_marked(p+1,bd)) {
 926                 // don't forget to update the free ptr in the block desc.
 927                 free_bd->free = free;
 928                 free_bd = free_bd->link;
 929                 free = free_bd->start;
 930                 free_blocks++;
 931             }
 932
 933             iptr = get_threaded_info(p);
 934             unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
 935             ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
 936             info = get_itbl((StgClosure *)p);
 937             size = closure_sizeW_((StgClosure *)p,info);
 938
 939             if (free != p) {
 940                 move(free,p,size);
 941             }
 942
 943             // relocate TSOs
 944             if (info->type == TSO) {
 945                 move_TSO((StgTSO *)p, (StgTSO *)free);
 946             }
 947
 948             free += size;
 949             p += size;
 950 #if 0
 951             goto next;
 952 #endif
 953         }
 954     }
 955
 956     // free the remaining blocks and count what's left.
 957     free_bd->free = free;
 958     if (free_bd->link != NULL) {
 959         freeChain(free_bd->link);
 960         free_bd->link = NULL;
 961     }
 962
 963     return free_blocks;
 964 }
 965
 966 void
 967 compact(StgClosure *static_objects)
 968 {
 969     nat g, blocks;
 970     generation *gen;
 971
 972     // 1. thread the roots
 973     markCapabilities((evac_fn)thread_root, NULL);
 974
 975     // the weak pointer lists...
 976     if (weak_ptr_list != NULL) {
 977         thread((void *)&weak_ptr_list);
 978     }
 979     if (old_weak_ptr_list != NULL) {
 980         thread((void *)&old_weak_ptr_list); // tmp
 981     }
 982
 983     // mutable lists
 984     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 985         bdescr *bd;
 986         StgPtr p;
 987         nat n;
 988         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 989             for (p = bd->start; p < bd->free; p++) {
 990                 thread((StgClosure **)p);
 991             }
 992         }
 993         for (n = 0; n < n_capabilities; n++) {
 994             for (bd = capabilities[n].mut_lists[g];
 995                  bd != NULL; bd = bd->link) {
 996                 for (p = bd->start; p < bd->free; p++) {
 997                     thread((StgClosure **)p);
 998                 }
 999             }
1000         }
1001     }
1002
1003     // the global thread list
1004     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1005         thread((void *)&generations[g].threads);
1006     }
1007
1008     // any threads resurrected during this GC
1009     thread((void *)&resurrected_threads);
1010
1011     // the blackhole queue
1012     thread((void *)&blackhole_queue);
1013
1014     // the task list
1015     {
1016         Task *task;
1017         for (task = all_tasks; task != NULL; task = task->all_link) {
1018             if (task->tso) {
1019                 thread_(&task->tso);
1020             }
1021         }
1022     }
1023
1024     // the static objects
1025     thread_static(static_objects /* ToDo: ok? */);
1026
1027     // the stable pointer table
1028     threadStablePtrTable((evac_fn)thread_root, NULL);
1029
1030     // the CAF list (used by GHCi)
1031     markCAFs((evac_fn)thread_root, NULL);
1032
1033     // 2. update forward ptrs
1034     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1035         gen = &generations[g];
1036         debugTrace(DEBUG_gc, "update_fwd:  %d", g);
1037
1038         update_fwd(gen->blocks);
1039         update_fwd_large(gen->scavenged_large_objects);
1040         if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) {
1041             debugTrace(DEBUG_gc, "update_fwd:  %d (compact)", g);
1042             update_fwd_compact(gen->old_blocks);
1043         }
1044     }
1045
1046     // 3. update backward ptrs
1047     gen = oldest_gen;
1048     if (gen->old_blocks != NULL) {
1049         blocks = update_bkwd_compact(gen);
1050         debugTrace(DEBUG_gc,
1051                    "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
1052                    gen->no, gen->n_old_blocks, blocks);
1053         gen->n_old_blocks = blocks;
1054     }
1055 }