rts/sm/Compact.c

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