ghc/rts/GCCompact.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GCCompact.c,v 1.6 2001/08/02 15:33:35 ken 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         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                 // unset the next bit in the bitmap to indicate that
 727                 // this object needs to be pushed into the next
 728                 // block.  This saves us having to run down the
 729                 // threaded info pointer list twice during the next pass.
 730                 unmark(q+1,bd);
 731                 free_bd = free_bd->link;
 732                 free = free_bd->start;
 733             } else {
 734                 ASSERT(is_marked(q+1,bd));
 735             }
 736
 737             unthread(q,free);
 738             free += size;
 739 #if 0
 740             goto next;
 741 #endif
 742         }
 743     }
 744 }
 745
 746 static nat
 747 update_bkwd_compact( step *stp )
 748 {
 749     StgPtr p, free;
 750     StgWord m;
 751     bdescr *bd, *free_bd;
 752     StgInfoTable *info;
 753     nat size, free_blocks;
 754
 755     bd = free_bd = stp->blocks;
 756     free = free_bd->start;
 757     free_blocks = 1;
 758
 759 #if defined(PAR)
 760     barf("update_bkwd: ToDo");
 761 #endif
 762
 763     // cycle through all the blocks in the step
 764     for (; bd != NULL; bd = bd->link) {
 765         p = bd->start;
 766
 767         while (p < bd->free ) {
 768
 769             while ( p < bd->free && !is_marked(p,bd) ) {
 770                 p++;
 771             }
 772             if (p >= bd->free) {
 773                 break;
 774             }
 775
 776 #if 0
 777     next:
 778         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 779         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 780
 781         while ( p < bd->free ) {
 782
 783             if ((m & 1) == 0) {
 784                 m >>= 1;
 785                 p++;
 786                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 787                     goto next;
 788                 } else {
 789                     continue;
 790                 }
 791             }
 792 #endif
 793
 794             if (!is_marked(p+1,bd)) {
 795                 // don't forget to update the free ptr in the block desc.
 796                 free_bd->free = free;
 797                 free_bd = free_bd->link;
 798                 free = free_bd->start;
 799                 free_blocks++;
 800             }
 801
 802             unthread(p,free);
 803             info = get_itbl((StgClosure *)p);
 804             size = obj_sizeW((StgClosure *)p,info);
 805
 806             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 807                          || IS_HUGS_CONSTR_INFO(info)));
 808
 809             if (free != p) {
 810                 move(free,p,size);
 811             }
 812
 813             // Rebuild the mutable list for the old generation.
 814             // (the mut_once list is updated using threading, with
 815             // special cases for IND_OLDGEN and MUT_CONS above).
 816             if (ip_MUTABLE(info)) {
 817                 recordMutable((StgMutClosure *)free);
 818             }
 819
 820             // relocate TSOs
 821             if (info->type == TSO) {
 822                 move_TSO((StgTSO *)p, (StgTSO *)free);
 823             }
 824
 825             free += size;
 826             p += size;
 827 #if 0
 828             goto next;
 829 #endif
 830         }
 831     }
 832
 833     // free the remaining blocks and count what's left.
 834     free_bd->free = free;
 835     if (free_bd->link != NULL) {
 836         freeChain(free_bd->link);
 837         free_bd->link = NULL;
 838     }
 839     stp->n_blocks = free_blocks;
 840
 841     return free_blocks;
 842 }
 843
 844 void
 845 compact( void (*get_roots)(evac_fn) )
 846 {
 847     nat g, s, blocks;
 848     step *stp;
 849     extern StgWeak *old_weak_ptr_list; // tmp
 850
 851     // 1. thread the roots
 852     get_roots((evac_fn)thread);
 853
 854     // the weak pointer lists...
 855     if (weak_ptr_list != NULL) {
 856         thread((StgPtr)&weak_ptr_list);
 857     }
 858     if (old_weak_ptr_list != NULL) {
 859         thread((StgPtr)&old_weak_ptr_list); // tmp
 860     }
 861
 862     // mutable lists
 863     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 864         thread((StgPtr)&generations[g].mut_list);
 865         thread((StgPtr)&generations[g].mut_once_list);
 866     }
 867
 868     // the global thread list
 869     thread((StgPtr)&all_threads);
 870
 871     // the static objects
 872     thread_static(scavenged_static_objects);
 873
 874     // the stable pointer table
 875     threadStablePtrTable((evac_fn)thread);
 876
 877     // 2. update forward ptrs
 878     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 879         for (s = 0; s < generations[g].n_steps; s++) {
 880             stp = &generations[g].steps[s];
 881             IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 882
 883             update_fwd(stp->to_blocks);
 884             update_fwd_large(stp->scavenged_large_objects);
 885             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 886                 IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 887                 update_fwd_compact(stp->blocks);
 888             }
 889         }
 890     }
 891
 892     // 3. update backward ptrs
 893     stp = &oldest_gen->steps[0];
 894     if (stp->blocks != NULL) {
 895         blocks = update_bkwd_compact(stp);
 896         IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 897                              stp->gen->no, stp->no,
 898                              stp->n_blocks, blocks););
 899         stp->n_blocks = blocks;
 900     }
 901 }