ghc/rts/GCCompact.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GCCompact.c,v 1.19 2004/08/13 13:09:56 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 "Apply.h"
  20
  21 // Turn off inlining when debugging - it obfuscates things
  22 #ifdef DEBUG
  23 # undef  STATIC_INLINE
  24 # define STATIC_INLINE static
  25 #endif
  26
  27 /* -----------------------------------------------------------------------------
  28    Threading / unthreading pointers.
  29
  30    The basic idea here is to chain together all the fields pointing at
  31    a particular object, with the root of the chain in the object's
  32    info table field.  The original contents of the info pointer goes
  33    at the end of the chain.
  34
  35    Adding a new field to the chain is a matter of swapping the
  36    contents of the field with the contents of the object's info table
  37    field.
  38
  39    To unthread the chain, we walk down it updating all the fields on
  40    the chain with the new location of the object.  We stop when we
  41    reach the info pointer at the end.
  42
  43    We use a trick to identify the info pointer: when swapping pointers
  44    for threading, we set the low bit of the original pointer, with the
  45    result that all the pointers in the chain have their low bits set
  46    except for the info pointer.
  47    -------------------------------------------------------------------------- */
  48
  49 STATIC_INLINE void
  50 thread( StgPtr p )
  51 {
  52     StgPtr q = (StgPtr)*p;
  53     bdescr *bd;
  54
  55     // It doesn't look like a closure at the moment, because the info
  56     // ptr is possibly threaded:
  57     // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
  58
  59     if (HEAP_ALLOCED(q)) {
  60         bd = Bdescr(q);
  61         // a handy way to discover whether the ptr is into the
  62         // compacted area of the old gen, is that the EVACUATED flag
  63         // is zero (it's non-zero for all the other areas of live
  64         // memory).
  65         if ((bd->flags & BF_EVACUATED) == 0) {
  66             *p = (StgWord)*q;
  67             *q = (StgWord)p + 1;        // set the low bit
  68         }
  69     }
  70 }
  71
  72 STATIC_INLINE void
  73 unthread( StgPtr p, StgPtr free )
  74 {
  75     StgPtr q = (StgPtr)*p, r;
  76
  77     while (((StgWord)q & 1) != 0) {
  78         (StgWord)q -= 1;        // unset the low bit again
  79         r = (StgPtr)*q;
  80         *q = (StgWord)free;
  81         q = r;
  82     }
  83     *p = (StgWord)q;
  84 }
  85
  86 STATIC_INLINE StgInfoTable *
  87 get_threaded_info( StgPtr p )
  88 {
  89     StgPtr q = (P_)GET_INFO((StgClosure *)p);
  90
  91     while (((StgWord)q & 1) != 0) {
  92         q = (P_)*((StgPtr)((StgWord)q-1));
  93     }
  94
  95     ASSERT(LOOKS_LIKE_INFO_PTR(q));
  96     return INFO_PTR_TO_STRUCT((StgInfoTable *)q);
  97 }
  98
  99 // A word-aligned memmove will be faster for small objects than libc's or gcc's.
 100 // Remember, the two regions *might* overlap, but: to <= from.
 101 STATIC_INLINE void
 102 move(StgPtr to, StgPtr from, nat size)
 103 {
 104     for(; size > 0; --size) {
 105         *to++ = *from++;
 106     }
 107 }
 108
 109 STATIC_INLINE nat
 110 obj_sizeW( StgClosure *p, StgInfoTable *info )
 111 {
 112     switch (info->type) {
 113     case FUN_0_1:
 114     case CONSTR_0_1:
 115     case FUN_1_0:
 116     case CONSTR_1_0:
 117         return sizeofW(StgHeader) + 1;
 118     case THUNK_0_1:
 119     case THUNK_0_2:
 120     case FUN_0_2:
 121     case CONSTR_0_2:
 122     case THUNK_1_0:
 123     case THUNK_1_1:
 124     case FUN_1_1:
 125     case CONSTR_1_1:
 126     case THUNK_2_0:
 127     case FUN_2_0:
 128     case CONSTR_2_0:
 129         return sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 130     case THUNK_SELECTOR:
 131         return THUNK_SELECTOR_sizeW();
 132     case AP_STACK:
 133         return ap_stack_sizeW((StgAP_STACK *)p);
 134     case AP:
 135     case PAP:
 136         return pap_sizeW((StgPAP *)p);
 137     case ARR_WORDS:
 138         return arr_words_sizeW((StgArrWords *)p);
 139     case MUT_ARR_PTRS:
 140     case MUT_ARR_PTRS_FROZEN:
 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     default:
 147         return sizeW_fromITBL(info);
 148     }
 149 }
 150
 151 static void
 152 thread_static( StgClosure* p )
 153 {
 154   const StgInfoTable *info;
 155
 156   // keep going until we've threaded all the objects on the linked
 157   // list...
 158   while (p != END_OF_STATIC_LIST) {
 159
 160     info = get_itbl(p);
 161     switch (info->type) {
 162
 163     case IND_STATIC:
 164         thread((StgPtr)&((StgInd *)p)->indirectee);
 165         p = IND_STATIC_LINK(p);
 166         continue;
 167
 168     case THUNK_STATIC:
 169         p = THUNK_STATIC_LINK(p);
 170         continue;
 171     case FUN_STATIC:
 172         p = FUN_STATIC_LINK(p);
 173         continue;
 174     case CONSTR_STATIC:
 175         p = STATIC_LINK(info,p);
 176         continue;
 177
 178     default:
 179         barf("thread_static: strange closure %d", (int)(info->type));
 180     }
 181
 182   }
 183 }
 184
 185 STATIC_INLINE void
 186 thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
 187 {
 188     nat i, b;
 189     StgWord bitmap;
 190
 191     b = 0;
 192     bitmap = large_bitmap->bitmap[b];
 193     for (i = 0; i < size; ) {
 194         if ((bitmap & 1) == 0) {
 195             thread(p);
 196         }
 197         i++;
 198         p++;
 199         if (i % BITS_IN(W_) == 0) {
 200             b++;
 201             bitmap = large_bitmap->bitmap[b];
 202         } else {
 203             bitmap = bitmap >> 1;
 204         }
 205     }
 206 }
 207
 208 STATIC_INLINE StgPtr
 209 thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
 210 {
 211     StgPtr p;
 212     StgWord bitmap;
 213     nat size;
 214
 215     p = (StgPtr)args;
 216     switch (fun_info->f.fun_type) {
 217     case ARG_GEN:
 218         bitmap = BITMAP_BITS(fun_info->f.bitmap);
 219         size = BITMAP_SIZE(fun_info->f.bitmap);
 220         goto small_bitmap;
 221     case ARG_GEN_BIG:
 222         size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
 223         thread_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
 224         p += size;
 225         break;
 226     default:
 227         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 228         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 229     small_bitmap:
 230         while (size > 0) {
 231             if ((bitmap & 1) == 0) {
 232                 thread(p);
 233             }
 234             p++;
 235             bitmap = bitmap >> 1;
 236             size--;
 237         }
 238         break;
 239     }
 240     return p;
 241 }
 242
 243 static void
 244 thread_stack(StgPtr p, StgPtr stack_end)
 245 {
 246     const StgRetInfoTable* info;
 247     StgWord bitmap;
 248     nat size;
 249
 250     // highly similar to scavenge_stack, but we do pointer threading here.
 251
 252     while (p < stack_end) {
 253
 254         // *p must be the info pointer of an activation
 255         // record.  All activation records have 'bitmap' style layout
 256         // info.
 257         //
 258         info  = get_ret_itbl((StgClosure *)p);
 259
 260         switch (info->i.type) {
 261
 262             // Dynamic bitmap: the mask is stored on the stack
 263         case RET_DYN:
 264         {
 265             StgWord dyn;
 266             dyn = ((StgRetDyn *)p)->liveness;
 267
 268             // traverse the bitmap first
 269             bitmap = RET_DYN_LIVENESS(dyn);
 270             p      = (P_)&((StgRetDyn *)p)->payload[0];
 271             size   = RET_DYN_BITMAP_SIZE;
 272             while (size > 0) {
 273                 if ((bitmap & 1) == 0) {
 274                     thread(p);
 275                 }
 276                 p++;
 277                 bitmap = bitmap >> 1;
 278                 size--;
 279             }
 280
 281             // skip over the non-ptr words
 282             p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
 283
 284             // follow the ptr words
 285             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 286                 thread(p);
 287                 p++;
 288             }
 289             continue;
 290         }
 291
 292             // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
 293         case UPDATE_FRAME:
 294         case STOP_FRAME:
 295         case CATCH_FRAME:
 296         case RET_SMALL:
 297         case RET_VEC_SMALL:
 298             bitmap = BITMAP_BITS(info->i.layout.bitmap);
 299             size   = BITMAP_SIZE(info->i.layout.bitmap);
 300             p++;
 301             // NOTE: the payload starts immediately after the info-ptr, we
 302             // don't have an StgHeader in the same sense as a heap closure.
 303             while (size > 0) {
 304                 if ((bitmap & 1) == 0) {
 305                     thread(p);
 306                 }
 307                 p++;
 308                 bitmap = bitmap >> 1;
 309                 size--;
 310             }
 311             continue;
 312
 313         case RET_BCO: {
 314             StgBCO *bco;
 315             nat size;
 316
 317             p++;
 318             bco = (StgBCO *)*p;
 319             thread(p);
 320             p++;
 321             size = BCO_BITMAP_SIZE(bco);
 322             thread_large_bitmap(p, BCO_BITMAP(bco), size);
 323             p += size;
 324             continue;
 325         }
 326
 327             // large bitmap (> 32 entries, or 64 on a 64-bit machine)
 328         case RET_BIG:
 329         case RET_VEC_BIG:
 330             p++;
 331             size = info->i.layout.large_bitmap->size;
 332             thread_large_bitmap(p, info->i.layout.large_bitmap, size);
 333             p += size;
 334             continue;
 335
 336         case RET_FUN:
 337         {
 338             StgRetFun *ret_fun = (StgRetFun *)p;
 339             StgFunInfoTable *fun_info;
 340
 341             fun_info = itbl_to_fun_itbl(
 342                 get_threaded_info((StgPtr)ret_fun->fun));
 343                  // *before* threading it!
 344             thread((StgPtr)&ret_fun->fun);
 345             p = thread_arg_block(fun_info, ret_fun->payload);
 346             continue;
 347         }
 348
 349         default:
 350             barf("thread_stack: weird activation record found on stack: %d",
 351                  (int)(info->i.type));
 352         }
 353     }
 354 }
 355
 356 STATIC_INLINE StgPtr
 357 thread_PAP (StgPAP *pap)
 358 {
 359     StgPtr p;
 360     StgWord bitmap, size;
 361     StgFunInfoTable *fun_info;
 362
 363     fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)pap->fun));
 364     ASSERT(fun_info->i.type != PAP);
 365
 366     p = (StgPtr)pap->payload;
 367     size = pap->n_args;
 368
 369     switch (fun_info->f.fun_type) {
 370     case ARG_GEN:
 371         bitmap = BITMAP_BITS(fun_info->f.bitmap);
 372         goto small_bitmap;
 373     case ARG_GEN_BIG:
 374         thread_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
 375         p += size;
 376         break;
 377     case ARG_BCO:
 378         thread_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
 379         p += size;
 380         break;
 381     default:
 382         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 383     small_bitmap:
 384         size = pap->n_args;
 385         while (size > 0) {
 386             if ((bitmap & 1) == 0) {
 387                 thread(p);
 388             }
 389             p++;
 390             bitmap = bitmap >> 1;
 391             size--;
 392         }
 393         break;
 394     }
 395
 396     thread((StgPtr)&pap->fun);
 397     return p;
 398 }
 399
 400 STATIC_INLINE StgPtr
 401 thread_AP_STACK (StgAP_STACK *ap)
 402 {
 403     thread((StgPtr)&ap->fun);
 404     thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
 405     return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
 406 }
 407
 408 static StgPtr
 409 thread_TSO (StgTSO *tso)
 410 {
 411     thread((StgPtr)&tso->link);
 412     thread((StgPtr)&tso->global_link);
 413
 414     if (   tso->why_blocked == BlockedOnMVar
 415         || tso->why_blocked == BlockedOnBlackHole
 416         || tso->why_blocked == BlockedOnException
 417 #if defined(PAR)
 418         || tso->why_blocked == BlockedOnGA
 419         || tso->why_blocked == BlockedOnGA_NoSend
 420 #endif
 421         ) {
 422         thread((StgPtr)&tso->block_info.closure);
 423     }
 424     if ( tso->blocked_exceptions != NULL ) {
 425         thread((StgPtr)&tso->blocked_exceptions);
 426     }
 427
 428     thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 429     return (StgPtr)tso + tso_sizeW(tso);
 430 }
 431
 432
 433 static void
 434 update_fwd_large( bdescr *bd )
 435 {
 436   StgPtr p;
 437   const StgInfoTable* info;
 438
 439   for (; bd != NULL; bd = bd->link) {
 440
 441     p = bd->start;
 442     info  = get_itbl((StgClosure *)p);
 443
 444     switch (info->type) {
 445
 446     case ARR_WORDS:
 447       // nothing to follow
 448       continue;
 449
 450     case MUT_ARR_PTRS:
 451     case MUT_ARR_PTRS_FROZEN:
 452       // follow everything
 453       {
 454         StgPtr next;
 455
 456         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 457         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 458             thread(p);
 459         }
 460         continue;
 461       }
 462
 463     case TSO:
 464         thread_TSO((StgTSO *)p);
 465         continue;
 466
 467     case AP_STACK:
 468         thread_AP_STACK((StgAP_STACK *)p);
 469         continue;
 470
 471     case PAP:
 472         thread_PAP((StgPAP *)p);
 473         continue;
 474
 475     default:
 476       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 477     }
 478   }
 479 }
 480
 481 STATIC_INLINE StgPtr
 482 thread_obj (StgInfoTable *info, StgPtr p)
 483 {
 484     switch (info->type) {
 485     case FUN_0_1:
 486     case CONSTR_0_1:
 487         return p + sizeofW(StgHeader) + 1;
 488
 489     case FUN_1_0:
 490     case CONSTR_1_0:
 491         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 492         return p + sizeofW(StgHeader) + 1;
 493
 494     case THUNK_1_0:
 495         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 496         return p + sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 497
 498     case THUNK_0_1: // MIN_UPD_SIZE
 499     case THUNK_0_2:
 500     case FUN_0_2:
 501     case CONSTR_0_2:
 502         return p + sizeofW(StgHeader) + 2;
 503
 504     case THUNK_1_1:
 505     case FUN_1_1:
 506     case CONSTR_1_1:
 507         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 508         return p + sizeofW(StgHeader) + 2;
 509
 510     case THUNK_2_0:
 511     case FUN_2_0:
 512     case CONSTR_2_0:
 513         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 514         thread((StgPtr)&((StgClosure *)p)->payload[1]);
 515         return p + sizeofW(StgHeader) + 2;
 516
 517     case BCO: {
 518         StgBCO *bco = (StgBCO *)p;
 519         thread((StgPtr)&bco->instrs);
 520         thread((StgPtr)&bco->literals);
 521         thread((StgPtr)&bco->ptrs);
 522         thread((StgPtr)&bco->itbls);
 523         return p + bco_sizeW(bco);
 524     }
 525
 526     case FUN:
 527     case THUNK:
 528     case CONSTR:
 529     case FOREIGN:
 530     case STABLE_NAME:
 531     case IND_PERM:
 532     case MUT_VAR:
 533     case MUT_CONS:
 534     case CAF_BLACKHOLE:
 535     case SE_CAF_BLACKHOLE:
 536     case SE_BLACKHOLE:
 537     case BLACKHOLE:
 538     case BLACKHOLE_BQ:
 539     {
 540         StgPtr end;
 541
 542         end = (P_)((StgClosure *)p)->payload +
 543             info->layout.payload.ptrs;
 544         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 545             thread(p);
 546         }
 547         return p + info->layout.payload.nptrs;
 548     }
 549
 550     case WEAK:
 551     {
 552         StgWeak *w = (StgWeak *)p;
 553         thread((StgPtr)&w->key);
 554         thread((StgPtr)&w->value);
 555         thread((StgPtr)&w->finalizer);
 556         if (w->link != NULL) {
 557             thread((StgPtr)&w->link);
 558         }
 559         return p + sizeofW(StgWeak);
 560     }
 561
 562     case MVAR:
 563     {
 564         StgMVar *mvar = (StgMVar *)p;
 565         thread((StgPtr)&mvar->head);
 566         thread((StgPtr)&mvar->tail);
 567         thread((StgPtr)&mvar->value);
 568         return p + sizeofW(StgMVar);
 569     }
 570
 571     case IND_OLDGEN:
 572     case IND_OLDGEN_PERM:
 573         thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
 574         return p + sizeofW(StgIndOldGen);
 575
 576     case THUNK_SELECTOR:
 577     {
 578         StgSelector *s = (StgSelector *)p;
 579         thread((StgPtr)&s->selectee);
 580         return p + THUNK_SELECTOR_sizeW();
 581     }
 582
 583     case AP_STACK:
 584         return thread_AP_STACK((StgAP_STACK *)p);
 585
 586     case PAP:
 587     case AP:
 588         return thread_PAP((StgPAP *)p);
 589
 590     case ARR_WORDS:
 591         return p + arr_words_sizeW((StgArrWords *)p);
 592
 593     case MUT_ARR_PTRS:
 594     case MUT_ARR_PTRS_FROZEN:
 595         // follow everything
 596     {
 597         StgPtr next;
 598
 599         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 600         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 601             thread(p);
 602         }
 603         return p;
 604     }
 605
 606     case TSO:
 607         return thread_TSO((StgTSO *)p);
 608
 609     default:
 610         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 611         return NULL;
 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 }