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 BLACKHOLE:
 625     {
 626         StgPtr end;
 627
 628         end = (P_)((StgClosure *)p)->payload +
 629             info->layout.payload.ptrs;
 630         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 631             thread((StgClosure **)p);
 632         }
 633         return p + info->layout.payload.nptrs;
 634     }
 635
 636     case WEAK:
 637     {
 638         StgWeak *w = (StgWeak *)p;
 639         thread(&w->key);
 640         thread(&w->value);
 641         thread(&w->finalizer);
 642         if (w->link != NULL) {
 643             thread_(&w->link);
 644         }
 645         return p + sizeofW(StgWeak);
 646     }
 647
 648     case MVAR_CLEAN:
 649     case MVAR_DIRTY:
 650     {
 651         StgMVar *mvar = (StgMVar *)p;
 652         thread_(&mvar->head);
 653         thread_(&mvar->tail);
 654         thread(&mvar->value);
 655         return p + sizeofW(StgMVar);
 656     }
 657
 658     case IND_OLDGEN:
 659     case IND_OLDGEN_PERM:
 660         thread(&((StgInd *)p)->indirectee);
 661         return p + sizeofW(StgInd);
 662
 663     case THUNK_SELECTOR:
 664     {
 665         StgSelector *s = (StgSelector *)p;
 666         thread(&s->selectee);
 667         return p + THUNK_SELECTOR_sizeW();
 668     }
 669
 670     case AP_STACK:
 671         return thread_AP_STACK((StgAP_STACK *)p);
 672
 673     case PAP:
 674         return thread_PAP((StgPAP *)p);
 675
 676     case AP:
 677         return thread_AP((StgAP *)p);
 678
 679     case ARR_WORDS:
 680         return p + arr_words_sizeW((StgArrWords *)p);
 681
 682     case MUT_ARR_PTRS_CLEAN:
 683     case MUT_ARR_PTRS_DIRTY:
 684     case MUT_ARR_PTRS_FROZEN:
 685     case MUT_ARR_PTRS_FROZEN0:
 686         // follow everything
 687     {
 688         StgPtr next;
 689
 690         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 691         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 692             thread((StgClosure **)p);
 693         }
 694         return p;
 695     }
 696
 697     case TSO:
 698         return thread_TSO((StgTSO *)p);
 699
 700     case TVAR_WATCH_QUEUE:
 701     {
 702         StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
 703         thread_(&wq->closure);
 704         thread_(&wq->next_queue_entry);
 705         thread_(&wq->prev_queue_entry);
 706         return p + sizeofW(StgTVarWatchQueue);
 707     }
 708
 709     case TVAR:
 710     {
 711         StgTVar *tvar = (StgTVar *)p;
 712         thread((void *)&tvar->current_value);
 713         thread((void *)&tvar->first_watch_queue_entry);
 714         return p + sizeofW(StgTVar);
 715     }
 716
 717     case TREC_HEADER:
 718     {
 719         StgTRecHeader *trec = (StgTRecHeader *)p;
 720         thread_(&trec->enclosing_trec);
 721         thread_(&trec->current_chunk);
 722         thread_(&trec->invariants_to_check);
 723         return p + sizeofW(StgTRecHeader);
 724     }
 725
 726     case TREC_CHUNK:
 727     {
 728         StgWord i;
 729         StgTRecChunk *tc = (StgTRecChunk *)p;
 730         TRecEntry *e = &(tc -> entries[0]);
 731         thread_(&tc->prev_chunk);
 732         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 733           thread_(&e->tvar);
 734           thread(&e->expected_value);
 735           thread(&e->new_value);
 736         }
 737         return p + sizeofW(StgTRecChunk);
 738     }
 739
 740     case ATOMIC_INVARIANT:
 741     {
 742         StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
 743         thread_(&invariant->code);
 744         thread_(&invariant->last_execution);
 745         return p + sizeofW(StgAtomicInvariant);
 746     }
 747
 748     case INVARIANT_CHECK_QUEUE:
 749     {
 750         StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p;
 751         thread_(&queue->invariant);
 752         thread_(&queue->my_execution);
 753         thread_(&queue->next_queue_entry);
 754         return p + sizeofW(StgInvariantCheckQueue);
 755     }
 756
 757     default:
 758         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 759         return NULL;
 760     }
 761 }
 762
 763 static void
 764 update_fwd( bdescr *blocks )
 765 {
 766     StgPtr p;
 767     bdescr *bd;
 768     StgInfoTable *info;
 769
 770     bd = blocks;
 771
 772     // cycle through all the blocks in the step
 773     for (; bd != NULL; bd = bd->link) {
 774         p = bd->start;
 775
 776         // linearly scan the objects in this block
 777         while (p < bd->free) {
 778             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 779             info = get_itbl((StgClosure *)p);
 780             p = thread_obj(info, p);
 781         }
 782     }
 783 }
 784
 785 static void
 786 update_fwd_compact( bdescr *blocks )
 787 {
 788     StgPtr p, q, free;
 789 #if 0
 790     StgWord m;
 791 #endif
 792     bdescr *bd, *free_bd;
 793     StgInfoTable *info;
 794     nat size;
 795     StgWord iptr;
 796
 797     bd = blocks;
 798     free_bd = blocks;
 799     free = free_bd->start;
 800
 801     // cycle through all the blocks in the step
 802     for (; bd != NULL; bd = bd->link) {
 803         p = bd->start;
 804
 805         while (p < bd->free ) {
 806
 807             while ( p < bd->free && !is_marked(p,bd) ) {
 808                 p++;
 809             }
 810             if (p >= bd->free) {
 811                 break;
 812             }
 813
 814 #if 0
 815     next:
 816         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 817         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 818
 819         while ( p < bd->free ) {
 820
 821             if ((m & 1) == 0) {
 822                 m >>= 1;
 823                 p++;
 824                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 825                     goto next;
 826                 } else {
 827                     continue;
 828                 }
 829             }
 830 #endif
 831
 832             // Problem: we need to know the destination for this cell
 833             // in order to unthread its info pointer.  But we can't
 834             // know the destination without the size, because we may
 835             // spill into the next block.  So we have to run down the
 836             // threaded list and get the info ptr first.
 837             //
 838             // ToDo: one possible avenue of attack is to use the fact
 839             // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
 840             // definitely have enough room.  Also see bug #1147.
 841             iptr = get_threaded_info(p);
 842             info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
 843
 844             q = p;
 845
 846             p = thread_obj(info, p);
 847
 848             size = p - q;
 849             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 850                 // unset the next bit in the bitmap to indicate that
 851                 // this object needs to be pushed into the next
 852                 // block.  This saves us having to run down the
 853                 // threaded info pointer list twice during the next pass.
 854                 unmark(q+1,bd);
 855                 free_bd = free_bd->link;
 856                 free = free_bd->start;
 857             } else {
 858                 ASSERT(is_marked(q+1,bd));
 859             }
 860
 861             unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
 862             free += size;
 863 #if 0
 864             goto next;
 865 #endif
 866         }
 867     }
 868 }
 869
 870 static nat
 871 update_bkwd_compact( step *stp )
 872 {
 873     StgPtr p, free;
 874 #if 0
 875     StgWord m;
 876 #endif
 877     bdescr *bd, *free_bd;
 878     StgInfoTable *info;
 879     nat size, free_blocks;
 880     StgWord iptr;
 881
 882     bd = free_bd = stp->old_blocks;
 883     free = free_bd->start;
 884     free_blocks = 1;
 885
 886     // cycle through all the blocks in the step
 887     for (; bd != NULL; bd = bd->link) {
 888         p = bd->start;
 889
 890         while (p < bd->free ) {
 891
 892             while ( p < bd->free && !is_marked(p,bd) ) {
 893                 p++;
 894             }
 895             if (p >= bd->free) {
 896                 break;
 897             }
 898
 899 #if 0
 900     next:
 901         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 902         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 903
 904         while ( p < bd->free ) {
 905
 906             if ((m & 1) == 0) {
 907                 m >>= 1;
 908                 p++;
 909                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 910                     goto next;
 911                 } else {
 912                     continue;
 913                 }
 914             }
 915 #endif
 916
 917             if (!is_marked(p+1,bd)) {
 918                 // don't forget to update the free ptr in the block desc.
 919                 free_bd->free = free;
 920                 free_bd = free_bd->link;
 921                 free = free_bd->start;
 922                 free_blocks++;
 923             }
 924
 925             iptr = get_threaded_info(p);
 926             unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
 927             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 928             info = get_itbl((StgClosure *)p);
 929             size = closure_sizeW_((StgClosure *)p,info);
 930
 931             if (free != p) {
 932                 move(free,p,size);
 933             }
 934
 935             // relocate TSOs
 936             if (info->type == TSO) {
 937                 move_TSO((StgTSO *)p, (StgTSO *)free);
 938             }
 939
 940             free += size;
 941             p += size;
 942 #if 0
 943             goto next;
 944 #endif
 945         }
 946     }
 947
 948     // free the remaining blocks and count what's left.
 949     free_bd->free = free;
 950     if (free_bd->link != NULL) {
 951         freeChain(free_bd->link);
 952         free_bd->link = NULL;
 953     }
 954
 955     return free_blocks;
 956 }
 957
 958 void
 959 compact(StgClosure *static_objects)
 960 {
 961     nat g, s, blocks;
 962     step *stp;
 963
 964     // 1. thread the roots
 965     markCapabilities((evac_fn)thread_root, NULL);
 966
 967     // the weak pointer lists...
 968     if (weak_ptr_list != NULL) {
 969         thread((void *)&weak_ptr_list);
 970     }
 971     if (old_weak_ptr_list != NULL) {
 972         thread((void *)&old_weak_ptr_list); // tmp
 973     }
 974
 975     // mutable lists
 976     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 977         bdescr *bd;
 978         StgPtr p;
 979         nat n;
 980         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 981             for (p = bd->start; p < bd->free; p++) {
 982                 thread((StgClosure **)p);
 983             }
 984         }
 985         for (n = 0; n < n_capabilities; n++) {
 986             for (bd = capabilities[n].mut_lists[g];
 987                  bd != NULL; bd = bd->link) {
 988                 for (p = bd->start; p < bd->free; p++) {
 989                     thread((StgClosure **)p);
 990                 }
 991             }
 992         }
 993     }
 994
 995     // the global thread list
 996     for (s = 0; s < total_steps; s++) {
 997         thread((void *)&all_steps[s].threads);
 998     }
 999
