ghc/rts/GCCompact.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team 2001
   4  *
   5  * Compacting garbage collector
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 #include "PosixSource.h"
  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 "Apply.h"
  19
  20 // Turn off inlining when debugging - it obfuscates things
  21 #ifdef DEBUG
  22 # undef  STATIC_INLINE
  23 # define STATIC_INLINE static
  24 #endif
  25
  26 /* -----------------------------------------------------------------------------
  27    Threading / unthreading pointers.
  28
  29    The basic idea here is to chain together all the fields pointing at
  30    a particular object, with the root of the chain in the object's
  31    info table field.  The original contents of the info pointer goes
  32    at the end of the chain.
  33
  34    Adding a new field to the chain is a matter of swapping the
  35    contents of the field with the contents of the object's info table
  36    field.
  37
  38    To unthread the chain, we walk down it updating all the fields on
  39    the chain with the new location of the object.  We stop when we
  40    reach the info pointer at the end.
  41
  42    We use a trick to identify the info pointer: when swapping pointers
  43    for threading, we set the low bit of the original pointer, with the
  44    result that all the pointers in the chain have their low bits set
  45    except for the info pointer.
  46    -------------------------------------------------------------------------- */
  47
  48 STATIC_INLINE void
  49 thread( StgPtr p )
  50 {
  51     StgPtr q = (StgPtr)*p;
  52     bdescr *bd;
  53
  54     // It doesn't look like a closure at the moment, because the info
  55     // ptr is possibly threaded:
  56     // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
  57
  58     if (HEAP_ALLOCED(q)) {
  59         bd = Bdescr(q);
  60         // a handy way to discover whether the ptr is into the
  61         // compacted area of the old gen, is that the EVACUATED flag
  62         // is zero (it's non-zero for all the other areas of live
  63         // memory).
  64         if ((bd->flags & BF_EVACUATED) == 0) {
  65             *p = (StgWord)*q;
  66             *q = (StgWord)p + 1;        // set the low bit
  67         }
  68     }
  69 }
  70
  71 STATIC_INLINE void
  72 unthread( StgPtr p, StgPtr free )
  73 {
  74     StgWord q = *p, r;
  75
  76     while ((q & 1) != 0) {
  77         q -= 1; // unset the low bit again
  78         r = *((StgPtr)q);
  79         *((StgPtr)q) = (StgWord)free;
  80         q = r;
  81     }
  82     *p = q;
  83 }
  84
  85 STATIC_INLINE StgInfoTable *
  86 get_threaded_info( StgPtr p )
  87 {
  88     StgPtr q = (P_)GET_INFO((StgClosure *)p);
  89
  90     while (((StgWord)q & 1) != 0) {
  91         q = (P_)*((StgPtr)((StgWord)q-1));
  92     }
  93
  94     ASSERT(LOOKS_LIKE_INFO_PTR(q));
  95     return INFO_PTR_TO_STRUCT((StgInfoTable *)q);
  96 }
  97
  98 // A word-aligned memmove will be faster for small objects than libc's or gcc's.
  99 // Remember, the two regions *might* overlap, but: to <= from.
 100 STATIC_INLINE void
 101 move(StgPtr to, StgPtr from, nat size)
 102 {
 103     for(; size > 0; --size) {
 104         *to++ = *from++;
 105     }
 106 }
 107
 108 STATIC_INLINE nat
 109 obj_sizeW( StgClosure *p, StgInfoTable *info )
 110 {
 111     switch (info->type) {
 112     case FUN_0_1:
 113     case CONSTR_0_1:
 114     case FUN_1_0:
 115     case CONSTR_1_0:
 116         return sizeofW(StgHeader) + 1;
 117     case THUNK_0_1:
 118     case THUNK_0_2:
 119     case FUN_0_2:
 120     case CONSTR_0_2:
 121     case THUNK_1_0:
 122     case THUNK_1_1:
 123     case FUN_1_1:
 124     case CONSTR_1_1:
 125     case THUNK_2_0:
 126     case FUN_2_0:
 127     case CONSTR_2_0:
 128         return sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 129     case THUNK_SELECTOR:
 130         return THUNK_SELECTOR_sizeW();
 131     case AP_STACK:
 132         return ap_stack_sizeW((StgAP_STACK *)p);
 133     case AP:
 134     case PAP:
 135         return pap_sizeW((StgPAP *)p);
 136     case ARR_WORDS:
 137         return arr_words_sizeW((StgArrWords *)p);
 138     case MUT_ARR_PTRS:
 139     case MUT_ARR_PTRS_FROZEN:
 140         return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 141     case TSO:
 142         return tso_sizeW((StgTSO *)p);
 143     case BCO:
 144         return bco_sizeW((StgBCO *)p);
 145     case TVAR_WAIT_QUEUE:
 146         return sizeofW(StgTVarWaitQueue);
 147     case TVAR:
 148         return sizeofW(StgTVar);
 149     case TREC_CHUNK:
 150         return sizeofW(StgTRecChunk);
 151     case TREC_HEADER:
 152         return sizeofW(StgTRecHeader);
 153     default:
 154         return sizeW_fromITBL(info);
 155     }
 156 }
 157
 158 static void
 159 thread_static( StgClosure* p )
 160 {
 161   const StgInfoTable *info;
 162
 163   // keep going until we've threaded all the objects on the linked
 164   // list...
 165   while (p != END_OF_STATIC_LIST) {
 166
 167     info = get_itbl(p);
 168     switch (info->type) {
 169
 170     case IND_STATIC:
 171         thread((StgPtr)&((StgInd *)p)->indirectee);
 172         p = IND_STATIC_LINK(p);
 173         continue;
 174
 175     case THUNK_STATIC:
 176         p = THUNK_STATIC_LINK(p);
 177         continue;
 178     case FUN_STATIC:
 179         p = FUN_STATIC_LINK(p);
 180         continue;
 181     case CONSTR_STATIC:
 182         p = STATIC_LINK(info,p);
 183         continue;
 184
 185     default:
 186         barf("thread_static: strange closure %d", (int)(info->type));
 187     }
 188
 189   }
 190 }
 191
 192 STATIC_INLINE void
 193 thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
 194 {
 195     nat i, b;
 196     StgWord bitmap;
 197
 198     b = 0;
 199     bitmap = large_bitmap->bitmap[b];
 200     for (i = 0; i < size; ) {
 201         if ((bitmap & 1) == 0) {
 202             thread(p);
 203         }
 204         i++;
 205         p++;
 206         if (i % BITS_IN(W_) == 0) {
 207             b++;
 208             bitmap = large_bitmap->bitmap[b];
 209         } else {
 210             bitmap = bitmap >> 1;
 211         }
 212     }
 213 }
 214
 215 STATIC_INLINE StgPtr
 216 thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
 217 {
 218     StgPtr p;
 219     StgWord bitmap;
 220     nat size;
 221
 222     p = (StgPtr)args;
 223     switch (fun_info->f.fun_type) {
 224     case ARG_GEN:
 225         bitmap = BITMAP_BITS(fun_info->f.bitmap);
 226         size = BITMAP_SIZE(fun_info->f.bitmap);
 227         goto small_bitmap;
 228     case ARG_GEN_BIG:
 229         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
 230         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 231         p += size;
 232         break;
 233     default:
 234         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 235         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 236     small_bitmap:
 237         while (size > 0) {
 238             if ((bitmap & 1) == 0) {
 239                 thread(p);
 240             }
 241             p++;
 242             bitmap = bitmap >> 1;
 243             size--;
 244         }
 245         break;
 246     }
 247     return p;
 248 }
 249
 250 static void
 251 thread_stack(StgPtr p, StgPtr stack_end)
 252 {
 253     const StgRetInfoTable* info;
 254     StgWord bitmap;
 255     nat size;
 256
 257     // highly similar to scavenge_stack, but we do pointer threading here.
 258
 259     while (p < stack_end) {
 260
 261         // *p must be the info pointer of an activation
 262         // record.  All activation records have 'bitmap' style layout
 263         // info.
 264         //
 265         info  = get_ret_itbl((StgClosure *)p);
 266
 267         switch (info->i.type) {
 268
 269             // Dynamic bitmap: the mask is stored on the stack
 270         case RET_DYN:
 271         {
 272             StgWord dyn;
 273             dyn = ((StgRetDyn *)p)->liveness;
 274
 275             // traverse the bitmap first
 276             bitmap = RET_DYN_LIVENESS(dyn);
 277             p      = (P_)&((StgRetDyn *)p)->payload[0];
 278             size   = RET_DYN_BITMAP_SIZE;
 279             while (size > 0) {
 280                 if ((bitmap & 1) == 0) {
 281                     thread(p);
 282                 }
 283                 p++;
 284                 bitmap = bitmap >> 1;
 285                 size--;
 286             }
 287
 288             // skip over the non-ptr words
 289             p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
 290
 291             // follow the ptr words
 292             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 293                 thread(p);
 294                 p++;
 295             }
 296             continue;
 297         }
 298
 299             // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
 300         case CATCH_RETRY_FRAME:
 301         case CATCH_STM_FRAME:
 302         case ATOMICALLY_FRAME:
 303         case UPDATE_FRAME:
 304         case STOP_FRAME:
 305         case CATCH_FRAME:
 306         case RET_SMALL:
 307         case RET_VEC_SMALL:
 308             bitmap = BITMAP_BITS(info->i.layout.bitmap);
 309             size   = BITMAP_SIZE(info->i.layout.bitmap);
 310             p++;
 311             // NOTE: the payload starts immediately after the info-ptr, we
 312             // don't have an StgHeader in the same sense as a heap closure.
 313             while (size > 0) {
 314                 if ((bitmap & 1) == 0) {
 315                     thread(p);
 316                 }
 317                 p++;
 318                 bitmap = bitmap >> 1;
 319                 size--;
 320             }
 321             continue;
 322
 323         case RET_BCO: {
 324             StgBCO *bco;
 325             nat size;
 326
 327             p++;
 328             bco = (StgBCO *)*p;
 329             thread(p);
 330             p++;
 331             size = BCO_BITMAP_SIZE(bco);
 332             thread_large_bitmap(p, BCO_BITMAP(bco), size);
 333             p += size;
 334             continue;
 335         }
 336
 337             // large bitmap (> 32 entries, or 64 on a 64-bit machine)
 338         case RET_BIG:
 339         case RET_VEC_BIG:
 340             p++;
 341             size = GET_LARGE_BITMAP(&info->i)->size;
 342             thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
 343             p += size;
 344             continue;
 345
 346         case RET_FUN:
 347         {
 348             StgRetFun *ret_fun = (StgRetFun *)p;
 349             StgFunInfoTable *fun_info;
 350
 351             fun_info = itbl_to_fun_itbl(
 352                 get_threaded_info((StgPtr)ret_fun->fun));
 353                  // *before* threading it!
 354             thread((StgPtr)&ret_fun->fun);
 355             p = thread_arg_block(fun_info, ret_fun->payload);
 356             continue;
 357         }
 358
 359         default:
 360             barf("thread_stack: weird activation record found on stack: %d",
 361                  (int)(info->i.type));
 362         }
 363     }
 364 }
 365
 366 STATIC_INLINE StgPtr
 367 thread_PAP (StgPAP *pap)
 368 {
 369     StgPtr p;
 370     StgWord bitmap, size;
 371     StgFunInfoTable *fun_info;
 372
 373     fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)pap->fun));
 374     ASSERT(fun_info->i.type != PAP);
 375
 376     p = (StgPtr)pap->payload;
 377     size = pap->n_args;
 378
 379     switch (fun_info->f.fun_type) {
 380     case ARG_GEN:
 381         bitmap = BITMAP_BITS(fun_info->f.bitmap);
 382         goto small_bitmap;
 383     case ARG_GEN_BIG:
 384         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 385         p += size;
 386         break;
 387     case ARG_BCO:
 388         thread_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
 389         p += size;
 390         break;
 391     default:
 392         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 393     small_bitmap:
 394         size = pap->n_args;
 395         while (size > 0) {
 396             if ((bitmap & 1) == 0) {
 397                 thread(p);
 398             }
 399             p++;
 400             bitmap = bitmap >> 1;
 401             size--;
 402         }
 403         break;
 404     }
 405
 406     thread((StgPtr)&pap->fun);
 407     return p;
 408 }
 409
 410 STATIC_INLINE StgPtr
 411 thread_AP_STACK (StgAP_STACK *ap)
 412 {
 413     thread((StgPtr)&ap->fun);
 414     thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
 415     return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
 416 }
 417
 418 static StgPtr
 419 thread_TSO (StgTSO *tso)
 420 {
 421     thread((StgPtr)&tso->link);
 422     thread((StgPtr)&tso->global_link);
 423
 424     if (   tso->why_blocked == BlockedOnMVar
 425         || tso->why_blocked == BlockedOnBlackHole
 426         || tso->why_blocked == BlockedOnException
 427 #if defined(PAR)
 428         || tso->why_blocked == BlockedOnGA
 429         || tso->why_blocked == BlockedOnGA_NoSend
 430 #endif
 431         ) {
 432         thread((StgPtr)&tso->block_info.closure);
 433     }
 434     if ( tso->blocked_exceptions != NULL ) {
 435         thread((StgPtr)&tso->blocked_exceptions);
 436     }
 437
 438     thread((StgPtr)&tso->trec);
 439
 440     thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 441     return (StgPtr)tso + tso_sizeW(tso);
 442 }
 443
 444
 445 static void
 446 update_fwd_large( bdescr *bd )
 447 {
 448   StgPtr p;
 449   const StgInfoTable* info;
 450
 451   for (; bd != NULL; bd = bd->link) {
 452
 453     p = bd->start;
 454     info  = get_itbl((StgClosure *)p);
 455
 456     switch (info->type) {
 457
 458     case ARR_WORDS:
 459       // nothing to follow
 460       continue;
 461
 462     case MUT_ARR_PTRS:
 463     case MUT_ARR_PTRS_FROZEN:
 464       // follow everything
 465       {
 466         StgPtr next;
 467
 468         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 469         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 470             thread(p);
 471         }
 472         continue;
 473       }
 474
 475     case TSO:
 476         thread_TSO((StgTSO *)p);
 477         continue;
 478
 479     case AP_STACK:
 480         thread_AP_STACK((StgAP_STACK *)p);
 481         continue;
 482
 483     case PAP:
 484         thread_PAP((StgPAP *)p);
 485         continue;
 486
 487     default:
 488       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 489     }
 490   }
 491 }
 492
 493 STATIC_INLINE StgPtr
 494 thread_obj (StgInfoTable *info, StgPtr p)
 495 {
 496     switch (info->type) {
 497     case FUN_0_1:
 498     case CONSTR_0_1:
 499         return p + sizeofW(StgHeader) + 1;
 500
 501     case FUN_1_0:
 502     case CONSTR_1_0:
 503         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 504         return p + sizeofW(StgHeader) + 1;
 505
 506     case THUNK_1_0:
 507         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 508         return p + sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 509
 510     case THUNK_0_1: // MIN_UPD_SIZE
 511     case THUNK_0_2:
 512     case FUN_0_2:
 513     case CONSTR_0_2:
 514         return p + sizeofW(StgHeader) + 2;
 515
 516     case THUNK_1_1:
 517     case FUN_1_1:
 518     case CONSTR_1_1:
 519         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 520         return p + sizeofW(StgHeader) + 2;
 521
 522     case THUNK_2_0:
 523     case FUN_2_0:
 524     case CONSTR_2_0:
 525         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 526         thread((StgPtr)&((StgClosure *)p)->payload[1]);
 527         return p + sizeofW(StgHeader) + 2;
 528
 529     case BCO: {
 530         StgBCO *bco = (StgBCO *)p;
 531         thread((StgPtr)&bco->instrs);
 532         thread((StgPtr)&bco->literals);
 533         thread((StgPtr)&bco->ptrs);
 534         thread((StgPtr)&bco->itbls);
 535         return p + bco_sizeW(bco);
 536     }
 537
 538     case FUN:
 539     case THUNK:
 540     case CONSTR:
 541     case FOREIGN:
 542     case STABLE_NAME:
 543     case IND_PERM:
 544     case MUT_VAR:
 545     case MUT_CONS:
 546     case CAF_BLACKHOLE:
 547     case SE_CAF_BLACKHOLE:
 548     case SE_BLACKHOLE:
 549     case BLACKHOLE:
 550     case BLACKHOLE_BQ:
 551     {
 552         StgPtr end;
 553
 554         end = (P_)((StgClosure *)p)->payload +
 555             info->layout.payload.ptrs;
 556         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 557             thread(p);
 558         }
 559         return p + info->layout.payload.nptrs;
 560     }
 561
 562     case WEAK:
 563     {
 564         StgWeak *w = (StgWeak *)p;
 565         thread((StgPtr)&w->key);
 566         thread((StgPtr)&w->value);
 567         thread((StgPtr)&w->finalizer);
 568         if (w->link != NULL) {
 569             thread((StgPtr)&w->link);
 570         }
 571         return p + sizeofW(StgWeak);
 572     }
 573
 574     case MVAR:
 575     {
 576         StgMVar *mvar = (StgMVar *)p;
 577         thread((StgPtr)&mvar->head);
 578         thread((StgPtr)&mvar->tail);
 579         thread((StgPtr)&mvar->value);
 580         return p + sizeofW(StgMVar);
 581     }
 582
 583     case IND_OLDGEN:
 584     case IND_OLDGEN_PERM:
 585         thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
 586         return p + sizeofW(StgIndOldGen);
 587
 588     case THUNK_SELECTOR:
 589     {
 590         StgSelector *s = (StgSelector *)p;
 591         thread((StgPtr)&s->selectee);
 592         return p + THUNK_SELECTOR_sizeW();
 593     }
 594
 595     case AP_STACK:
 596         return thread_AP_STACK((StgAP_STACK *)p);
 597
 598     case PAP:
 599     case AP:
 600         return thread_PAP((StgPAP *)p);
 601
 602     case ARR_WORDS:
 603         return p + arr_words_sizeW((StgArrWords *)p);
 604
 605     case MUT_ARR_PTRS:
 606     case MUT_ARR_PTRS_FROZEN:
 607         // follow everything
 608     {
 609         StgPtr next;
 610
 611         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 612         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 613             thread(p);
 614         }
 615         return p;
 616     }
 617
 618     case TSO:
 619         return thread_TSO((StgTSO *)p);
 620
 621     case TVAR_WAIT_QUEUE:
 622     {
 623         StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
 624         thread((StgPtr)&wq->waiting_tso);
 625         thread((StgPtr)&wq->next_queue_entry);
 626         thread((StgPtr)&wq->prev_queue_entry);
 627         return p + sizeofW(StgTVarWaitQueue);
 628     }
 629
 630     case TVAR:
 631     {
 632         StgTVar *tvar = (StgTVar *)p;
 633         thread((StgPtr)&tvar->current_value);
 634         thread((StgPtr)&tvar->first_wait_queue_entry);
 635         return p + sizeofW(StgTVar);
 636     }
 637
 638     case TREC_HEADER:
 639     {
 640         StgTRecHeader *trec = (StgTRecHeader *)p;
 641         thread((StgPtr)&trec->enclosing_trec);
 642         thread((StgPtr)&trec->current_chunk);
 643         return p + sizeofW(StgTRecHeader);
 644     }
 645
 646     case TREC_CHUNK:
 647     {
 648         StgWord i;
 649         StgTRecChunk *tc = (StgTRecChunk *)p;
 650         TRecEntry *e = &(tc -> entries[0]);
 651         thread((StgPtr)&tc->prev_chunk);
 652         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 653           thread((StgPtr)&e->tvar);
 654           thread((StgPtr)&e->expected_value);
 655           thread((StgPtr)&e->new_value);
 656         }
 657         return p + sizeofW(StgTRecChunk);
 658     }
 659
 660     default:
 661         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 662         return NULL;
 663     }
 664 }
 665
 666 static void
 667 update_fwd( bdescr *blocks )
 668 {
 669     StgPtr p;
 670     bdescr *bd;
 671     StgInfoTable *info;
 672
 673     bd = blocks;
 674
 675 #if defined(PAR)
 676     barf("update_fwd: ToDo");
 677 #endif
 678
 679     // cycle through all the blocks in the step
 680     for (; bd != NULL; bd = bd->link) {
 681         p = bd->start;
 682
 683         // linearly scan the objects in this block
 684         while (p < bd->free) {
 685             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 686             info = get_itbl((StgClosure *)p);
 687             p = thread_obj(info, p);
 688         }
 689     }
 690 }
 691
 692 static void
 693 update_fwd_compact( bdescr *blocks )
 694 {
 695     StgPtr p, q, free;
 696 #if 0
 697     StgWord m;
 698 #endif
 699     bdescr *bd, *free_bd;
 700     StgInfoTable *info;
 701     nat size;
 702
 703     bd = blocks;
 704     free_bd = blocks;
 705     free = free_bd->start;
 706
 707 #if defined(PAR)
 708     barf("update_fwd: ToDo");
 709 #endif
 710
 711     // cycle through all the blocks in the step
 712     for (; bd != NULL; bd = bd->link) {
 713         p = bd->start;
 714
 715         while (p < bd->free ) {
 716
 717             while ( p < bd->free && !is_marked(p,bd) ) {
 718                 p++;
 719             }
 720             if (p >= bd->free) {
 721                 break;
 722             }
 723
 724 #if 0
 725     next:
 726         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 727         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 728
 729         while ( p < bd->free ) {
 730
 731             if ((m & 1) == 0) {
 732                 m >>= 1;
 733                 p++;
 734                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 735                     goto next;
 736                 } else {
 737                     continue;
 738                 }
 739             }
 740 #endif
 741
 742             // Problem: we need to know the destination for this cell
 743             // in order to unthread its info pointer.  But we can't
 744             // know the destination without the size, because we may
 745             // spill into the next block.  So we have to run down the
 746             // threaded list and get the info ptr first.
 747             info = get_threaded_info(p);
 748
 749             q = p;
 750
 751             p = thread_obj(info, p);
 752
 753             size = p - q;
 754             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 755                 // unset the next bit in the bitmap to indicate that
 756                 // this object needs to be pushed into the next
 757                 // block.  This saves us having to run down the
 758                 // threaded info pointer list twice during the next pass.
 759                 unmark(q+1,bd);
 760                 free_bd = free_bd->link;
 761                 free = free_bd->start;
 762             } else {
 763                 ASSERT(is_marked(q+1,bd));
 764             }
 765
 766             unthread(q,free);
 767             free += size;
 768 #if 0
 769             goto next;
 770 #endif
 771         }
 772     }
 773 }
 774
 775 static nat
 776 update_bkwd_compact( step *stp )
 777 {
 778     StgPtr p, free;
 779 #if 0
 780     StgWord m;
 781 #endif
 782     bdescr *bd, *free_bd;
 783     StgInfoTable *info;
 784     nat size, free_blocks;
 785
 786     bd = free_bd = stp->blocks;
 787     free = free_bd->start;
 788     free_blocks = 1;
 789
 790 #if defined(PAR)
 791     barf("update_bkwd: ToDo");
 792 #endif
 793
 794     // cycle through all the blocks in the step
 795     for (; bd != NULL; bd = bd->link) {
 796         p = bd->start;
 797
 798         while (p < bd->free ) {
 799
 800             while ( p < bd->free && !is_marked(p,bd) ) {
 801                 p++;
 802             }
 803             if (p >= bd->free) {
 804                 break;
 805             }
 806
 807 #if 0
 808     next:
 809         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 810         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 811
 812         while ( p < bd->free ) {
 813
 814             if ((m & 1) == 0) {
 815                 m >>= 1;
 816                 p++;
 817                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 818                     goto next;
 819                 } else {
 820                     continue;
 821                 }
 822             }
 823 #endif
 824
 825             if (!is_marked(p+1,bd)) {
 826                 // don't forget to update the free ptr in the block desc.
 827                 free_bd->free = free;
 828                 free_bd = free_bd->link;
 829                 free = free_bd->start;
 830                 free_blocks++;
 831             }
 832
 833             unthread(p,free);
 834             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 835             info = get_itbl((StgClosure *)p);
 836             size = obj_sizeW((StgClosure *)p,info);
 837
 838             if (free != p) {
 839                 move(free,p,size);
 840             }
 841
 842             // Rebuild the mutable list for the old generation.
 843             if (ip_MUTABLE(info)) {
 844                 recordMutable((StgMutClosure *)free);
 845             }
 846
 847             // relocate TSOs
 848             if (info->type == TSO) {
 849                 move_TSO((StgTSO *)p, (StgTSO *)free);
 850             }
 851
 852             free += size;
 853             p += size;
 854 #if 0
 855             goto next;
 856 #endif
 857         }
 858     }
 859
 860     // free the remaining blocks and count what's left.
 861     free_bd->free = free;
 862     if (free_bd->link != NULL) {
 863         freeChain(free_bd->link);
 864         free_bd->link = NULL;
 865     }
 866     stp->n_blocks = free_blocks;
 867
 868     return free_blocks;
 869 }
 870
 871 static void
 872 thread_mut_once_list( generation *g )
 873 {
 874     StgMutClosure *p, *next;
 875
 876     for (p = g->mut_once_list; p != END_MUT_LIST; p = next) {
 877         next = p->mut_link;
 878         thread((StgPtr)&p->mut_link);
 879     }
 880
 881     thread((StgPtr)&g->mut_once_list);
 882 }
 883
 884 void
 885 compact( void (*get_roots)(evac_fn) )
 886 {
 887     nat g, s, blocks;
 888     step *stp;
 889
 890     // 1. thread the roots
 891     get_roots((evac_fn)thread);
 892
 893     // the weak pointer lists...
 894     if (weak_ptr_list != NULL) {
 895         thread((StgPtr)&weak_ptr_list);
 896     }
 897     if (old_weak_ptr_list != NULL) {
 898         thread((StgPtr)&old_weak_ptr_list); // tmp
 899     }
 900
 901     // mutable lists
 902     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 903         thread((StgPtr)&generations[g].mut_list);
 904         thread_mut_once_list(&generations[g]);
 905     }
 906
 907     // the global thread list
 908     thread((StgPtr)&all_threads);
 909
 910     // any threads resurrected during this GC
 911     thread((StgPtr)&resurrected_threads);
 912
 913     // the main threads list
 914     {
 915         StgMainThread *m;
 916         for (m = main_threads; m != NULL; m = m->link) {
 917             thread((StgPtr)&m->tso);
 918         }
 919     }
 920
 921     // the static objects
 922     thread_static(scavenged_static_objects);
 923
 924     // the stable pointer table
 925     threadStablePtrTable((evac_fn)thread);
 926
 927     // the CAF list (used by GHCi)
 928     markCAFs((evac_fn)thread);
 929
 930     // 2. update forward ptrs
 931     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 932         for (s = 0; s < generations[g].n_steps; s++) {
 933             stp = &generations[g].steps[s];
 934             IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 935
 936             update_fwd(stp->to_blocks);
 937             update_fwd_large(stp->scavenged_large_objects);
 938             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 939                 IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 940                 update_fwd_compact(stp->blocks);
 941             }
 942         }
 943     }
 944
 945     // 3. update backward ptrs
 946     stp = &oldest_gen->steps[0];
 947     if (stp->blocks != NULL) {
 948         blocks = update_bkwd_compact(stp);
 949         IF_DEBUG(gc, debugBelch("update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 950                              stp->gen->no, stp->no,
 951                              stp->n_blocks, blocks););
 952         stp->n_blocks = blocks;
 953     }
 954 }