rts/sm/Compact.c

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