ghc/rts/GCCompact.c

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