ghc/rts/GCCompact.c

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