ghc/rts/GCCompact.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GCCompact.c,v 1.7 2001/08/08 13:44:13 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             // specialise this case, because we want to update the
 450             // mut_link field too.
 451             case IND_OLDGEN:
 452             case IND_OLDGEN_PERM:
 453             {
 454                 StgIndOldGen *ind = (StgIndOldGen *)p;
 455                 thread((StgPtr)&ind->indirectee);
 456                 if (ind->mut_link != NULL) {
 457                     thread((StgPtr)&ind->mut_link);
 458                 }
 459                 break;
 460             }
 461
 462             case THUNK_SELECTOR:
 463             {
 464                 StgSelector *s = (StgSelector *)p;
 465                 thread((StgPtr)&s->selectee);
 466                 p += THUNK_SELECTOR_sizeW();
 467                 break;
 468             }
 469
 470             case AP_UPD: // same as PAPs
 471             case PAP:
 472             {
 473                 StgPAP* pap = (StgPAP *)p;
 474
 475                 thread((P_)&pap->fun);
 476                 thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
 477                 p += pap_sizeW(pap);
 478                 break;
 479             }
 480
 481             case ARR_WORDS:
 482                 p += arr_words_sizeW((StgArrWords *)p);
 483                 break;
 484
 485             case MUT_ARR_PTRS:
 486             case MUT_ARR_PTRS_FROZEN:
 487                 // follow everything
 488             {
 489                 StgPtr next;
 490
 491                 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 492                 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 493                     thread(p);
 494                 }
 495                 break;
 496             }
 497
 498             case TSO:
 499             {
 500                 StgTSO *tso = (StgTSO *)p;
 501                 thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 502                 thread((StgPtr)&tso->link);
 503                 thread((StgPtr)&tso->global_link);
 504                 p += tso_sizeW(tso);
 505                 break;
 506             }
 507
 508             default:
 509                 barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 510             }
 511         }
 512     }
 513 }
 514
 515 static void
 516 update_fwd_compact( bdescr *blocks )
 517 {
 518     StgPtr p, q, free;
 519     StgWord m;
 520     bdescr *bd, *free_bd;
 521     StgInfoTable *info;
 522     nat size;
 523
 524     bd = blocks;
 525     free_bd = blocks;
 526     free = free_bd->start;
 527
 528 #if defined(PAR)
 529     barf("update_fwd: ToDo");
 530 #endif
 531
 532     // cycle through all the blocks in the step
 533     for (; bd != NULL; bd = bd->link) {
 534         p = bd->start;
 535
 536         while (p < bd->free ) {
 537
 538             while ( p < bd->free && !is_marked(p,bd) ) {
 539                 p++;
 540             }
 541             if (p >= bd->free) {
 542                 break;
 543             }
 544
 545 #if 0
 546     next:
 547         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 548         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 549
 550         while ( p < bd->free ) {
 551
 552             if ((m & 1) == 0) {
 553                 m >>= 1;
 554                 p++;
 555                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 556                     goto next;
 557                 } else {
 558                     continue;
 559                 }
 560             }
 561 #endif
 562
 563             // Problem: we need to know the destination for this cell
 564             // in order to unthread its info pointer.  But we can't
 565             // know the destination without the size, because we may
 566             // spill into the next block.  So we have to run down the
 567             // threaded list and get the info ptr first.
 568             info = get_threaded_info(p);
 569
 570             q = p;
 571             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 572                          || IS_HUGS_CONSTR_INFO(info)));
 573
 574             switch (info->type) {
 575             case FUN_0_1:
 576             case CONSTR_0_1:
 577                 p += sizeofW(StgHeader) + 1;
 578                 break;
 579
 580             case FUN_1_0:
 581             case CONSTR_1_0:
 582                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 583                 p += sizeofW(StgHeader) + 1;
 584                 break;
 585
 586             case THUNK_1_0:
 587                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 588                 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 589                 break;
 590
 591             case THUNK_0_1: // MIN_UPD_SIZE
 592             case THUNK_0_2:
 593             case FUN_0_2:
 594             case CONSTR_0_2:
 595                 p += sizeofW(StgHeader) + 2;
 596                 break;
 597
 598             case THUNK_1_1:
 599             case FUN_1_1:
 600             case CONSTR_1_1:
 601                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 602                 p += sizeofW(StgHeader) + 2;
 603                 break;
 604
 605             case THUNK_2_0:
 606             case FUN_2_0:
 607             case CONSTR_2_0:
 608                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 609                 thread((StgPtr)&((StgClosure *)p)->payload[1]);
 610                 p += sizeofW(StgHeader) + 2;
 611                 break;
 612
 613             case FUN:
 614             case THUNK:
 615             case CONSTR:
 616             case FOREIGN:
 617             case STABLE_NAME:
 618             case BCO:
 619             case IND_PERM:
 620             case MUT_VAR:
 621             case MUT_CONS:
 622             case CAF_BLACKHOLE:
 623             case SE_CAF_BLACKHOLE:
 624             case SE_BLACKHOLE:
 625             case BLACKHOLE:
 626             case BLACKHOLE_BQ:
 627             {
 628                 StgPtr end;
 629
 630                 end = (P_)((StgClosure *)p)->payload +
 631                     info->layout.payload.ptrs;
 632                 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 633                     thread(p);
 634                 }
 635                 p += info->layout.payload.nptrs;
 636                 break;
 637             }
 638
 639             case WEAK:
 640             {
 641                 StgWeak *w = (StgWeak *)p;
 642                 thread((StgPtr)&w->key);
 643                 thread((StgPtr)&w->value);
 644                 thread((StgPtr)&w->finalizer);
 645                 if (w->link != NULL) {
 646                     thread((StgPtr)&w->link);
 647                 }
 648                 p += sizeofW(StgWeak);
 649                 break;
 650             }
 651
 652             case MVAR:
 653             {
 654                 StgMVar *mvar = (StgMVar *)p;
 655                 thread((StgPtr)&mvar->head);
 656                 thread((StgPtr)&mvar->tail);
 657                 thread((StgPtr)&mvar->value);
 658                 p += sizeofW(StgMVar);
 659                 break;
 660             }
 661
 662             case IND_OLDGEN:
 663             case IND_OLDGEN_PERM:
 664                 // specialise this case, because we want to update the
 665                 // mut_link field too.
 666             {
 667                 StgIndOldGen *ind = (StgIndOldGen *)p;
 668                 thread((StgPtr)&ind->indirectee);
 669                 if (ind->mut_link != NULL) {
 670                     thread((StgPtr)&ind->mut_link);
 671                 }
 672                 p += sizeofW(StgIndOldGen);
 673                 break;
 674             }
 675
 676             case THUNK_SELECTOR:
 677             {
 678                 StgSelector *s = (StgSelector *)p;
 679                 thread((StgPtr)&s->selectee);
 680                 p += THUNK_SELECTOR_sizeW();
 681                 break;
 682             }
 683
 684             case AP_UPD: // same as PAPs
 685             case PAP:
 686             {
 687                 StgPAP* pap = (StgPAP *)p;
 688
 689                 thread((P_)&pap->fun);
 690                 thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
 691                 p += pap_sizeW(pap);
 692                 break;
 693             }
 694
 695             case ARR_WORDS:
 696                 p += arr_words_sizeW((StgArrWords *)p);
 697                 break;
 698
 699             case MUT_ARR_PTRS:
 700             case MUT_ARR_PTRS_FROZEN:
 701                 // follow everything
 702             {
 703                 StgPtr next;
 704
 705                 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 706                 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 707                     thread(p);
 708                 }
 709                 break;
 710             }
 711
 712             case TSO:
 713             {
 714                 StgTSO *tso = (StgTSO *)p;
 715                 thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 716                 thread((StgPtr)&tso->link);
 717                 thread((StgPtr)&tso->global_link);
 718                 p += tso_sizeW(tso);
 719                 break;
 720             }
 721
 722             default:
 723                 barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 724             }
 725
 726             size = p - q;
 727             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 728                 // unset the next bit in the bitmap to indicate that
 729                 // this object needs to be pushed into the next
 730                 // block.  This saves us having to run down the
 731                 // threaded info pointer list twice during the next pass.
 732                 unmark(q+1,bd);
 733                 free_bd = free_bd->link;
 734                 free = free_bd->start;
 735             } else {
 736                 ASSERT(is_marked(q+1,bd));
 737             }
 738
 739             unthread(q,free);
 740             free += size;
 741 #if 0
 742             goto next;
 743 #endif
 744         }
 745     }
 746 }
 747
 748 static nat
 749 update_bkwd_compact( step *stp )
 750 {
 751     StgPtr p, free;
 752     StgWord m;
 753     bdescr *bd, *free_bd;
 754     StgInfoTable *info;
 755     nat size, free_blocks;
 756
 757     bd = free_bd = stp->blocks;
 758     free = free_bd->start;
 759     free_blocks = 1;
 760
 761 #if defined(PAR)
 762     barf("update_bkwd: ToDo");
 763 #endif
 764
 765     // cycle through all the blocks in the step
 766     for (; bd != NULL; bd = bd->link) {
 767         p = bd->start;
 768
 769         while (p < bd->free ) {
 770
 771             while ( p < bd->free && !is_marked(p,bd) ) {
 772                 p++;
 773             }
 774             if (p >= bd->free) {
 775                 break;
 776             }
 777
 778 #if 0
 779     next:
 780         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 781         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 782
 783         while ( p < bd->free ) {
 784
 785             if ((m & 1) == 0) {
 786                 m >>= 1;
 787                 p++;
 788                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 789                     goto next;
 790                 } else {
 791                     continue;
 792                 }
 793             }
 794 #endif
 795
 796             if (!is_marked(p+1,bd)) {
 797                 // don't forget to update the free ptr in the block desc.
 798                 free_bd->free = free;
 799                 free_bd = free_bd->link;
 800                 free = free_bd->start;
 801                 free_blocks++;
 802             }
 803
 804             unthread(p,free);
 805             info = get_itbl((StgClosure *)p);
 806             size = obj_sizeW((StgClosure *)p,info);
 807
 808             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 809                          || IS_HUGS_CONSTR_INFO(info)));
 810
 811             if (free != p) {
 812                 move(free,p,size);
 813             }
 814
 815             // Rebuild the mutable list for the old generation.
 816             // (the mut_once list is updated using threading, with
 817             // special cases for IND_OLDGEN and MUT_CONS above).
 818             if (ip_MUTABLE(info)) {
 819                 recordMutable((StgMutClosure *)free);
 820             }
 821
 822             // relocate TSOs
 823             if (info->type == TSO) {
 824                 move_TSO((StgTSO *)p, (StgTSO *)free);
 825             }
 826
 827             free += size;
 828             p += size;
 829 #if 0
 830             goto next;
 831 #endif
 832         }
 833     }
 834
 835     // free the remaining blocks and count what's left.
 836     free_bd->free = free;
 837     if (free_bd->link != NULL) {
 838         freeChain(free_bd->link);
 839         free_bd->link = NULL;
 840     }
 841     stp->n_blocks = free_blocks;
 842
 843     return free_blocks;
 844 }
 845
 846 void
 847 compact( void (*get_roots)(evac_fn) )
 848 {
 849     nat g, s, blocks;
 850     step *stp;
 851     extern StgWeak *old_weak_ptr_list; // tmp
 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((StgPtr)&generations[g].mut_once_list);
 868     }
 869
 870     // the global thread list
 871     thread((StgPtr)&all_threads);
 872
 873     // the static objects
 874     thread_static(scavenged_static_objects);
 875
 876     // the stable pointer table
 877     threadStablePtrTable((evac_fn)thread);
 878
 879     // 2. update forward ptrs
 880     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 881         for (s = 0; s < generations[g].n_steps; s++) {
 882             stp = &generations[g].steps[s];
 883             IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 884
 885             update_fwd(stp->to_blocks);
 886             update_fwd_large(stp->scavenged_large_objects);
 887             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 888                 IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 889                 update_fwd_compact(stp->blocks);
 890             }
 891         }
 892     }
 893
 894     // 3. update backward ptrs
 895     stp = &oldest_gen->steps[0];
 896     if (stp->blocks != NULL) {
 897         blocks = update_bkwd_compact(stp);
 898         IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 899                              stp->gen->no, stp->no,
 900                              stp->n_blocks, blocks););
 901         stp->n_blocks = blocks;
 902     }
 903 }