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