rts/sm/Compact.c

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