rts/sm/Compact.c

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