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     if ( tso->blocked_exceptions != NULL ) {
 407         thread_(&tso->blocked_exceptions);
 408     }
 409
 410     thread_(&tso->trec);
 411
 412     thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 413     return (StgPtr)tso + tso_sizeW(tso);
 414 }
 415
 416
 417 static void
 418 update_fwd_large( bdescr *bd )
 419 {
 420   StgPtr p;
 421   const StgInfoTable* info;
 422
 423   for (; bd != NULL; bd = bd->link) {
 424
 425     p = bd->start;
 426     info  = get_itbl((StgClosure *)p);
 427
 428     switch (info->type) {
 429
 430     case ARR_WORDS:
 431       // nothing to follow
 432       continue;
 433
 434     case MUT_ARR_PTRS_CLEAN:
 435     case MUT_ARR_PTRS_DIRTY:
 436     case MUT_ARR_PTRS_FROZEN:
 437     case MUT_ARR_PTRS_FROZEN0:
 438       // follow everything
 439       {
 440         StgPtr next;
 441
 442         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 443         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 444             thread((StgClosure **)p);
 445         }
 446         continue;
 447       }
 448
 449     case TSO:
 450         thread_TSO((StgTSO *)p);
 451         continue;
 452
 453     case AP_STACK:
 454         thread_AP_STACK((StgAP_STACK *)p);
 455         continue;
 456
 457     case PAP:
 458         thread_PAP((StgPAP *)p);
 459         continue;
 460
 461     case TREC_CHUNK:
 462     {
 463         StgWord i;
 464         StgTRecChunk *tc = (StgTRecChunk *)p;
 465         TRecEntry *e = &(tc -> entries[0]);
 466         thread_(&tc->prev_chunk);
 467         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 468           thread_(&e->tvar);
 469           thread(&e->expected_value);
 470           thread(&e->new_value);
 471         }
 472         continue;
 473     }
 474
 475     default:
 476       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 477     }
 478   }
 479 }
 480
 481 STATIC_INLINE StgPtr
 482 thread_obj (StgInfoTable *info, StgPtr p)
 483 {
 484     switch (info->type) {
 485     case THUNK_0_1:
 486         return p + sizeofW(StgThunk) + 1;
 487
 488     case FUN_0_1:
 489     case CONSTR_0_1:
 490         return p + sizeofW(StgHeader) + 1;
 491
 492     case FUN_1_0:
 493     case CONSTR_1_0:
 494         thread(&((StgClosure *)p)->payload[0]);
 495         return p + sizeofW(StgHeader) + 1;
 496
 497     case THUNK_1_0:
 498         thread(&((StgThunk *)p)->payload[0]);
 499         return p + sizeofW(StgThunk) + 1;
 500
 501     case THUNK_0_2:
 502         return p + sizeofW(StgThunk) + 2;
 503
 504     case FUN_0_2:
 505     case CONSTR_0_2:
 506         return p + sizeofW(StgHeader) + 2;
 507
 508     case THUNK_1_1:
 509         thread(&((StgThunk *)p)->payload[0]);
 510         return p + sizeofW(StgThunk) + 2;
 511
 512     case FUN_1_1:
 513     case CONSTR_1_1:
 514         thread(&((StgClosure *)p)->payload[0]);
 515         return p + sizeofW(StgHeader) + 2;
 516
 517     case THUNK_2_0:
 518         thread(&((StgThunk *)p)->payload[0]);
 519         thread(&((StgThunk *)p)->payload[1]);
 520         return p + sizeofW(StgThunk) + 2;
 521
 522     case FUN_2_0:
 523     case CONSTR_2_0:
 524         thread(&((StgClosure *)p)->payload[0]);
 525         thread(&((StgClosure *)p)->payload[1]);
 526         return p + sizeofW(StgHeader) + 2;
 527
 528     case BCO: {
 529         StgBCO *bco = (StgBCO *)p;
 530         thread_(&bco->instrs);
 531         thread_(&bco->literals);
 532         thread_(&bco->ptrs);
 533         thread_(&bco->itbls);
 534         return p + bco_sizeW(bco);
 535     }
 536
 537     case THUNK:
 538     {
 539         StgPtr end;
 540
 541         end = (P_)((StgThunk *)p)->payload +
 542             info->layout.payload.ptrs;
 543         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
 544             thread((StgClosure **)p);
 545         }
 546         return p + info->layout.payload.nptrs;
 547     }
 548
 549     case FUN:
 550     case CONSTR:
 551     case STABLE_NAME:
 552     case IND_PERM:
 553     case MUT_VAR_CLEAN:
 554     case MUT_VAR_DIRTY:
 555     case CAF_BLACKHOLE:
 556     case SE_CAF_BLACKHOLE:
 557     case SE_BLACKHOLE:
 558     case BLACKHOLE:
 559     {
 560         StgPtr end;
 561
 562         end = (P_)((StgClosure *)p)->payload +
 563             info->layout.payload.ptrs;
 564         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 565             thread((StgClosure **)p);
 566         }
 567         return p + info->layout.payload.nptrs;
 568     }
 569
 570     case WEAK:
 571     {
 572         StgWeak *w = (StgWeak *)p;
 573         thread(&w->key);
 574         thread(&w->value);
 575         thread(&w->finalizer);
 576         if (w->link != NULL) {
 577             thread_(&w->link);
 578         }
 579         return p + sizeofW(StgWeak);
 580     }
 581
 582     case MVAR:
 583     {
 584         StgMVar *mvar = (StgMVar *)p;
 585         thread_(&mvar->head);
 586         thread_(&mvar->tail);
 587         thread(&mvar->value);
 588         return p + sizeofW(StgMVar);
 589     }
 590
 591     case IND_OLDGEN:
 592     case IND_OLDGEN_PERM:
 593         thread(&((StgInd *)p)->indirectee);
 594         return p + sizeofW(StgInd);
 595
 596     case THUNK_SELECTOR:
 597     {
 598         StgSelector *s = (StgSelector *)p;
 599         thread(&s->selectee);
 600         return p + THUNK_SELECTOR_sizeW();
 601     }
 602
 603     case AP_STACK:
 604         return thread_AP_STACK((StgAP_STACK *)p);
 605
 606     case PAP:
 607         return thread_PAP((StgPAP *)p);
 608
 609     case AP:
 610         return thread_AP((StgAP *)p);
 611
 612     case ARR_WORDS:
 613         return p + arr_words_sizeW((StgArrWords *)p);
 614
 615     case MUT_ARR_PTRS_CLEAN:
 616     case MUT_ARR_PTRS_DIRTY:
 617     case MUT_ARR_PTRS_FROZEN:
 618     case MUT_ARR_PTRS_FROZEN0:
 619         // follow everything
 620     {
 621         StgPtr next;
 622
 623         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 624         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 625             thread((StgClosure **)p);
 626         }
 627         return p;
 628     }
 629
 630     case TSO:
 631         return thread_TSO((StgTSO *)p);
 632
 633     case TVAR_WAIT_QUEUE:
 634     {
 635         StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
 636         thread_(&wq->waiting_tso);
 637         thread_(&wq->next_queue_entry);
 638         thread_(&wq->prev_queue_entry);
 639         return p + sizeofW(StgTVarWaitQueue);
 640     }
 641
 642     case TVAR:
 643     {
 644         StgTVar *tvar = (StgTVar *)p;
 645         thread((void *)&tvar->current_value);
 646         thread((void *)&tvar->first_wait_queue_entry);
 647         return p + sizeofW(StgTVar);
 648     }
 649
 650     case TREC_HEADER:
 651     {
 652         StgTRecHeader *trec = (StgTRecHeader *)p;
 653         thread_(&trec->enclosing_trec);
 654         thread_(&trec->current_chunk);
 655         return p + sizeofW(StgTRecHeader);
 656     }
 657
 658     case TREC_CHUNK:
 659     {
 660         StgWord i;
 661         StgTRecChunk *tc = (StgTRecChunk *)p;
 662         TRecEntry *e = &(tc -> entries[0]);
 663         thread_(&tc->prev_chunk);
 664         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 665           thread_(&e->tvar);
 666           thread(&e->expected_value);
 667           thread(&e->new_value);
 668         }
 669         return p + sizeofW(StgTRecChunk);
 670     }
 671
 672     default:
 673         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 674         return NULL;
 675     }
 676 }
 677
 678 static void
 679 update_fwd( bdescr *blocks )
 680 {
 681     StgPtr p;
 682     bdescr *bd;
 683     StgInfoTable *info;
 684
 685     bd = blocks;
 686
 687 #if defined(PAR)
 688     barf("update_fwd: ToDo");
 689 #endif
 690
 691     // cycle through all the blocks in the step
 692     for (; bd != NULL; bd = bd->link) {
 693         p = bd->start;
 694
 695         // linearly scan the objects in this block
 696         while (p < bd->free) {
 697             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 698             info = get_itbl((StgClosure *)p);
 699             p = thread_obj(info, p);
 700         }
 701     }
 702 }
 703
 704 static void
 705 update_fwd_compact( bdescr *blocks )
 706 {
 707     StgPtr p, q, free;
 708 #if 0
 709     StgWord m;
 710 #endif
 711     bdescr *bd, *free_bd;
 712     StgInfoTable *info;
 713     nat size;
 714
 715     bd = blocks;
 716     free_bd = blocks;
 717     free = free_bd->start;
 718
 719 #if defined(PAR)
 720     barf("update_fwd: ToDo");
 721 #endif
 722
 723     // cycle through all the blocks in the step
 724     for (; bd != NULL; bd = bd->link) {
 725         p = bd->start;
 726
 727         while (p < bd->free ) {
 728
 729             while ( p < bd->free && !is_marked(p,bd) ) {
 730                 p++;
 731             }
 732             if (p >= bd->free) {
 733                 break;
 734             }
 735
 736 #if 0
 737     next:
 738         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 739         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 740
 741         while ( p < bd->free ) {
 742
 743             if ((m & 1) == 0) {
 744                 m >>= 1;
 745                 p++;
 746                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 747                     goto next;
 748                 } else {
 749                     continue;
 750                 }
 751             }
 752 #endif
 753
 754             // Problem: we need to know the destination for this cell
 755             // in order to unthread its info pointer.  But we can't
 756             // know the destination without the size, because we may
 757             // spill into the next block.  So we have to run down the
 758             // threaded list and get the info ptr first.
 759             info = get_threaded_info(p);
 760
 761             q = p;
 762
 763             p = thread_obj(info, p);
 764
 765             size = p - q;
 766             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 767                 // unset the next bit in the bitmap to indicate that
 768                 // this object needs to be pushed into the next
 769                 // block.  This saves us having to run down the
 770                 // threaded info pointer list twice during the next pass.
 771                 unmark(q+1,bd);
 772                 free_bd = free_bd->link;
 773                 free = free_bd->start;
 774             } else {
 775                 ASSERT(is_marked(q+1,bd));
 776             }
 777
 778             unthread(q,free);
 779             free += size;
 780 #if 0
 781             goto next;
 782 #endif
 783         }
 784     }
 785 }
 786
 787 static nat
 788 update_bkwd_compact( step *stp )
 789 {
 790     StgPtr p, free;
 791 #if 0
 792     StgWord m;
 793 #endif
 794     bdescr *bd, *free_bd;
 795     StgInfoTable *info;
 796     nat size, free_blocks;
 797
 798     bd = free_bd = stp->old_blocks;
 799     free = free_bd->start;
 800     free_blocks = 1;
 801
 802 #if defined(PAR)
 803     barf("update_bkwd: ToDo");
 804 #endif
 805
 806     // cycle through all the blocks in the step
 807     for (; bd != NULL; bd = bd->link) {
 808         p = bd->start;
 809
 810         while (p < bd->free ) {
 811
 812             while ( p < bd->free && !is_marked(p,bd) ) {
 813                 p++;
 814             }
 815             if (p >= bd->free) {
 816                 break;
 817             }
 818
 819 #if 0
 820     next:
 821         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 822         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 823
 824         while ( p < bd->free ) {
 825
 826             if ((m & 1) == 0) {
 827                 m >>= 1;
 828                 p++;
 829                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 830                     goto next;
 831                 } else {
 832                     continue;
 833                 }
 834             }
 835 #endif
 836
 837             if (!is_marked(p+1,bd)) {
 838                 // don't forget to update the free ptr in the block desc.
 839                 free_bd->free = free;
 840                 free_bd = free_bd->link;
 841                 free = free_bd->start;
 842                 free_blocks++;
 843             }
 844
 845             unthread(p,free);
 846             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 847             info = get_itbl((StgClosure *)p);
 848             size = closure_sizeW_((StgClosure *)p,info);
 849
 850             if (free != p) {
 851                 move(free,p,size);
 852             }
 853
 854             // relocate TSOs
 855             if (info->type == TSO) {
 856                 move_TSO((StgTSO *)p, (StgTSO *)free);
 857             }
 858
 859             free += size;
 860             p += size;
 861 #if 0
 862             goto next;
 863 #endif
 864         }
 865     }
 866
 867     // free the remaining blocks and count what's left.
 868     free_bd->free = free;
 869     if (free_bd->link != NULL) {
 870         freeChain(free_bd->link);
 871         free_bd->link = NULL;
 872     }
 873
 874     return free_blocks;
 875 }
 876
 877 void
 878 compact( void (*get_roots)(evac_fn) )
 879 {
 880     nat g, s, blocks;
 881     step *stp;
 882
 883     // 1. thread the roots
 884     get_roots((evac_fn)thread);
 885
 886     // the weak pointer lists...
 887     if (weak_ptr_list != NULL) {
 888         thread((void *)&weak_ptr_list);
 889     }
 890     if (old_weak_ptr_list != NULL) {
 891         thread((void *)&old_weak_ptr_list); // tmp
 892     }
 893
 894     // mutable lists
 895     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 896         bdescr *bd;
 897         StgPtr p;
 898         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 899             for (p = bd->start; p < bd->free; p++) {
 900                 thread((StgClosure **)p);
 901             }
 902         }
 903     }
 904
 905     // the global thread list
 906     thread((void *)&all_threads);
 907
 908     // any threads resurrected during this GC
 909     thread((void *)&resurrected_threads);
 910
 911     // the task list
 912     {
 913         Task *task;
 914         for (task = all_tasks; task != NULL; task = task->all_link) {
 915             if (task->tso) {
 916                 thread_(&task->tso);
 917             }
 918         }
 919     }
 920
 921     // the static objects
 922     thread_static(scavenged_static_objects);
 923
 924     // the stable pointer table
 925     threadStablePtrTable((evac_fn)thread);
 926
 927     // the CAF list (used by GHCi)
 928     markCAFs((evac_fn)thread);
 929
 930     // 2. update forward ptrs
 931     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 932         for (s = 0; s < generations[g].n_steps; s++) {
 933             if (g==0 && s ==0) continue;
 934             stp = &generations[g].steps[s];
 935             debugTrace(DEBUG_gc, "update_fwd:  %d.%d",
 936                        stp->gen->no, stp->no);
 937
 938             update_fwd(stp->blocks);
 939             update_fwd_large(stp->scavenged_large_objects);
 940             if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
 941                 debugTrace(DEBUG_gc, "update_fwd:  %d.%d (compact)",
 942                            stp->gen->no, stp->no);
 943                 update_fwd_compact(stp->old_blocks);
 944             }
 945         }
 946     }
 947
 948     // 3. update backward ptrs
 949     stp = &oldest_gen->steps[0];
 950     if (stp->old_blocks != NULL) {
 951         blocks = update_bkwd_compact(stp);
 952         debugTrace(DEBUG_gc,
 953                    "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
 954                    stp->gen->no, stp->no,
 955                    stp->n_old_blocks, blocks);
 956         stp->n_old_blocks = blocks;
 957     }
 958 }