1000     // any threads resurrected during this GC
1001     thread((void *)&resurrected_threads);
1002
1003     // the blackhole queue
1004     thread((void *)&blackhole_queue);
1005
1006     // the task list
1007     {
1008         Task *task;
1009         for (task = all_tasks; task != NULL; task = task->all_link) {
1010             if (task->tso) {
1011                 thread_(&task->tso);
1012             }
1013         }
1014     }
1015
1016     // the static objects
1017     thread_static(static_objects /* ToDo: ok? */);
1018
1019     // the stable pointer table
1020     threadStablePtrTable((evac_fn)thread_root, NULL);
1021
1022     // the CAF list (used by GHCi)
1023     markCAFs((evac_fn)thread_root, NULL);
1024
1025     // 2. update forward ptrs
1026     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1027         for (s = 0; s < generations[g].n_steps; s++) {
1028             if (g==0 && s ==0) continue;
1029             stp = &generations[g].steps[s];
1030             debugTrace(DEBUG_gc, "update_fwd:  %d.%d",
1031                        stp->gen->no, stp->no);
1032
1033             update_fwd(stp->blocks);
1034             update_fwd_large(stp->scavenged_large_objects);
1035             if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
1036                 debugTrace(DEBUG_gc, "update_fwd:  %d.%d (compact)",
1037                            stp->gen->no, stp->no);
1038                 update_fwd_compact(stp->old_blocks);
1039             }
1040         }
1041     }
1042
1043     // 3. update backward ptrs
1044     stp = &oldest_gen->steps[0];
1045     if (stp->old_blocks != NULL) {
1046         blocks = update_bkwd_compact(stp);
1047         debugTrace(DEBUG_gc,
1048                    "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
1049                    stp->gen->no, stp->no,
1050                    stp->n_old_blocks, blocks);
1051         stp->n_old_blocks = blocks;
1052     }
1053 }