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