ghc/rts/GCCompact.c

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