rts/sm/Compact.c

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