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         ) {
 476         thread_(&tso->block_info.closure);
 477     }
 478     thread_(&tso->blocked_exceptions);
 479
 480     thread_(&tso->trec);
 481
 482     thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 483     return (StgPtr)tso + tso_sizeW(tso);
 484 }
 485
 486
 487 static void
 488 update_fwd_large( bdescr *bd )
 489 {
 490   StgPtr p;
 491   const StgInfoTable* info;
 492
 493   for (; bd != NULL; bd = bd->link) {
 494
 495     // nothing to do in a pinned block; it might not even have an object
 496     // at the beginning.
 497     if (bd->flags & BF_PINNED) continue;
 498
 499     p = bd->start;
 500     info  = get_itbl((StgClosure *)p);
 501
 502     switch (info->type) {
 503
 504     case ARR_WORDS:
 505       // nothing to follow
 506       continue;
 507
 508     case MUT_ARR_PTRS_CLEAN:
 509     case MUT_ARR_PTRS_DIRTY:
 510     case MUT_ARR_PTRS_FROZEN:
 511     case MUT_ARR_PTRS_FROZEN0:
 512       // follow everything
 513       {
 514           StgMutArrPtrs *a;
 515
 516           a = (StgMutArrPtrs*)p;
 517           for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
 518               thread((StgClosure **)p);
 519           }
 520           continue;
 521       }
 522
 523     case TSO:
 524         thread_TSO((StgTSO *)p);
 525         continue;
 526
 527     case AP_STACK:
 528         thread_AP_STACK((StgAP_STACK *)p);
 529         continue;
 530
 531     case PAP:
 532         thread_PAP((StgPAP *)p);
 533         continue;
 534
 535     case TREC_CHUNK:
 536     {
 537         StgWord i;
 538         StgTRecChunk *tc = (StgTRecChunk *)p;
 539         TRecEntry *e = &(tc -> entries[0]);
 540         thread_(&tc->prev_chunk);
 541         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 542           thread_(&e->tvar);
 543           thread(&e->expected_value);
 544           thread(&e->new_value);
 545         }
 546         continue;
 547     }
 548
 549     default:
 550       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 551     }
 552   }
 553 }
 554
 555 // ToDo: too big to inline
 556 static /* STATIC_INLINE */ StgPtr
 557 thread_obj (StgInfoTable *info, StgPtr p)
 558 {
 559     switch (info->type) {
 560     case THUNK_0_1:
 561         return p + sizeofW(StgThunk) + 1;
 562
 563     case FUN_0_1:
 564     case CONSTR_0_1:
 565         return p + sizeofW(StgHeader) + 1;
 566
 567     case FUN_1_0:
 568     case CONSTR_1_0:
 569         thread(&((StgClosure *)p)->payload[0]);
 570         return p + sizeofW(StgHeader) + 1;
 571
 572     case THUNK_1_0:
 573         thread(&((StgThunk *)p)->payload[0]);
 574         return p + sizeofW(StgThunk) + 1;
 575
 576     case THUNK_0_2:
 577         return p + sizeofW(StgThunk) + 2;
 578
 579     case FUN_0_2:
 580     case CONSTR_0_2:
 581         return p + sizeofW(StgHeader) + 2;
 582
 583     case THUNK_1_1:
 584         thread(&((StgThunk *)p)->payload[0]);
 585         return p + sizeofW(StgThunk) + 2;
 586
 587     case FUN_1_1:
 588     case CONSTR_1_1:
 589         thread(&((StgClosure *)p)->payload[0]);
 590         return p + sizeofW(StgHeader) + 2;
 591
 592     case THUNK_2_0:
 593         thread(&((StgThunk *)p)->payload[0]);
 594         thread(&((StgThunk *)p)->payload[1]);
 595         return p + sizeofW(StgThunk) + 2;
 596
 597     case FUN_2_0:
 598     case CONSTR_2_0:
 599         thread(&((StgClosure *)p)->payload[0]);
 600         thread(&((StgClosure *)p)->payload[1]);
 601         return p + sizeofW(StgHeader) + 2;
 602
 603     case BCO: {
 604         StgBCO *bco = (StgBCO *)p;
 605         thread_(&bco->instrs);
 606         thread_(&bco->literals);
 607         thread_(&bco->ptrs);
 608         return p + bco_sizeW(bco);
 609     }
 610
 611     case THUNK:
 612     {
 613         StgPtr end;
 614
 615         end = (P_)((StgThunk *)p)->payload +
 616             info->layout.payload.ptrs;
 617         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
 618             thread((StgClosure **)p);
 619         }
 620         return p + info->layout.payload.nptrs;
 621     }
 622
 623     case FUN:
 624     case CONSTR:
 625     case PRIM:
 626     case MUT_PRIM:
 627     case MUT_VAR_CLEAN:
 628     case MUT_VAR_DIRTY:
 629     case BLACKHOLE:
 630     case BLOCKING_QUEUE:
 631     {
 632         StgPtr end;
 633
 634         end = (P_)((StgClosure *)p)->payload +
 635             info->layout.payload.ptrs;
 636         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 637             thread((StgClosure **)p);
 638         }
 639         return p + info->layout.payload.nptrs;
 640     }
 641
 642     case WEAK:
 643     {
 644         StgWeak *w = (StgWeak *)p;
 645         thread(&w->cfinalizer);
 646         thread(&w->key);
 647         thread(&w->value);
 648         thread(&w->finalizer);
 649         if (w->link != NULL) {
 650             thread_(&w->link);
 651         }
 652         return p + sizeofW(StgWeak);
 653     }
 654
 655     case MVAR_CLEAN:
 656     case MVAR_DIRTY:
 657     {
 658         StgMVar *mvar = (StgMVar *)p;
 659         thread_(&mvar->head);
 660         thread_(&mvar->tail);
 661         thread(&mvar->value);
 662         return p + sizeofW(StgMVar);
 663     }
 664
 665     case IND:
 666     case IND_PERM:
 667         thread(&((StgInd *)p)->indirectee);
 668         return p + sizeofW(StgInd);
 669
 670     case THUNK_SELECTOR:
 671     {
 672         StgSelector *s = (StgSelector *)p;
 673         thread(&s->selectee);
 674         return p + THUNK_SELECTOR_sizeW();
 675     }
 676
 677     case AP_STACK:
 678         return thread_AP_STACK((StgAP_STACK *)p);
 679
 680     case PAP:
 681         return thread_PAP((StgPAP *)p);
 682
 683     case AP:
 684         return thread_AP((StgAP *)p);
 685
 686     case ARR_WORDS:
 687         return p + arr_words_sizeW((StgArrWords *)p);
 688
 689     case MUT_ARR_PTRS_CLEAN:
 690     case MUT_ARR_PTRS_DIRTY:
 691     case MUT_ARR_PTRS_FROZEN:
 692     case MUT_ARR_PTRS_FROZEN0:
 693         // follow everything
 694     {
 695         StgMutArrPtrs *a;
 696
 697         a = (StgMutArrPtrs *)p;
 698         for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
 699             thread((StgClosure **)p);
 700         }
 701
 702         return (StgPtr)a + mut_arr_ptrs_sizeW(a);
 703     }
 704
 705     case TSO:
 706         return thread_TSO((StgTSO *)p);
 707
 708     case TREC_CHUNK:
 709     {
 710         StgWord i;
 711         StgTRecChunk *tc = (StgTRecChunk *)p;
 712         TRecEntry *e = &(tc -> entries[0]);
 713         thread_(&tc->prev_chunk);
 714         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 715           thread_(&e->tvar);
 716           thread(&e->expected_value);
 717           thread(&e->new_value);
 718         }
 719         return p + sizeofW(StgTRecChunk);
 720     }
 721
 722     default:
 723         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 724         return NULL;
 725     }
 726 }
 727
 728 static void
 729 update_fwd( bdescr *blocks )
 730 {
 731     StgPtr p;
 732     bdescr *bd;
 733     StgInfoTable *info;
 734
 735     bd = blocks;
 736
 737     // cycle through all the blocks in the step
 738     for (; bd != NULL; bd = bd->link) {
 739         p = bd->start;
 740
 741         // linearly scan the objects in this block
 742         while (p < bd->free) {
 743             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 744             info = get_itbl((StgClosure *)p);
 745             p = thread_obj(info, p);
 746         }
 747     }
 748 }
 749
 750 static void
 751 update_fwd_compact( bdescr *blocks )
 752 {
 753     StgPtr p, q, free;
 754 #if 0
 755     StgWord m;
 756 #endif
 757     bdescr *bd, *free_bd;
 758     StgInfoTable *info;
 759     nat size;
 760     StgWord iptr;
 761
 762     bd = blocks;
 763     free_bd = blocks;
 764     free = free_bd->start;
 765
 766     // cycle through all the blocks in the step
 767     for (; bd != NULL; bd = bd->link) {
 768         p = bd->start;
 769
 770         while (p < bd->free ) {
 771
 772             while ( p < bd->free && !is_marked(p,bd) ) {
 773                 p++;
 774             }
 775             if (p >= bd->free) {
 776                 break;
 777             }
 778
 779 #if 0
 780     next:
 781         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 782         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 783
 784         while ( p < bd->free ) {
 785
 786             if ((m & 1) == 0) {
 787                 m >>= 1;
 788                 p++;
 789                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 790                     goto next;
 791                 } else {
 792                     continue;
 793                 }
 794             }
 795 #endif
 796
 797             // Problem: we need to know the destination for this cell
 798             // in order to unthread its info pointer.  But we can't
 799             // know the destination without the size, because we may
 800             // spill into the next block.  So we have to run down the
 801             // threaded list and get the info ptr first.
 802             //
 803             // ToDo: one possible avenue of attack is to use the fact
 804             // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
 805             // definitely have enough room.  Also see bug #1147.
 806             iptr = get_threaded_info(p);
 807             info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
 808
 809             q = p;
 810
 811             p = thread_obj(info, p);
 812
 813             size = p - q;
 814             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 815                 // set the next bit in the bitmap to indicate that
 816                 // this object needs to be pushed into the next
 817                 // block.  This saves us having to run down the
 818                 // threaded info pointer list twice during the next pass.
 819                 mark(q+1,bd);
 820                 free_bd = free_bd->link;
 821                 free = free_bd->start;
 822             } else {
 823                 ASSERT(!is_marked(q+1,bd));
 824             }
 825
 826             unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
 827             free += size;
 828 #if 0
 829             goto next;
 830 #endif
 831         }
 832     }
 833 }
 834
 835 static nat
 836 update_bkwd_compact( generation *gen )
 837 {
 838     StgPtr p, free;
 839 #if 0
 840     StgWord m;
 841 #endif
 842     bdescr *bd, *free_bd;
 843     StgInfoTable *info;
 844     nat size, free_blocks;
 845     StgWord iptr;
 846
 847     bd = free_bd = gen->old_blocks;
 848     free = free_bd->start;
 849     free_blocks = 1;
 850
 851     // cycle through all the blocks in the step
 852     for (; bd != NULL; bd = bd->link) {
 853         p = bd->start;
 854
 855         while (p < bd->free ) {
 856
 857             while ( p < bd->free && !is_marked(p,bd) ) {
 858                 p++;
 859             }
 860             if (p >= bd->free) {
 861                 break;
 862             }
 863
 864 #if 0
 865     next:
 866         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 867         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 868
 869         while ( p < bd->free ) {
 870
 871             if ((m & 1) == 0) {
 872                 m >>= 1;
 873                 p++;
 874                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 875                     goto next;
 876                 } else {
 877                     continue;
 878                 }
 879             }
 880 #endif
 881
 882             if (is_marked(p+1,bd)) {
 883                 // don't forget to update the free ptr in the block desc.
 884                 free_bd->free = free;
 885                 free_bd = free_bd->link;
 886                 free = free_bd->start;
 887                 free_blocks++;
 888             }
 889
 890             iptr = get_threaded_info(p);
 891             unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
 892             ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
 893             info = get_itbl((StgClosure *)p);
 894             size = closure_sizeW_((StgClosure *)p,info);
 895
 896             if (free != p) {
 897                 move(free,p,size);
 898             }
 899
 900             // relocate TSOs
 901             if (info->type == TSO) {
 902                 move_TSO((StgTSO *)p, (StgTSO *)free);
 903             }
 904
 905             free += size;
 906             p += size;
 907 #if 0
 908             goto next;
 909 #endif
 910         }
 911     }
 912
 913     // free the remaining blocks and count what's left.
 914     free_bd->free = free;
 915     if (free_bd->link != NULL) {
 916         freeChain(free_bd->link);
 917         free_bd->link = NULL;
 918     }
 919
 920     return free_blocks;
 921 }
 922
 923 void
 924 compact(StgClosure *static_objects)
 925 {
 926     nat g, blocks;
 927     generation *gen;
 928
 929     // 1. thread the roots
 930     markCapabilities((evac_fn)thread_root, NULL);
 931
 932     // the weak pointer lists...
 933     if (weak_ptr_list != NULL) {
 934         thread((void *)&weak_ptr_list);
 935     }
 936     if (old_weak_ptr_list != NULL) {
 937         thread((void *)&old_weak_ptr_list); // tmp
 938     }
 939
 940     // mutable lists
 941     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 942         bdescr *bd;
 943         StgPtr p;
 944         nat n;
 945         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 946             for (p = bd->start; p < bd->free; p++) {
 947                 thread((StgClosure **)p);
 948             }
 949         }
 950         for (n = 0; n < n_capabilities; n++) {
 951             for (bd = capabilities[n].mut_lists[g];
 952                  bd != NULL; bd = bd->link) {
 953                 for (p = bd->start; p < bd->free; p++) {
 954                     thread((StgClosure **)p);
 955                 }
 956             }
 957         }
 958     }
 959
 960     // the global thread list
 961     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 962         thread((void *)&generations[g].threads);
 963     }
 964
 965     // any threads resurrected during this GC
 966     thread((void *)&resurrected_threads);
 967
 968     // the task list
 969     {
 970         Task *task;
 971         InCall *incall;
 972         for (task = all_tasks; task != NULL; task = task->all_link) {
 973             for (incall = task->incall; incall != NULL;
 974                  incall = incall->prev_stack) {
 975                 if (incall->tso) {
 976                     thread_(&incall->tso);
 977                 }
 978             }
 979         }
 980     }
 981
 982     // the static objects
 983     thread_static(static_objects /* ToDo: ok? */);
 984
 985     // the stable pointer table
 986     threadStablePtrTable((evac_fn)thread_root, NULL);
 987
 988     // the CAF list (used by GHCi)
 989     markCAFs((evac_fn)thread_root, NULL);
 990
 991     // 2. update forward ptrs
 992     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 993         gen = &generations[g];
 994         debugTrace(DEBUG_gc, "update_fwd:  %d", g);
 995
 996         update_fwd(gen->blocks);
 997         update_fwd_large(gen->scavenged_large_objects);
 998         if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) {
 999             debugTrace(DEBUG_gc, "update_fwd:  %d (compact)", g);
1000             update_fwd_compact(gen->old_blocks);
1001         }
1002     }
1003
1004     // 3. update backward ptrs
1005     gen = oldest_gen;
1006     if (gen->old_blocks != NULL) {
1007         blocks = update_bkwd_compact(gen);
1008         debugTrace(DEBUG_gc,
1009                    "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
1010                    gen->no, gen->n_old_blocks, blocks);
1011         gen->n_old_blocks = blocks;
1012     }
1013 }