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