rts/sm/Compact.c

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