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