ghc/rts/GCCompact.c

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