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