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