rts/sm/Compact.c

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