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