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