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         return sizeofW(StgHeader) + 1;
 117     case THUNK_0_1:
 118     case THUNK_0_2:
 119     case FUN_0_2:
 120     case CONSTR_0_2:
 121     case THUNK_1_0:
 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; // MIN_UPD_SIZE
 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         return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 141     case TSO:
 142         return tso_sizeW((StgTSO *)p);
 143     case BCO:
 144         return bco_sizeW((StgBCO *)p);
 145     default:
 146         return sizeW_fromITBL(info);
 147     }
 148 }
 149
 150 static void
 151 thread_static( StgClosure* p )
 152 {
 153   const StgInfoTable *info;
 154
 155   // keep going until we've threaded all the objects on the linked
 156   // list...
 157   while (p != END_OF_STATIC_LIST) {
 158
 159     info = get_itbl(p);
 160     switch (info->type) {
 161
 162     case IND_STATIC:
 163         thread((StgPtr)&((StgInd *)p)->indirectee);
 164         p = IND_STATIC_LINK(p);
 165         continue;
 166
 167     case THUNK_STATIC:
 168         p = THUNK_STATIC_LINK(p);
 169         continue;
 170     case FUN_STATIC:
 171         p = FUN_STATIC_LINK(p);
 172         continue;
 173     case CONSTR_STATIC:
 174         p = STATIC_LINK(info,p);
 175         continue;
 176
 177     default:
 178         barf("thread_static: strange closure %d", (int)(info->type));
 179     }
 180
 181   }
 182 }
 183
 184 STATIC_INLINE void
 185 thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
 186 {
 187     nat i, b;
 188     StgWord bitmap;
 189
 190     b = 0;
 191     bitmap = large_bitmap->bitmap[b];
 192     for (i = 0; i < size; ) {
 193         if ((bitmap & 1) == 0) {
 194             thread(p);
 195         }
 196         i++;
 197         p++;
 198         if (i % BITS_IN(W_) == 0) {
 199             b++;
 200             bitmap = large_bitmap->bitmap[b];
 201         } else {
 202             bitmap = bitmap >> 1;
 203         }
 204     }
 205 }
 206
 207 STATIC_INLINE StgPtr
 208 thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
 209 {
 210     StgPtr p;
 211     StgWord bitmap;
 212     nat size;
 213
 214     p = (StgPtr)args;
 215     switch (fun_info->f.fun_type) {
 216     case ARG_GEN:
 217         bitmap = BITMAP_BITS(fun_info->f.bitmap);
 218         size = BITMAP_SIZE(fun_info->f.bitmap);
 219         goto small_bitmap;
 220     case ARG_GEN_BIG:
 221         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
 222         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 223         p += size;
 224         break;
 225     default:
 226         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 227         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 228     small_bitmap:
 229         while (size > 0) {
 230             if ((bitmap & 1) == 0) {
 231                 thread(p);
 232             }
 233             p++;
 234             bitmap = bitmap >> 1;
 235             size--;
 236         }
 237         break;
 238     }
 239     return p;
 240 }
 241
 242 static void
 243 thread_stack(StgPtr p, StgPtr stack_end)
 244 {
 245     const StgRetInfoTable* info;
 246     StgWord bitmap;
 247     nat size;
 248
 249     // highly similar to scavenge_stack, but we do pointer threading here.
 250
 251     while (p < stack_end) {
 252
 253         // *p must be the info pointer of an activation
 254         // record.  All activation records have 'bitmap' style layout
 255         // info.
 256         //
 257         info  = get_ret_itbl((StgClosure *)p);
 258
 259         switch (info->i.type) {
 260
 261             // Dynamic bitmap: the mask is stored on the stack
 262         case RET_DYN:
 263         {
 264             StgWord dyn;
 265             dyn = ((StgRetDyn *)p)->liveness;
 266
 267             // traverse the bitmap first
 268             bitmap = RET_DYN_LIVENESS(dyn);
 269             p      = (P_)&((StgRetDyn *)p)->payload[0];
 270             size   = RET_DYN_BITMAP_SIZE;
 271             while (size > 0) {
 272                 if ((bitmap & 1) == 0) {
 273                     thread(p);
 274                 }
 275                 p++;
 276                 bitmap = bitmap >> 1;
 277                 size--;
 278             }
 279
 280             // skip over the non-ptr words
 281             p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
 282
 283             // follow the ptr words
 284             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 285                 thread(p);
 286                 p++;
 287             }
 288             continue;
 289         }
 290
 291             // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
 292         case UPDATE_FRAME:
 293         case STOP_FRAME:
 294         case CATCH_FRAME:
 295         case RET_SMALL:
 296         case RET_VEC_SMALL:
 297             bitmap = BITMAP_BITS(info->i.layout.bitmap);
 298             size   = BITMAP_SIZE(info->i.layout.bitmap);
 299             p++;
 300             // NOTE: the payload starts immediately after the info-ptr, we
 301             // don't have an StgHeader in the same sense as a heap closure.
 302             while (size > 0) {
 303                 if ((bitmap & 1) == 0) {
 304                     thread(p);
 305                 }
 306                 p++;
 307                 bitmap = bitmap >> 1;
 308                 size--;
 309             }
 310             continue;
 311
 312         case RET_BCO: {
 313             StgBCO *bco;
 314             nat size;
 315
 316             p++;
 317             bco = (StgBCO *)*p;
 318             thread(p);
 319             p++;
 320             size = BCO_BITMAP_SIZE(bco);
 321             thread_large_bitmap(p, BCO_BITMAP(bco), size);
 322             p += size;
 323             continue;
 324         }
 325
 326             // large bitmap (> 32 entries, or 64 on a 64-bit machine)
 327         case RET_BIG:
 328         case RET_VEC_BIG:
 329             p++;
 330             size = GET_LARGE_BITMAP(&info->i)->size;
 331             thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
 332             p += size;
 333             continue;
 334
 335         case RET_FUN:
 336         {
 337             StgRetFun *ret_fun = (StgRetFun *)p;
 338             StgFunInfoTable *fun_info;
 339
 340             fun_info = itbl_to_fun_itbl(
 341                 get_threaded_info((StgPtr)ret_fun->fun));
 342                  // *before* threading it!
 343             thread((StgPtr)&ret_fun->fun);
 344             p = thread_arg_block(fun_info, ret_fun->payload);
 345             continue;
 346         }
 347
 348         default:
 349             barf("thread_stack: weird activation record found on stack: %d",
 350                  (int)(info->i.type));
 351         }
 352     }
 353 }
 354
 355 STATIC_INLINE StgPtr
 356 thread_PAP (StgPAP *pap)
 357 {
 358     StgPtr p;
 359     StgWord bitmap, size;
 360     StgFunInfoTable *fun_info;
 361
 362     fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)pap->fun));
 363     ASSERT(fun_info->i.type != PAP);
 364
 365     p = (StgPtr)pap->payload;
 366     size = pap->n_args;
 367
 368     switch (fun_info->f.fun_type) {
 369     case ARG_GEN:
 370         bitmap = BITMAP_BITS(fun_info->f.bitmap);
 371         goto small_bitmap;
 372     case ARG_GEN_BIG:
 373         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 374         p += size;
 375         break;
 376     case ARG_BCO:
 377         thread_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
 378         p += size;
 379         break;
 380     default:
 381         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 382     small_bitmap:
 383         size = pap->n_args;
 384         while (size > 0) {
 385             if ((bitmap & 1) == 0) {
 386                 thread(p);
 387             }
 388             p++;
 389             bitmap = bitmap >> 1;
 390             size--;
 391         }
 392         break;
 393     }
 394
 395     thread((StgPtr)&pap->fun);
 396     return p;
 397 }
 398
 399 STATIC_INLINE StgPtr
 400 thread_AP_STACK (StgAP_STACK *ap)
 401 {
 402     thread((StgPtr)&ap->fun);
 403     thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
 404     return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
 405 }
 406
 407 static StgPtr
 408 thread_TSO (StgTSO *tso)
 409 {
 410     thread((StgPtr)&tso->link);
 411     thread((StgPtr)&tso->global_link);
 412
 413     if (   tso->why_blocked == BlockedOnMVar
 414         || tso->why_blocked == BlockedOnBlackHole
 415         || tso->why_blocked == BlockedOnException
 416 #if defined(PAR)
 417         || tso->why_blocked == BlockedOnGA
 418         || tso->why_blocked == BlockedOnGA_NoSend
 419 #endif
 420         ) {
 421         thread((StgPtr)&tso->block_info.closure);
 422     }
 423     if ( tso->blocked_exceptions != NULL ) {
 424         thread((StgPtr)&tso->blocked_exceptions);
 425     }
 426
 427     thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 428     return (StgPtr)tso + tso_sizeW(tso);
 429 }
 430
 431
 432 static void
 433 update_fwd_large( bdescr *bd )
 434 {
 435   StgPtr p;
 436   const StgInfoTable* info;
 437
 438   for (; bd != NULL; bd = bd->link) {
 439
 440     p = bd->start;
 441     info  = get_itbl((StgClosure *)p);
 442
 443     switch (info->type) {
 444
 445     case ARR_WORDS:
 446       // nothing to follow
 447       continue;
 448
 449     case MUT_ARR_PTRS:
 450     case MUT_ARR_PTRS_FROZEN:
 451       // follow everything
 452       {
 453         StgPtr next;
 454
 455         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 456         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 457             thread(p);
 458         }
 459         continue;
 460       }
 461
 462     case TSO:
 463         thread_TSO((StgTSO *)p);
 464         continue;
 465
 466     case AP_STACK:
 467         thread_AP_STACK((StgAP_STACK *)p);
 468         continue;
 469
 470     case PAP:
 471         thread_PAP((StgPAP *)p);
 472         continue;
 473
 474     default:
 475       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 476     }
 477   }
 478 }
 479
 480 STATIC_INLINE StgPtr
 481 thread_obj (StgInfoTable *info, StgPtr p)
 482 {
 483     switch (info->type) {
 484     case FUN_0_1:
 485     case CONSTR_0_1:
 486         return p + sizeofW(StgHeader) + 1;
 487
 488     case FUN_1_0:
 489     case CONSTR_1_0:
 490         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 491         return p + sizeofW(StgHeader) + 1;
 492
 493     case THUNK_1_0:
 494         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 495         return p + sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 496
 497     case THUNK_0_1: // MIN_UPD_SIZE
 498     case THUNK_0_2:
 499     case FUN_0_2:
 500     case CONSTR_0_2:
 501         return p + sizeofW(StgHeader) + 2;
 502
 503     case THUNK_1_1:
 504     case FUN_1_1:
 505     case CONSTR_1_1:
 506         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 507         return p + sizeofW(StgHeader) + 2;
 508
 509     case THUNK_2_0:
 510     case FUN_2_0:
 511     case CONSTR_2_0:
 512         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 513         thread((StgPtr)&((StgClosure *)p)->payload[1]);
 514         return p + sizeofW(StgHeader) + 2;
 515
 516     case BCO: {
 517         StgBCO *bco = (StgBCO *)p;
 518         thread((StgPtr)&bco->instrs);
 519         thread((StgPtr)&bco->literals);
 520         thread((StgPtr)&bco->ptrs);
 521         thread((StgPtr)&bco->itbls);
 522         return p + bco_sizeW(bco);
 523     }
 524
 525     case FUN:
 526     case THUNK:
 527     case CONSTR:
 528     case FOREIGN:
 529     case STABLE_NAME:
 530     case IND_PERM:
 531     case MUT_VAR:
 532     case MUT_CONS:
 533     case CAF_BLACKHOLE:
 534     case SE_CAF_BLACKHOLE:
 535     case SE_BLACKHOLE:
 536     case BLACKHOLE:
 537     case BLACKHOLE_BQ:
 538     {
 539         StgPtr end;
 540
 541         end = (P_)((StgClosure *)p)->payload +
 542             info->layout.payload.ptrs;
 543         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 544             thread(p);
 545         }
 546         return p + info->layout.payload.nptrs;
 547     }
 548
 549     case WEAK:
 550     {
 551         StgWeak *w = (StgWeak *)p;
 552         thread((StgPtr)&w->key);
 553         thread((StgPtr)&w->value);
 554         thread((StgPtr)&w->finalizer);
 555         if (w->link != NULL) {
 556             thread((StgPtr)&w->link);
 557         }
 558         return p + sizeofW(StgWeak);
 559     }
 560
 561     case MVAR:
 562     {
 563         StgMVar *mvar = (StgMVar *)p;
 564         thread((StgPtr)&mvar->head);
 565         thread((StgPtr)&mvar->tail);
 566         thread((StgPtr)&mvar->value);
 567         return p + sizeofW(StgMVar);
 568     }
 569
 570     case IND_OLDGEN:
 571     case IND_OLDGEN_PERM:
 572         thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
 573         return p + sizeofW(StgIndOldGen);
 574
 575     case THUNK_SELECTOR:
 576     {
 577         StgSelector *s = (StgSelector *)p;
 578         thread((StgPtr)&s->selectee);
 579         return p + THUNK_SELECTOR_sizeW();
 580     }
 581
 582     case AP_STACK:
 583         return thread_AP_STACK((StgAP_STACK *)p);
 584
 585     case PAP:
 586     case AP:
 587         return thread_PAP((StgPAP *)p);
 588
 589     case ARR_WORDS:
 590         return p + arr_words_sizeW((StgArrWords *)p);
 591
 592     case MUT_ARR_PTRS:
 593     case MUT_ARR_PTRS_FROZEN:
 594         // follow everything
 595     {
 596         StgPtr next;
 597
 598         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 599         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 600             thread(p);
 601         }
 602         return p;
 603     }
 604
 605     case TSO:
 606         return thread_TSO((StgTSO *)p);
 607
 608     default:
 609         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 610         return NULL;
 611     }
 612 }
 613
 614 static void
 615 update_fwd( bdescr *blocks )
 616 {
 617     StgPtr p;
 618     bdescr *bd;
 619     StgInfoTable *info;
 620
 621     bd = blocks;
 622
 623 #if defined(PAR)
 624     barf("update_fwd: ToDo");
 625 #endif
 626
 627     // cycle through all the blocks in the step
 628     for (; bd != NULL; bd = bd->link) {
 629         p = bd->start;
 630
 631         // linearly scan the objects in this block
 632         while (p < bd->free) {
 633             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 634             info = get_itbl((StgClosure *)p);
 635             p = thread_obj(info, p);
 636         }
 637     }
 638 }
 639
 640 static void
 641 update_fwd_compact( bdescr *blocks )
 642 {
 643     StgPtr p, q, free;
 644 #if 0
 645     StgWord m;
 646 #endif
 647     bdescr *bd, *free_bd;
 648     StgInfoTable *info;
 649     nat size;
 650
 651     bd = blocks;
 652     free_bd = blocks;
 653     free = free_bd->start;
 654
 655 #if defined(PAR)
 656     barf("update_fwd: ToDo");
 657 #endif
 658
 659     // cycle through all the blocks in the step
 660     for (; bd != NULL; bd = bd->link) {
 661         p = bd->start;
 662
 663         while (p < bd->free ) {
 664
 665             while ( p < bd->free && !is_marked(p,bd) ) {
 666                 p++;
 667             }
 668             if (p >= bd->free) {
 669                 break;
 670             }
 671
 672 #if 0
 673     next:
 674         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 675         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 676
 677         while ( p < bd->free ) {
 678
 679             if ((m & 1) == 0) {
 680                 m >>= 1;
 681                 p++;
 682                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 683                     goto next;
 684                 } else {
 685                     continue;
 686                 }
 687             }
 688 #endif
 689
 690             // Problem: we need to know the destination for this cell
 691             // in order to unthread its info pointer.  But we can't
 692             // know the destination without the size, because we may
 693             // spill into the next block.  So we have to run down the
 694             // threaded list and get the info ptr first.
 695             info = get_threaded_info(p);
 696
 697             q = p;
 698
 699             p = thread_obj(info, p);
 700
 701             size = p - q;
 702             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 703                 // unset the next bit in the bitmap to indicate that
 704                 // this object needs to be pushed into the next
 705                 // block.  This saves us having to run down the
 706                 // threaded info pointer list twice during the next pass.
 707                 unmark(q+1,bd);
 708                 free_bd = free_bd->link;
 709                 free = free_bd->start;
 710             } else {
 711                 ASSERT(is_marked(q+1,bd));
 712             }
 713
 714             unthread(q,free);
 715             free += size;
 716 #if 0
 717             goto next;
 718 #endif
 719         }
 720     }
 721 }
 722
 723 static nat
 724 update_bkwd_compact( step *stp )
 725 {
 726     StgPtr p, free;
 727 #if 0
 728     StgWord m;
 729 #endif
 730     bdescr *bd, *free_bd;
 731     StgInfoTable *info;
 732     nat size, free_blocks;
 733
 734     bd = free_bd = stp->blocks;
 735     free = free_bd->start;
 736     free_blocks = 1;
 737
 738 #if defined(PAR)
 739     barf("update_bkwd: ToDo");
 740 #endif
 741
 742     // cycle through all the blocks in the step
 743     for (; bd != NULL; bd = bd->link) {
 744         p = bd->start;
 745
 746         while (p < bd->free ) {
 747
 748             while ( p < bd->free && !is_marked(p,bd) ) {
 749                 p++;
 750             }
 751             if (p >= bd->free) {
 752                 break;
 753             }
 754
 755 #if 0
 756     next:
 757         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 758         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 759
 760         while ( p < bd->free ) {
 761
 762             if ((m & 1) == 0) {
 763                 m >>= 1;
 764                 p++;
 765                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 766                     goto next;
 767                 } else {
 768                     continue;
 769                 }
 770             }
 771 #endif
 772
 773             if (!is_marked(p+1,bd)) {
 774                 // don't forget to update the free ptr in the block desc.
 775                 free_bd->free = free;
 776                 free_bd = free_bd->link;
 777                 free = free_bd->start;
 778                 free_blocks++;
 779             }
 780
 781             unthread(p,free);
 782             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 783             info = get_itbl((StgClosure *)p);
 784             size = obj_sizeW((StgClosure *)p,info);
 785
 786             if (free != p) {
 787                 move(free,p,size);
 788             }
 789
 790             // Rebuild the mutable list for the old generation.
 791             if (ip_MUTABLE(info)) {
 792                 recordMutable((StgMutClosure *)free);
 793             }
 794
 795             // relocate TSOs
 796             if (info->type == TSO) {
 797                 move_TSO((StgTSO *)p, (StgTSO *)free);
 798             }
 799
 800             free += size;
 801             p += size;
 802 #if 0
 803             goto next;
 804 #endif
 805         }
 806     }
 807
 808     // free the remaining blocks and count what's left.
 809     free_bd->free = free;
 810     if (free_bd->link != NULL) {
 811         freeChain(free_bd->link);
 812         free_bd->link = NULL;
 813     }
 814     stp->n_blocks = free_blocks;
 815
 816     return free_blocks;
 817 }
 818
 819 static void
 820 thread_mut_once_list( generation *g )
 821 {
 822     StgMutClosure *p, *next;
 823
 824     for (p = g->mut_once_list; p != END_MUT_LIST; p = next) {
 825         next = p->mut_link;
 826         thread((StgPtr)&p->mut_link);
 827     }
 828
 829     thread((StgPtr)&g->mut_once_list);
 830 }
 831
 832 void
 833 compact( void (*get_roots)(evac_fn) )
 834 {
 835     nat g, s, blocks;
 836     step *stp;
 837
 838     // 1. thread the roots
 839     get_roots((evac_fn)thread);
 840
 841     // the weak pointer lists...
 842     if (weak_ptr_list != NULL) {
 843         thread((StgPtr)&weak_ptr_list);
 844     }
 845     if (old_weak_ptr_list != NULL) {
 846         thread((StgPtr)&old_weak_ptr_list); // tmp
 847     }
 848
 849     // mutable lists
 850     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 851         thread((StgPtr)&generations[g].mut_list);
 852         thread_mut_once_list(&generations[g]);
 853     }
 854
 855     // the global thread list
 856     thread((StgPtr)&all_threads);
 857
 858     // any threads resurrected during this GC
 859     thread((StgPtr)&resurrected_threads);
 860
 861     // the main threads list
 862     {
 863         StgMainThread *m;
 864         for (m = main_threads; m != NULL; m = m->link) {
 865             thread((StgPtr)&m->tso);
 866         }
 867     }
 868
 869     // the static objects
 870     thread_static(scavenged_static_objects);
 871
 872     // the stable pointer table
 873     threadStablePtrTable((evac_fn)thread);
 874
 875     // the CAF list (used by GHCi)
 876     markCAFs((evac_fn)thread);
 877
 878     // 2. update forward ptrs
 879     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 880         for (s = 0; s < generations[g].n_steps; s++) {
 881             stp = &generations[g].steps[s];
 882             IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 883
 884             update_fwd(stp->to_blocks);
 885             update_fwd_large(stp->scavenged_large_objects);
 886             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 887                 IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 888                 update_fwd_compact(stp->blocks);
 889             }
 890         }
 891     }
 892
 893     // 3. update backward ptrs
 894     stp = &oldest_gen->steps[0];
 895     if (stp->blocks != NULL) {
 896         blocks = update_bkwd_compact(stp);
 897         IF_DEBUG(gc, debugBelch("update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 898                              stp->gen->no, stp->no,
 899                              stp->n_blocks, blocks););
 900         stp->n_blocks = blocks;
 901     }
 902 }