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 (StgClosure **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
  67             *(StgPtr)p = (StgWord)*q;
  68             *q = (StgWord)p + 1;        // set the low bit
  69         }
  70     }
  71 }
  72
  73 // This version of thread() takes a (void *), used to circumvent
  74 // warnings from gcc about pointer punning and strict aliasing.
  75 STATIC_INLINE void thread_ (void *p) { thread((StgClosure **)p); }
  76
  77 STATIC_INLINE void
  78 unthread( StgPtr p, StgPtr free )
  79 {
  80     StgWord q = *p, r;
  81
  82     while ((q & 1) != 0) {
  83         q -= 1; // unset the low bit again
  84         r = *((StgPtr)q);
  85         *((StgPtr)q) = (StgWord)free;
  86         q = r;
  87     }
  88     *p = q;
  89 }
  90
  91 STATIC_INLINE StgInfoTable *
  92 get_threaded_info( StgPtr p )
  93 {
  94     StgPtr q = (P_)GET_INFO((StgClosure *)p);
  95
  96     while (((StgWord)q & 1) != 0) {
  97         q = (P_)*((StgPtr)((StgWord)q-1));
  98     }
  99
 100     ASSERT(LOOKS_LIKE_INFO_PTR(q));
 101     return INFO_PTR_TO_STRUCT((StgInfoTable *)q);
 102 }
 103
 104 // A word-aligned memmove will be faster for small objects than libc's or gcc's.
 105 // Remember, the two regions *might* overlap, but: to <= from.
 106 STATIC_INLINE void
 107 move(StgPtr to, StgPtr from, nat size)
 108 {
 109     for(; size > 0; --size) {
 110         *to++ = *from++;
 111     }
 112 }
 113
 114 static void
 115 thread_static( StgClosure* p )
 116 {
 117   const StgInfoTable *info;
 118
 119   // keep going until we've threaded all the objects on the linked
 120   // list...
 121   while (p != END_OF_STATIC_LIST) {
 122
 123     info = get_itbl(p);
 124     switch (info->type) {
 125
 126     case IND_STATIC:
 127         thread(&((StgInd *)p)->indirectee);
 128         p = *IND_STATIC_LINK(p);
 129         continue;
 130
 131     case THUNK_STATIC:
 132         p = *THUNK_STATIC_LINK(p);
 133         continue;
 134     case FUN_STATIC:
 135         p = *FUN_STATIC_LINK(p);
 136         continue;
 137     case CONSTR_STATIC:
 138         p = *STATIC_LINK(info,p);
 139         continue;
 140
 141     default:
 142         barf("thread_static: strange closure %d", (int)(info->type));
 143     }
 144
 145   }
 146 }
 147
 148 STATIC_INLINE void
 149 thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
 150 {
 151     nat i, b;
 152     StgWord bitmap;
 153
 154     b = 0;
 155     bitmap = large_bitmap->bitmap[b];
 156     for (i = 0; i < size; ) {
 157         if ((bitmap & 1) == 0) {
 158             thread((StgClosure **)p);
 159         }
 160         i++;
 161         p++;
 162         if (i % BITS_IN(W_) == 0) {
 163             b++;
 164             bitmap = large_bitmap->bitmap[b];
 165         } else {
 166             bitmap = bitmap >> 1;
 167         }
 168     }
 169 }
 170
 171 STATIC_INLINE StgPtr
 172 thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
 173 {
 174     StgPtr p;
 175     StgWord bitmap;
 176     nat size;
 177
 178     p = (StgPtr)args;
 179     switch (fun_info->f.fun_type) {
 180     case ARG_GEN:
 181         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
 182         size = BITMAP_SIZE(fun_info->f.b.bitmap);
 183         goto small_bitmap;
 184     case ARG_GEN_BIG:
 185         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
 186         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 187         p += size;
 188         break;
 189     default:
 190         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 191         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 192     small_bitmap:
 193         while (size > 0) {
 194             if ((bitmap & 1) == 0) {
 195                 thread((StgClosure **)p);
 196             }
 197             p++;
 198             bitmap = bitmap >> 1;
 199             size--;
 200         }
 201         break;
 202     }
 203     return p;
 204 }
 205
 206 static void
 207 thread_stack(StgPtr p, StgPtr stack_end)
 208 {
 209     const StgRetInfoTable* info;
 210     StgWord bitmap;
 211     nat size;
 212
 213     // highly similar to scavenge_stack, but we do pointer threading here.
 214
 215     while (p < stack_end) {
 216
 217         // *p must be the info pointer of an activation
 218         // record.  All activation records have 'bitmap' style layout
 219         // info.
 220         //
 221         info  = get_ret_itbl((StgClosure *)p);
 222
 223         switch (info->i.type) {
 224
 225             // Dynamic bitmap: the mask is stored on the stack
 226         case RET_DYN:
 227         {
 228             StgWord dyn;
 229             dyn = ((StgRetDyn *)p)->liveness;
 230
 231             // traverse the bitmap first
 232             bitmap = RET_DYN_LIVENESS(dyn);
 233             p      = (P_)&((StgRetDyn *)p)->payload[0];
 234             size   = RET_DYN_BITMAP_SIZE;
 235             while (size > 0) {
 236                 if ((bitmap & 1) == 0) {
 237                     thread((StgClosure **)p);
 238                 }
 239                 p++;
 240                 bitmap = bitmap >> 1;
 241                 size--;
 242             }
 243
 244             // skip over the non-ptr words
 245             p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
 246
 247             // follow the ptr words
 248             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 249                 thread((StgClosure **)p);
 250                 p++;
 251             }
 252             continue;
 253         }
 254
 255             // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
 256         case CATCH_RETRY_FRAME:
 257         case CATCH_STM_FRAME:
 258         case ATOMICALLY_FRAME:
 259         case UPDATE_FRAME:
 260         case STOP_FRAME:
 261         case CATCH_FRAME:
 262         case RET_SMALL:
 263         case RET_VEC_SMALL:
 264             bitmap = BITMAP_BITS(info->i.layout.bitmap);
 265             size   = BITMAP_SIZE(info->i.layout.bitmap);
 266             p++;
 267             // NOTE: the payload starts immediately after the info-ptr, we
 268             // don't have an StgHeader in the same sense as a heap closure.
 269             while (size > 0) {
 270                 if ((bitmap & 1) == 0) {
 271                     thread((StgClosure **)p);
 272                 }
 273                 p++;
 274                 bitmap = bitmap >> 1;
 275                 size--;
 276             }
 277             continue;
 278
 279         case RET_BCO: {
 280             StgBCO *bco;
 281             nat size;
 282
 283             p++;
 284             bco = (StgBCO *)*p;
 285             thread((StgClosure **)p);
 286             p++;
 287             size = BCO_BITMAP_SIZE(bco);
 288             thread_large_bitmap(p, BCO_BITMAP(bco), size);
 289             p += size;
 290             continue;
 291         }
 292
 293             // large bitmap (> 32 entries, or 64 on a 64-bit machine)
 294         case RET_BIG:
 295         case RET_VEC_BIG:
 296             p++;
 297             size = GET_LARGE_BITMAP(&info->i)->size;
 298             thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
 299             p += size;
 300             continue;
 301
 302         case RET_FUN:
 303         {
 304             StgRetFun *ret_fun = (StgRetFun *)p;
 305             StgFunInfoTable *fun_info;
 306
 307             fun_info = itbl_to_fun_itbl(
 308                 get_threaded_info((StgPtr)ret_fun->fun));
 309                  // *before* threading it!
 310             thread(&ret_fun->fun);
 311             p = thread_arg_block(fun_info, ret_fun->payload);
 312             continue;
 313         }
 314
 315         default:
 316             barf("thread_stack: weird activation record found on stack: %d",
 317                  (int)(info->i.type));
 318         }
 319     }
 320 }
 321
 322 STATIC_INLINE StgPtr
 323 thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
 324 {
 325     StgPtr p;
 326     StgWord bitmap;
 327     StgFunInfoTable *fun_info;
 328
 329     fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)fun));
 330     ASSERT(fun_info->i.type != PAP);
 331
 332     p = (StgPtr)payload;
 333
 334     switch (fun_info->f.fun_type) {
 335     case ARG_GEN:
 336         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
 337         goto small_bitmap;
 338     case ARG_GEN_BIG:
 339         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 340         p += size;
 341         break;
 342     case ARG_BCO:
 343         thread_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
 344         p += size;
 345         break;
 346     default:
 347         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 348     small_bitmap:
 349         while (size > 0) {
 350             if ((bitmap & 1) == 0) {
 351                 thread((StgClosure **)p);
 352             }
 353             p++;
 354             bitmap = bitmap >> 1;
 355             size--;
 356         }
 357         break;
 358     }
 359
 360     return p;
 361 }
 362
 363 STATIC_INLINE StgPtr
 364 thread_PAP (StgPAP *pap)
 365 {
 366     StgPtr p;
 367     p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
 368     thread(&pap->fun);
 369     return p;
 370 }
 371
 372 STATIC_INLINE StgPtr
 373 thread_AP (StgAP *ap)
 374 {
 375     StgPtr p;
 376     p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
 377     thread(&ap->fun);
 378     return p;
 379 }
 380
 381 STATIC_INLINE StgPtr
 382 thread_AP_STACK (StgAP_STACK *ap)
 383 {
 384     thread(&ap->fun);
 385     thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
 386     return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
 387 }
 388
 389 static StgPtr
 390 thread_TSO (StgTSO *tso)
 391 {
 392     thread_(&tso->link);
 393     thread_(&tso->global_link);
 394
 395     if (   tso->why_blocked == BlockedOnMVar
 396         || tso->why_blocked == BlockedOnBlackHole
 397         || tso->why_blocked == BlockedOnException
 398 #if defined(PAR)
 399         || tso->why_blocked == BlockedOnGA
 400         || tso->why_blocked == BlockedOnGA_NoSend
 401 #endif
 402         ) {
 403         thread_(&tso->block_info.closure);
 404     }
 405     if ( tso->blocked_exceptions != NULL ) {
 406         thread_(&tso->blocked_exceptions);
 407     }
 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 STATIC_INLINE StgPtr
 481 thread_obj (StgInfoTable *info, StgPtr p)
 482 {
 483     switch (info->type) {
 484     case THUNK_0_1:
 485         return p + sizeofW(StgThunk) + 1;
 486
 487     case FUN_0_1:
 488     case CONSTR_0_1:
 489         return p + sizeofW(StgHeader) + 1;
 490
 491     case FUN_1_0:
 492     case CONSTR_1_0:
 493         thread(&((StgClosure *)p)->payload[0]);
 494         return p + sizeofW(StgHeader) + 1;
 495
 496     case THUNK_1_0:
 497         thread(&((StgThunk *)p)->payload[0]);
 498         return p + sizeofW(StgThunk) + 1;
 499
 500     case THUNK_0_2:
 501         return p + sizeofW(StgThunk) + 2;
 502
 503     case FUN_0_2:
 504     case CONSTR_0_2:
 505         return p + sizeofW(StgHeader) + 2;
 506
 507     case THUNK_1_1:
 508         thread(&((StgThunk *)p)->payload[0]);
 509         return p + sizeofW(StgThunk) + 2;
 510
 511     case FUN_1_1:
 512     case CONSTR_1_1:
 513         thread(&((StgClosure *)p)->payload[0]);
 514         return p + sizeofW(StgHeader) + 2;
 515
 516     case THUNK_2_0:
 517         thread(&((StgThunk *)p)->payload[0]);
 518         thread(&((StgThunk *)p)->payload[1]);
 519         return p + sizeofW(StgThunk) + 2;
 520
 521     case FUN_2_0:
 522     case CONSTR_2_0:
 523         thread(&((StgClosure *)p)->payload[0]);
 524         thread(&((StgClosure *)p)->payload[1]);
 525         return p + sizeofW(StgHeader) + 2;
 526
 527     case BCO: {
 528         StgBCO *bco = (StgBCO *)p;
 529         thread_(&bco->instrs);
 530         thread_(&bco->literals);
 531         thread_(&bco->ptrs);
 532         thread_(&bco->itbls);
 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_WAIT_QUEUE:
 633     {
 634         StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
 635         thread_(&wq->waiting_tso);
 636         thread_(&wq->next_queue_entry);
 637         thread_(&wq->prev_queue_entry);
 638         return p + sizeofW(StgTVarWaitQueue);
 639     }
 640
 641     case TVAR:
 642     {
 643         StgTVar *tvar = (StgTVar *)p;
 644         thread((void *)&tvar->current_value);
 645         thread((void *)&tvar->first_wait_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         return p + sizeofW(StgTRecHeader);
 655     }
 656
 657     case TREC_CHUNK:
 658     {
 659         StgWord i;
 660         StgTRecChunk *tc = (StgTRecChunk *)p;
 661         TRecEntry *e = &(tc -> entries[0]);
 662         thread_(&tc->prev_chunk);
 663         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 664           thread_(&e->tvar);
 665           thread(&e->expected_value);
 666           thread(&e->new_value);
 667         }
 668         return p + sizeofW(StgTRecChunk);
 669     }
 670
 671     default:
 672         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 673         return NULL;
 674     }
 675 }
 676
 677 static void
 678 update_fwd( bdescr *blocks )
 679 {
 680     StgPtr p;
 681     bdescr *bd;
 682     StgInfoTable *info;
 683
 684     bd = blocks;
 685
 686 #if defined(PAR)
 687     barf("update_fwd: ToDo");
 688 #endif
 689
 690     // cycle through all the blocks in the step
 691     for (; bd != NULL; bd = bd->link) {
 692         p = bd->start;
 693
 694         // linearly scan the objects in this block
 695         while (p < bd->free) {
 696             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 697             info = get_itbl((StgClosure *)p);
 698             p = thread_obj(info, p);
 699         }
 700     }
 701 }
 702
 703 static void
 704 update_fwd_compact( bdescr *blocks )
 705 {
 706     StgPtr p, q, free;
 707 #if 0
 708     StgWord m;
 709 #endif
 710     bdescr *bd, *free_bd;
 711     StgInfoTable *info;
 712     nat size;
 713
 714     bd = blocks;
 715     free_bd = blocks;
 716     free = free_bd->start;
 717
 718 #if defined(PAR)
 719     barf("update_fwd: ToDo");
 720 #endif
 721
 722     // cycle through all the blocks in the step
 723     for (; bd != NULL; bd = bd->link) {
 724         p = bd->start;
 725
 726         while (p < bd->free ) {
 727
 728             while ( p < bd->free && !is_marked(p,bd) ) {
 729                 p++;
 730             }
 731             if (p >= bd->free) {
 732                 break;
 733             }
 734
 735 #if 0
 736     next:
 737         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 738         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 739
 740         while ( p < bd->free ) {
 741
 742             if ((m & 1) == 0) {
 743                 m >>= 1;
 744                 p++;
 745                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 746                     goto next;
 747                 } else {
 748                     continue;
 749                 }
 750             }
 751 #endif
 752
 753             // Problem: we need to know the destination for this cell
 754             // in order to unthread its info pointer.  But we can't
 755             // know the destination without the size, because we may
 756             // spill into the next block.  So we have to run down the
 757             // threaded list and get the info ptr first.
 758             info = get_threaded_info(p);
 759
 760             q = p;
 761
 762             p = thread_obj(info, p);
 763
 764             size = p - q;
 765             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 766                 // unset the next bit in the bitmap to indicate that
 767                 // this object needs to be pushed into the next
 768                 // block.  This saves us having to run down the
 769                 // threaded info pointer list twice during the next pass.
 770                 unmark(q+1,bd);
 771                 free_bd = free_bd->link;
 772                 free = free_bd->start;
 773             } else {
 774                 ASSERT(is_marked(q+1,bd));
 775             }
 776
 777             unthread(q,free);
 778             free += size;
 779 #if 0
 780             goto next;
 781 #endif
 782         }
 783     }
 784 }
 785
 786 static nat
 787 update_bkwd_compact( step *stp )
 788 {
 789     StgPtr p, free;
 790 #if 0
 791     StgWord m;
 792 #endif
 793     bdescr *bd, *free_bd;
 794     StgInfoTable *info;
 795     nat size, free_blocks;
 796
 797     bd = free_bd = stp->old_blocks;
 798     free = free_bd->start;
 799     free_blocks = 1;
 800
 801 #if defined(PAR)
 802     barf("update_bkwd: ToDo");
 803 #endif
 804
 805     // cycle through all the blocks in the step
 806     for (; bd != NULL; bd = bd->link) {
 807         p = bd->start;
 808
 809         while (p < bd->free ) {
 810
 811             while ( p < bd->free && !is_marked(p,bd) ) {
 812                 p++;
 813             }
 814             if (p >= bd->free) {
 815                 break;
 816             }
 817
 818 #if 0
 819     next:
 820         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 821         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 822
 823         while ( p < bd->free ) {
 824
 825             if ((m & 1) == 0) {
 826                 m >>= 1;
 827                 p++;
 828                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 829                     goto next;
 830                 } else {
 831                     continue;
 832                 }
 833             }
 834 #endif
 835
 836             if (!is_marked(p+1,bd)) {
 837                 // don't forget to update the free ptr in the block desc.
 838                 free_bd->free = free;
 839                 free_bd = free_bd->link;
 840                 free = free_bd->start;
 841                 free_blocks++;
 842             }
 843
 844             unthread(p,free);
 845             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 846             info = get_itbl((StgClosure *)p);
 847             size = closure_sizeW_((StgClosure *)p,info);
 848
 849             if (free != p) {
 850                 move(free,p,size);
 851             }
 852
 853             // relocate TSOs
 854             if (info->type == TSO) {
 855                 move_TSO((StgTSO *)p, (StgTSO *)free);
 856             }
 857
 858             free += size;
 859             p += size;
 860 #if 0
 861             goto next;
 862 #endif
 863         }
 864     }
 865
 866     // free the remaining blocks and count what's left.
 867     free_bd->free = free;
 868     if (free_bd->link != NULL) {
 869         freeChain(free_bd->link);
 870         free_bd->link = NULL;
 871     }
 872
 873     return free_blocks;
 874 }
 875
 876 void
 877 compact( void (*get_roots)(evac_fn) )
 878 {
 879     nat g, s, blocks;
 880     step *stp;
 881
 882     // 1. thread the roots
 883     get_roots((evac_fn)thread);
 884
 885     // the weak pointer lists...
 886     if (weak_ptr_list != NULL) {
 887         thread((void *)&weak_ptr_list);
 888     }
 889     if (old_weak_ptr_list != NULL) {
 890         thread((void *)&old_weak_ptr_list); // tmp
 891     }
 892
 893     // mutable lists
 894     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 895         bdescr *bd;
 896         StgPtr p;
 897         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 898             for (p = bd->start; p < bd->free; p++) {
 899                 thread((StgClosure **)p);
 900             }
 901         }
 902     }
 903
 904     // the global thread list
 905     thread((void *)&all_threads);
 906
 907     // any threads resurrected during this GC
 908     thread((void *)&resurrected_threads);
 909
 910     // the task list
 911     {
 912         Task *task;
 913         for (task = all_tasks; task != NULL; task = task->all_link) {
 914             if (task->tso) {
 915                 thread_(&task->tso);
 916             }
 917         }
 918     }
 919
 920     // the static objects
 921     thread_static(scavenged_static_objects);
 922
 923     // the stable pointer table
 924     threadStablePtrTable((evac_fn)thread);
 925
 926     // the CAF list (used by GHCi)
 927     markCAFs((evac_fn)thread);
 928
 929     // 2. update forward ptrs
 930     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 931         for (s = 0; s < generations[g].n_steps; s++) {
 932             if (g==0 && s ==0) continue;
 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->blocks);
 937             update_fwd_large(stp->scavenged_large_objects);
 938             if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
 939                 IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 940                 update_fwd_compact(stp->old_blocks);
 941             }
 942         }
 943     }
 944
 945     // 3. update backward ptrs
 946     stp = &oldest_gen->steps[0];
 947     if (stp->old_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_old_blocks, blocks););
 952         stp->n_old_blocks = blocks;
 953     }
 954 }