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