ghc/rts/GCCompact.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GCCompact.c,v 1.3 2001/07/24 15:13:01 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         break;
 152
 153     case THUNK_STATIC:
 154     case FUN_STATIC:
 155     case CONSTR_STATIC:
 156         break;
 157
 158     default:
 159         barf("thread_static: strange closure %d", (int)(info->type));
 160     }
 161
 162     p = STATIC_LINK(info,p);
 163   }
 164 }
 165
 166 static void
 167 thread_stack(StgPtr p, StgPtr stack_end)
 168 {
 169     StgPtr q;
 170     const StgInfoTable* info;
 171     StgWord32 bitmap;
 172
 173     // highly similar to scavenge_stack, but we do pointer threading here.
 174
 175     while (p < stack_end) {
 176         q = (StgPtr)*p;
 177
 178         // If we've got a tag, skip over that many words on the stack
 179         if ( IS_ARG_TAG((W_)q) ) {
 180             p += ARG_SIZE(q);
 181             p++; continue;
 182         }
 183
 184         // Is q a pointer to a closure?
 185         if ( !LOOKS_LIKE_GHC_INFO(q) ) {
 186             thread(p);
 187             p++;
 188             continue;
 189         }
 190
 191         // Otherwise, q must be the info pointer of an activation
 192         // record.  All activation records have 'bitmap' style layout
 193         // info.
 194         //
 195         info  = get_itbl((StgClosure *)p);
 196
 197         switch (info->type) {
 198
 199             // Dynamic bitmap: the mask is stored on the stack
 200         case RET_DYN:
 201             bitmap = ((StgRetDyn *)p)->liveness;
 202             p      = (P_)&((StgRetDyn *)p)->payload[0];
 203             goto small_bitmap;
 204
 205             // probably a slow-entry point return address:
 206         case FUN:
 207         case FUN_STATIC:
 208             p++;
 209             continue;
 210
 211             // small bitmap (< 32 entries, or 64 on a 64-bit machine)
 212         case UPDATE_FRAME:
 213         case STOP_FRAME:
 214         case CATCH_FRAME:
 215         case SEQ_FRAME:
 216         case RET_BCO:
 217         case RET_SMALL:
 218         case RET_VEC_SMALL:
 219             bitmap = info->layout.bitmap;
 220             p++;
 221             // this assumes that the payload starts immediately after the info-ptr
 222         small_bitmap:
 223             while (bitmap != 0) {
 224                 if ((bitmap & 1) == 0) {
 225                     thread(p);
 226                 }
 227                 p++;
 228                 bitmap = bitmap >> 1;
 229             }
 230             continue;
 231
 232             // large bitmap (> 32 entries)
 233         case RET_BIG:
 234         case RET_VEC_BIG:
 235         {
 236             StgPtr q;
 237             StgLargeBitmap *large_bitmap;
 238             nat i;
 239
 240             large_bitmap = info->layout.large_bitmap;
 241             p++;
 242
 243             for (i=0; i<large_bitmap->size; i++) {
 244                 bitmap = large_bitmap->bitmap[i];
 245                 q = p + sizeof(W_) * 8;
 246                 while (bitmap != 0) {
 247                     if ((bitmap & 1) == 0) {
 248                         thread(p);
 249                     }
 250                     p++;
 251                     bitmap = bitmap >> 1;
 252                 }
 253                 if (i+1 < large_bitmap->size) {
 254                     while (p < q) {
 255                         thread(p);
 256                         p++;
 257                     }
 258                 }
 259             }
 260             continue;
 261         }
 262
 263         default:
 264             barf("thread_stack: weird activation record found on stack: %d",
 265                  (int)(info->type));
 266         }
 267     }
 268 }
 269
 270 static void
 271 update_fwd_large( bdescr *bd )
 272 {
 273   StgPtr p;
 274   const StgInfoTable* info;
 275
 276   for (; bd != NULL; bd = bd->link) {
 277
 278     p = bd->start;
 279     info  = get_itbl((StgClosure *)p);
 280
 281     switch (info->type) {
 282
 283     case ARR_WORDS:
 284       // nothing to follow
 285       continue;
 286
 287     case MUT_ARR_PTRS:
 288     case MUT_ARR_PTRS_FROZEN:
 289       // follow everything
 290       {
 291         StgPtr next;
 292
 293         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 294         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 295             thread(p);
 296         }
 297         continue;
 298       }
 299
 300     case TSO:
 301     {
 302         StgTSO *tso = (StgTSO *)p;
 303         thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 304         continue;
 305     }
 306
 307     case AP_UPD:
 308     case PAP:
 309       {
 310         StgPAP* pap = (StgPAP *)p;
 311         thread((StgPtr)&pap->fun);
 312         thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
 313         continue;
 314       }
 315
 316     default:
 317       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 318     }
 319   }
 320 }
 321
 322 static void
 323 update_fwd( bdescr *blocks )
 324 {
 325     StgPtr p;
 326     bdescr *bd;
 327     StgInfoTable *info;
 328
 329     bd = blocks;
 330
 331 #if defined(PAR)
 332     barf("update_fwd: ToDo");
 333 #endif
 334
 335     // cycle through all the blocks in the step
 336     for (; bd != NULL; bd = bd->link) {
 337         p = bd->start;
 338
 339         // linearly scan the objects in this block
 340         while (p < bd->free) {
 341
 342             info = get_itbl((StgClosure *)p);
 343
 344             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 345                          || IS_HUGS_CONSTR_INFO(info)));
 346
 347             switch (info->type) {
 348             case FUN_0_1:
 349             case CONSTR_0_1:
 350                 p += sizeofW(StgHeader) + 1;
 351                 break;
 352
 353             case FUN_1_0:
 354             case CONSTR_1_0:
 355                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 356                 p += sizeofW(StgHeader) + 1;
 357                 break;
 358
 359             case THUNK_1_0:
 360                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 361                 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 362                 break;
 363
 364             case THUNK_0_1: // MIN_UPD_SIZE
 365             case THUNK_0_2:
 366             case FUN_0_2:
 367             case CONSTR_0_2:
 368                 p += sizeofW(StgHeader) + 2;
 369                 break;
 370
 371             case THUNK_1_1:
 372             case FUN_1_1:
 373             case CONSTR_1_1:
 374                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 375                 p += sizeofW(StgHeader) + 2;
 376                 break;
 377
 378             case THUNK_2_0:
 379             case FUN_2_0:
 380             case CONSTR_2_0:
 381                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 382                 thread((StgPtr)&((StgClosure *)p)->payload[1]);
 383                 p += sizeofW(StgHeader) + 2;
 384                 break;
 385
 386             case FUN:
 387             case THUNK:
 388             case CONSTR:
 389             case FOREIGN:
 390             case STABLE_NAME:
 391             case BCO:
 392             case IND_PERM:
 393             case MUT_VAR:
 394             case MUT_CONS:
 395             case CAF_BLACKHOLE:
 396             case SE_CAF_BLACKHOLE:
 397             case SE_BLACKHOLE:
 398             case BLACKHOLE:
 399             case BLACKHOLE_BQ:
 400             {
 401                 StgPtr end;
 402
 403                 end = (P_)((StgClosure *)p)->payload +
 404                     info->layout.payload.ptrs;
 405                 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 406                     thread(p);
 407                 }
 408                 p += info->layout.payload.nptrs;
 409                 break;
 410             }
 411
 412             // the info table for a weak ptr lies about the number of ptrs
 413             // (because we have special GC routines for them, but we
 414             // want to use the standard evacuate code).  So we have to
 415             // special case here.
 416             case WEAK:
 417             {
 418                 StgWeak *w = (StgWeak *)p;
 419                 thread((StgPtr)&w->key);
 420                 thread((StgPtr)&w->value);
 421                 thread((StgPtr)&w->finalizer);
 422                 if (w->link != NULL) {
 423                     thread((StgPtr)&w->link);
 424                 }
 425                 p += sizeofW(StgWeak);
 426                 break;
 427             }
 428
 429             // again, the info table for MVar isn't suitable here (it includes
 430             // the mut_link field as a pointer, and we don't want to
 431             // thread it).
 432             case MVAR:
 433             {
 434                 StgMVar *mvar = (StgMVar *)p;
 435                 thread((StgPtr)&mvar->head);
 436                 thread((StgPtr)&mvar->tail);
 437                 thread((StgPtr)&mvar->value);
 438                 p += sizeofW(StgMVar);
 439                 break;
 440             }
 441
 442             // specialise this case, because we want to update the
 443             // mut_link field too.
 444             case IND_OLDGEN:
 445             case IND_OLDGEN_PERM:
 446             {
 447                 StgIndOldGen *ind = (StgIndOldGen *)p;
 448                 thread((StgPtr)&ind->indirectee);
 449                 if (ind->mut_link != NULL) {
 450                     thread((StgPtr)&ind->mut_link);
 451                 }
 452                 break;
 453             }
 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                 // specialise this case, because we want to update the
 658                 // mut_link field too.
 659             {
 660                 StgIndOldGen *ind = (StgIndOldGen *)p;
 661                 thread((StgPtr)&ind->indirectee);
 662                 if (ind->mut_link != NULL) {
 663                     thread((StgPtr)&ind->mut_link);
 664                 }
 665                 p += sizeofW(StgIndOldGen);
 666                 break;
 667             }
 668
 669             case THUNK_SELECTOR:
 670             {
 671                 StgSelector *s = (StgSelector *)p;
 672                 thread((StgPtr)&s->selectee);
 673                 p += THUNK_SELECTOR_sizeW();
 674                 break;
 675             }
 676
 677             case AP_UPD: // same as PAPs
 678             case PAP:
 679             {
 680                 StgPAP* pap = (StgPAP *)p;
 681
 682                 thread((P_)&pap->fun);
 683                 thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
 684                 p += pap_sizeW(pap);
 685                 break;
 686             }
 687
 688             case ARR_WORDS:
 689                 p += arr_words_sizeW((StgArrWords *)p);
 690                 break;
 691
 692             case MUT_ARR_PTRS:
 693             case MUT_ARR_PTRS_FROZEN:
 694                 // follow everything
 695             {
 696                 StgPtr next;
 697
 698                 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 699                 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 700                     thread(p);
 701                 }
 702                 break;
 703             }
 704
 705             case TSO:
 706             {
 707                 StgTSO *tso = (StgTSO *)p;
 708                 thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 709                 thread((StgPtr)&tso->link);
 710                 thread((StgPtr)&tso->global_link);
 711                 p += tso_sizeW(tso);
 712                 break;
 713             }
 714
 715             default:
 716                 barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 717             }
 718
 719             size = p - q;
 720             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 721                 free_bd = free_bd->link;
 722                 free = free_bd->start;
 723             }
 724
 725             unthread(q,free);
 726             free += size;
 727 #if 0
 728             goto next;
 729 #endif
 730         }
 731     }
 732 }
 733
 734 static nat
 735 update_bkwd_compact( step *stp )
 736 {
 737     StgPtr p, free;
 738     StgWord m;
 739     bdescr *bd, *free_bd;
 740     StgInfoTable *info;
 741     nat size, free_blocks;
 742
 743     bd = free_bd = stp->blocks;
 744     free = free_bd->start;
 745     free_blocks = 1;
 746
 747 #if defined(PAR)
 748     barf("update_bkwd: ToDo");
 749 #endif
 750
 751     // cycle through all the blocks in the step
 752     for (; bd != NULL; bd = bd->link) {
 753         p = bd->start;
 754
 755         while (p < bd->free ) {
 756
 757             while ( p < bd->free && !is_marked(p,bd) ) {
 758                 p++;
 759             }
 760             if (p >= bd->free) {
 761                 break;
 762             }
 763
 764 #if 0
 765     next:
 766         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 767         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 768
 769         while ( p < bd->free ) {
 770
 771             if ((m & 1) == 0) {
 772                 m >>= 1;
 773                 p++;
 774                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 775                     goto next;
 776                 } else {
 777                     continue;
 778                 }
 779             }
 780 #endif
 781
 782             // must unthread before we look at the info ptr...
 783             info = get_threaded_info(p);
 784
 785             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 786                          || IS_HUGS_CONSTR_INFO(info)));
 787
 788             size = obj_sizeW((StgClosure *)p,info);
 789
 790             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 791                 // don't forget to update the free ptr in the block desc.
 792                 free_bd->free = free;
 793                 free_bd = free_bd->link;
 794                 free = free_bd->start;
 795                 free_blocks++;
 796             }
 797
 798             unthread(p,free);
 799             if (free != p) {
 800                 move(free,p,size);
 801             }
 802
 803             // Rebuild the mutable list for the old generation.
 804             // (the mut_once list is updated using threading, with
 805             // special cases for IND_OLDGEN and MUT_CONS above).
 806             if (ip_MUTABLE(info)) {
 807                 recordMutable((StgMutClosure *)free);
 808             }
 809
 810             // relocate TSOs
 811             if (info->type == TSO) {
 812                 move_TSO((StgTSO *)p, (StgTSO *)free);
 813             }
 814
 815             free += size;
 816             p += size;
 817 #if 0
 818             goto next;
 819 #endif
 820         }
 821     }
 822
 823     // free the remaining blocks and count what's left.
 824     free_bd->free = free;
 825     if (free_bd->link != NULL) {
 826         freeChain(free_bd->link);
 827         free_bd->link = NULL;
 828     }
 829     stp->n_blocks = free_blocks;
 830
 831     return free_blocks;
 832 }
 833
 834 void
 835 compact( void (*get_roots)(evac_fn) )
 836 {
 837     nat g, s, blocks;
 838     step *stp;
 839     extern StgWeak *old_weak_ptr_list; // tmp
 840
 841     // 1. thread the roots
 842     get_roots((evac_fn)thread);
 843
 844     // the weak pointer lists...
 845     if (weak_ptr_list != NULL) {
 846         thread((StgPtr)&weak_ptr_list);
 847     }
 848     if (old_weak_ptr_list != NULL) {
 849         thread((StgPtr)&old_weak_ptr_list); // tmp
 850     }
 851
 852     // mutable lists
 853     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 854         thread((StgPtr)&generations[g].mut_list);
 855         thread((StgPtr)&generations[g].mut_once_list);
 856     }
 857
 858     // the global thread list
 859     thread((StgPtr)&all_threads);
 860
 861     // the static objects
 862     thread_static(scavenged_static_objects);
 863
 864     // the stable pointer table
 865     threadStablePtrTable((evac_fn)thread);
 866
 867     // 2. update forward ptrs
 868     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 869         for (s = 0; s < generations[g].n_steps; s++) {
 870             stp = &generations[g].steps[s];
 871             IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 872
 873             update_fwd(stp->to_blocks);
 874             update_fwd_large(stp->scavenged_large_objects);
 875             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 876                 IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 877                 update_fwd_compact(stp->blocks);
 878             }
 879         }
 880     }
 881
 882     // 3. update backward ptrs
 883     stp = &oldest_gen->steps[0];
 884     if (stp->blocks != NULL) {
 885         blocks = update_bkwd_compact(stp);
 886         IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 887                              stp->gen->no, stp->no,
 888                              stp->n_blocks, blocks););
 889         stp->n_blocks = blocks;
 890     }
 891 }