ghc/rts/GCCompact.c

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