ghc/rts/GCCompact.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GCCompact.c,v 1.15 2003/03/24 16:18:26 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(
 344                 get_threaded_info((StgPtr)ret_fun->fun));
 345                  // *before* threading it!
 346             thread((StgPtr)&ret_fun->fun);
 347             p = thread_arg_block(fun_info, ret_fun->payload);
 348             continue;
 349         }
 350
 351         default:
 352             barf("thread_stack: weird activation record found on stack: %d",
 353                  (int)(info->i.type));
 354         }
 355     }
 356 }
 357
 358 static INLINE StgPtr
 359 thread_PAP (StgPAP *pap)
 360 {
 361     StgPtr p;
 362     StgWord bitmap, size;
 363     StgFunInfoTable *fun_info;
 364
 365     fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)pap->fun));
 366     ASSERT(fun_info->i.type != PAP);
 367
 368     p = (StgPtr)pap->payload;
 369     size = pap->n_args;
 370
 371     switch (fun_info->fun_type) {
 372     case ARG_GEN:
 373         bitmap = BITMAP_BITS(fun_info->bitmap);
 374         goto small_bitmap;
 375     case ARG_GEN_BIG:
 376         thread_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
 377         p += size;
 378         break;
 379     case ARG_BCO:
 380         thread_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
 381         p += size;
 382         break;
 383     default:
 384         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
 385     small_bitmap:
 386         size = pap->n_args;
 387         while (size > 0) {
 388             if ((bitmap & 1) == 0) {
 389                 thread(p);
 390             }
 391             p++;
 392             bitmap = bitmap >> 1;
 393             size--;
 394         }
 395         break;
 396     }
 397
 398     thread((StgPtr)&pap->fun);
 399     return p;
 400 }
 401
 402 static INLINE StgPtr
 403 thread_AP_STACK (StgAP_STACK *ap)
 404 {
 405     thread((StgPtr)&ap->fun);
 406     thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
 407     return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
 408 }
 409
 410 static StgPtr
 411 thread_TSO (StgTSO *tso)
 412 {
 413     thread((StgPtr)&tso->link);
 414     thread((StgPtr)&tso->global_link);
 415
 416     if (   tso->why_blocked == BlockedOnMVar
 417         || tso->why_blocked == BlockedOnBlackHole
 418         || tso->why_blocked == BlockedOnException
 419 #if defined(PAR)
 420         || tso->why_blocked == BlockedOnGA
 421         || tso->why_blocked == BlockedOnGA_NoSend
 422 #endif
 423         ) {
 424         thread((StgPtr)&tso->block_info.closure);
 425     }
 426     if ( tso->blocked_exceptions != NULL ) {
 427         thread((StgPtr)&tso->blocked_exceptions);
 428     }
 429
 430     thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 431     return (StgPtr)tso + tso_sizeW(tso);
 432 }
 433
 434
 435 static void
 436 update_fwd_large( bdescr *bd )
 437 {
 438   StgPtr p;
 439   const StgInfoTable* info;
 440
 441   for (; bd != NULL; bd = bd->link) {
 442
 443     p = bd->start;
 444     info  = get_itbl((StgClosure *)p);
 445
 446     switch (info->type) {
 447
 448     case ARR_WORDS:
 449       // nothing to follow
 450       continue;
 451
 452     case MUT_ARR_PTRS:
 453     case MUT_ARR_PTRS_FROZEN:
 454       // follow everything
 455       {
 456         StgPtr next;
 457
 458         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 459         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 460             thread(p);
 461         }
 462         continue;
 463       }
 464
 465     case TSO:
 466         thread_TSO((StgTSO *)p);
 467         continue;
 468
 469     case AP_STACK:
 470         thread_AP_STACK((StgAP_STACK *)p);
 471         continue;
 472
 473     case PAP:
 474         thread_PAP((StgPAP *)p);
 475         continue;
 476
 477     default:
 478       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 479     }
 480   }
 481 }
 482
 483 static INLINE StgPtr
 484 thread_obj (StgInfoTable *info, StgPtr p)
 485 {
 486     switch (info->type) {
 487     case FUN_0_1:
 488     case CONSTR_0_1:
 489         return p + sizeofW(StgHeader) + 1;
 490
 491     case FUN_1_0:
 492     case CONSTR_1_0:
 493         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 494         return p + sizeofW(StgHeader) + 1;
 495
 496     case THUNK_1_0:
 497         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 498         return p + sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 499
 500     case THUNK_0_1: // MIN_UPD_SIZE
 501     case THUNK_0_2:
 502     case FUN_0_2:
 503     case CONSTR_0_2:
 504         return p + sizeofW(StgHeader) + 2;
 505
 506     case THUNK_1_1:
 507     case FUN_1_1:
 508     case CONSTR_1_1:
 509         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 510         return p + sizeofW(StgHeader) + 2;
 511
 512     case THUNK_2_0:
 513     case FUN_2_0:
 514     case CONSTR_2_0:
 515         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 516         thread((StgPtr)&((StgClosure *)p)->payload[1]);
 517         return p + sizeofW(StgHeader) + 2;
 518
 519     case BCO: {
 520         StgBCO *bco = (StgBCO *)p;
 521         thread((StgPtr)&bco->instrs);
 522         thread((StgPtr)&bco->literals);
 523         thread((StgPtr)&bco->ptrs);
 524         thread((StgPtr)&bco->itbls);
 525         return p + bco_sizeW(bco);
 526     }
 527
 528     case FUN:
 529     case THUNK:
 530     case CONSTR:
 531     case FOREIGN:
 532     case STABLE_NAME:
 533     case IND_PERM:
 534     case MUT_VAR:
 535     case MUT_CONS:
 536     case CAF_BLACKHOLE:
 537     case SE_CAF_BLACKHOLE:
 538     case SE_BLACKHOLE:
 539     case BLACKHOLE:
 540     case BLACKHOLE_BQ:
 541     {
 542         StgPtr end;
 543
 544         end = (P_)((StgClosure *)p)->payload +
 545             info->layout.payload.ptrs;
 546         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 547             thread(p);
 548         }
 549         return p + info->layout.payload.nptrs;
 550     }
 551
 552     case WEAK:
 553     {
 554         StgWeak *w = (StgWeak *)p;
 555         thread((StgPtr)&w->key);
 556         thread((StgPtr)&w->value);
 557         thread((StgPtr)&w->finalizer);
 558         if (w->link != NULL) {
 559             thread((StgPtr)&w->link);
 560         }
 561         return p + sizeofW(StgWeak);
 562     }
 563
 564     case MVAR:
 565     {
 566         StgMVar *mvar = (StgMVar *)p;
 567         thread((StgPtr)&mvar->head);
 568         thread((StgPtr)&mvar->tail);
 569         thread((StgPtr)&mvar->value);
 570         return p + sizeofW(StgMVar);
 571     }
 572
 573     case IND_OLDGEN:
 574     case IND_OLDGEN_PERM:
 575         thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
 576         return p + sizeofW(StgIndOldGen);
 577
 578     case THUNK_SELECTOR:
 579     {
 580         StgSelector *s = (StgSelector *)p;
 581         thread((StgPtr)&s->selectee);
 582         return p + THUNK_SELECTOR_sizeW();
 583     }
 584
 585     case AP_STACK:
 586         return thread_AP_STACK((StgAP_STACK *)p);
 587
 588     case PAP:
 589     case AP:
 590         return thread_PAP((StgPAP *)p);
 591
 592     case ARR_WORDS:
 593         return p + arr_words_sizeW((StgArrWords *)p);
 594
 595     case MUT_ARR_PTRS:
 596     case MUT_ARR_PTRS_FROZEN:
 597         // follow everything
 598     {
 599         StgPtr next;
 600
 601         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 602         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 603             thread(p);
 604         }
 605         return p;
 606     }
 607
 608     case TSO:
 609         return thread_TSO((StgTSO *)p);
 610
 611     default:
 612         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 613     }
 614 }
 615
 616 static void
 617 update_fwd( bdescr *blocks )
 618 {
 619     StgPtr p;
 620     bdescr *bd;
 621     StgInfoTable *info;
 622
 623     bd = blocks;
 624
 625 #if defined(PAR)
 626     barf("update_fwd: ToDo");
 627 #endif
 628
 629     // cycle through all the blocks in the step
 630     for (; bd != NULL; bd = bd->link) {
 631         p = bd->start;
 632
 633         // linearly scan the objects in this block
 634         while (p < bd->free) {
 635             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 636             info = get_itbl((StgClosure *)p);
 637             p = thread_obj(info, p);
 638         }
 639     }
 640 }
 641
 642 static void
 643 update_fwd_compact( bdescr *blocks )
 644 {
 645     StgPtr p, q, free;
 646 #if 0
 647     StgWord m;
 648 #endif
 649     bdescr *bd, *free_bd;
 650     StgInfoTable *info;
 651     nat size;
 652
 653     bd = blocks;
 654     free_bd = blocks;
 655     free = free_bd->start;
 656
 657 #if defined(PAR)
 658     barf("update_fwd: ToDo");
 659 #endif
 660
 661     // cycle through all the blocks in the step
 662     for (; bd != NULL; bd = bd->link) {
 663         p = bd->start;
 664
 665         while (p < bd->free ) {
 666
 667             while ( p < bd->free && !is_marked(p,bd) ) {
 668                 p++;
 669             }
 670             if (p >= bd->free) {
 671                 break;
 672             }
 673
 674 #if 0
 675     next:
 676         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 677         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 678
 679         while ( p < bd->free ) {
 680
 681             if ((m & 1) == 0) {
 682                 m >>= 1;
 683                 p++;
 684                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 685                     goto next;
 686                 } else {
 687                     continue;
 688                 }
 689             }
 690 #endif
 691
 692             // Problem: we need to know the destination for this cell
 693             // in order to unthread its info pointer.  But we can't
 694             // know the destination without the size, because we may
 695             // spill into the next block.  So we have to run down the
 696             // threaded list and get the info ptr first.
 697             info = get_threaded_info(p);
 698
 699             q = p;
 700
 701             p = thread_obj(info, p);
 702
 703             size = p - q;
 704             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 705                 // unset the next bit in the bitmap to indicate that
 706                 // this object needs to be pushed into the next
 707                 // block.  This saves us having to run down the
 708                 // threaded info pointer list twice during the next pass.
 709                 unmark(q+1,bd);
 710                 free_bd = free_bd->link;
 711                 free = free_bd->start;
 712             } else {
 713                 ASSERT(is_marked(q+1,bd));
 714             }
 715
 716             unthread(q,free);
 717             free += size;
 718 #if 0
 719             goto next;
 720 #endif
 721         }
 722     }
 723 }
 724
 725 static nat
 726 update_bkwd_compact( step *stp )
 727 {
 728     StgPtr p, free;
 729 #if 0
 730     StgWord m;
 731 #endif
 732     bdescr *bd, *free_bd;
 733     StgInfoTable *info;
 734     nat size, free_blocks;
 735
 736     bd = free_bd = stp->blocks;
 737     free = free_bd->start;
 738     free_blocks = 1;
 739
 740 #if defined(PAR)
 741     barf("update_bkwd: ToDo");
 742 #endif
 743
 744     // cycle through all the blocks in the step
 745     for (; bd != NULL; bd = bd->link) {
 746         p = bd->start;
 747
 748         while (p < bd->free ) {
 749
 750             while ( p < bd->free && !is_marked(p,bd) ) {
 751                 p++;
 752             }
 753             if (p >= bd->free) {
 754                 break;
 755             }
 756
 757 #if 0
 758     next:
 759         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 760         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 761
 762         while ( p < bd->free ) {
 763
 764             if ((m & 1) == 0) {
 765                 m >>= 1;
 766                 p++;
 767                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 768                     goto next;
 769                 } else {
 770                     continue;
 771                 }
 772             }
 773 #endif
 774
 775             if (!is_marked(p+1,bd)) {
 776                 // don't forget to update the free ptr in the block desc.
 777                 free_bd->free = free;
 778                 free_bd = free_bd->link;
 779                 free = free_bd->start;
 780                 free_blocks++;
 781             }
 782
 783             unthread(p,free);
 784             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 785             info = get_itbl((StgClosure *)p);
 786             size = obj_sizeW((StgClosure *)p,info);
 787
 788             if (free != p) {
 789                 move(free,p,size);
 790             }
 791
 792             // Rebuild the mutable list for the old generation.
 793             if (ip_MUTABLE(info)) {
 794                 recordMutable((StgMutClosure *)free);
 795             }
 796
 797             // relocate TSOs
 798             if (info->type == TSO) {
 799                 move_TSO((StgTSO *)p, (StgTSO *)free);
 800             }
 801
 802             free += size;
 803             p += size;
 804 #if 0
 805             goto next;
 806 #endif
 807         }
 808     }
 809
 810     // free the remaining blocks and count what's left.
 811     free_bd->free = free;
 812     if (free_bd->link != NULL) {
 813         freeChain(free_bd->link);
 814         free_bd->link = NULL;
 815     }
 816     stp->n_blocks = free_blocks;
 817
 818     return free_blocks;
 819 }
 820
 821 static void
 822 thread_mut_once_list( generation *g )
 823 {
 824     StgMutClosure *p, *next;
 825
 826     for (p = g->mut_once_list; p != END_MUT_LIST; p = next) {
 827         next = p->mut_link;
 828         thread((StgPtr)&p->mut_link);
 829     }
 830
 831     thread((StgPtr)&g->mut_once_list);
 832 }
 833
 834 void
 835 compact( void (*get_roots)(evac_fn) )
 836 {
 837     nat g, s, blocks;
 838     step *stp;
 839
 840     // 1. thread the roots
 841     get_roots((evac_fn)thread);
 842
 843     // the weak pointer lists...
 844     if (weak_ptr_list != NULL) {
 845         thread((StgPtr)&weak_ptr_list);
 846     }
 847     if (old_weak_ptr_list != NULL) {
 848         thread((StgPtr)&old_weak_ptr_list); // tmp
 849     }
 850
 851     // mutable lists
 852     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 853         thread((StgPtr)&generations[g].mut_list);
 854         thread_mut_once_list(&generations[g]);
 855     }
 856
 857     // the global thread list
 858     thread((StgPtr)&all_threads);
 859
 860     // any threads resurrected during this GC
 861     thread((StgPtr)&resurrected_threads);
 862
 863     // the main threads list
 864     {
 865         StgMainThread *m;
 866         for (m = main_threads; m != NULL; m = m->link) {
 867             thread((StgPtr)&m->tso);
 868         }
 869     }
 870
 871     // the static objects
 872     thread_static(scavenged_static_objects);
 873
 874     // the stable pointer table
 875     threadStablePtrTable((evac_fn)thread);
 876
 877     // the CAF list (used by GHCi)
 878     markCAFs((evac_fn)thread);
 879
 880     // 2. update forward ptrs
 881     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 882         for (s = 0; s < generations[g].n_steps; s++) {
 883             stp = &generations[g].steps[s];
 884             IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 885
 886             update_fwd(stp->to_blocks);
 887             update_fwd_large(stp->scavenged_large_objects);
 888             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 889                 IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 890                 update_fwd_compact(stp->blocks);
 891             }
 892         }
 893     }
 894
 895     // 3. update backward ptrs
 896     stp = &oldest_gen->steps[0];
 897     if (stp->blocks != NULL) {
 898         blocks = update_bkwd_compact(stp);
 899         IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 900                              stp->gen->no, stp->no,
 901                              stp->n_blocks, blocks););
 902         stp->n_blocks = blocks;
 903     }
 904 }