ghc/rts/GCCompact.c

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