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