ghc/rts/GCCompact.c

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