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