ghc/rts/GCCompact.c

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