rts/sm/Compact.c

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