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         return p + sizeofW(StgTVar);
 679     }
 680
 681     case TREC_HEADER:
 682     {
 683         StgTRecHeader *trec = (StgTRecHeader *)p;
 684         thread((StgPtr)&trec->enclosing_trec);
 685         thread((StgPtr)&trec->current_chunk);
 686         return p + sizeofW(StgTRecHeader);
 687     }
 688
 689     case TREC_CHUNK:
 690     {
 691         StgWord i;
 692         StgTRecChunk *tc = (StgTRecChunk *)p;
 693         TRecEntry *e = &(tc -> entries[0]);
 694         thread((StgPtr)&tc->prev_chunk);
 695         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 696           thread((StgPtr)&e->tvar);
 697           thread((StgPtr)&e->expected_value);
 698           thread((StgPtr)&e->new_value);
 699         }
 700         return p + sizeofW(StgTRecChunk);
 701     }
 702
 703     default:
 704         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 705         return NULL;
 706     }
 707 }
 708
 709 static void
 710 update_fwd( bdescr *blocks )
 711 {
 712     StgPtr p;
 713     bdescr *bd;
 714     StgInfoTable *info;
 715
 716     bd = blocks;
 717
 718 #if defined(PAR)
 719     barf("update_fwd: ToDo");
 720 #endif
 721
 722     // cycle through all the blocks in the step
 723     for (; bd != NULL; bd = bd->link) {
 724         p = bd->start;
 725
 726         // linearly scan the objects in this block
 727         while (p < bd->free) {
 728             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 729             info = get_itbl((StgClosure *)p);
 730             p = thread_obj(info, p);
 731         }
 732     }
 733 }
 734
 735 static void
 736 update_fwd_compact( bdescr *blocks )
 737 {
 738     StgPtr p, q, free;
 739 #if 0
 740     StgWord m;
 741 #endif
 742     bdescr *bd, *free_bd;
 743     StgInfoTable *info;
 744     nat size;
 745
 746     bd = blocks;
 747     free_bd = blocks;
 748     free = free_bd->start;
 749
 750 #if defined(PAR)
 751     barf("update_fwd: ToDo");
 752 #endif
 753
 754     // cycle through all the blocks in the step
 755     for (; bd != NULL; bd = bd->link) {
 756         p = bd->start;
 757
 758         while (p < bd->free ) {
 759
 760             while ( p < bd->free && !is_marked(p,bd) ) {
 761                 p++;
 762             }
 763             if (p >= bd->free) {
 764                 break;
 765             }
 766
 767 #if 0
 768     next:
 769         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 770         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 771
 772         while ( p < bd->free ) {
 773
 774             if ((m & 1) == 0) {
 775                 m >>= 1;
 776                 p++;
 777                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 778                     goto next;
 779                 } else {
 780                     continue;
 781                 }
 782             }
 783 #endif
 784
 785             // Problem: we need to know the destination for this cell
 786             // in order to unthread its info pointer.  But we can't
 787             // know the destination without the size, because we may
 788             // spill into the next block.  So we have to run down the
 789             // threaded list and get the info ptr first.
 790             info = get_threaded_info(p);
 791
 792             q = p;
 793
 794             p = thread_obj(info, p);
 795
 796             size = p - q;
 797             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 798                 // unset the next bit in the bitmap to indicate that
 799                 // this object needs to be pushed into the next
 800                 // block.  This saves us having to run down the
 801                 // threaded info pointer list twice during the next pass.
 802                 unmark(q+1,bd);
 803                 free_bd = free_bd->link;
 804                 free = free_bd->start;
 805             } else {
 806                 ASSERT(is_marked(q+1,bd));
 807             }
 808
 809             unthread(q,free);
 810             free += size;
 811 #if 0
 812             goto next;
 813 #endif
 814         }
 815     }
 816 }
 817
 818 static nat
 819 update_bkwd_compact( step *stp )
 820 {
 821     StgPtr p, free;
 822 #if 0
 823     StgWord m;
 824 #endif
 825     bdescr *bd, *free_bd;
 826     StgInfoTable *info;
 827     nat size, free_blocks;
 828
 829     bd = free_bd = stp->blocks;
 830     free = free_bd->start;
 831     free_blocks = 1;
 832
 833 #if defined(PAR)
 834     barf("update_bkwd: ToDo");
 835 #endif
 836
 837     // cycle through all the blocks in the step
 838     for (; bd != NULL; bd = bd->link) {
 839         p = bd->start;
 840
 841         while (p < bd->free ) {
 842
 843             while ( p < bd->free && !is_marked(p,bd) ) {
 844                 p++;
 845             }
 846             if (p >= bd->free) {
 847                 break;
 848             }
 849
 850 #if 0
 851     next:
 852         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 853         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 854
 855         while ( p < bd->free ) {
 856
 857             if ((m & 1) == 0) {
 858                 m >>= 1;
 859                 p++;
 860                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 861                     goto next;
 862                 } else {
 863                     continue;
 864                 }
 865             }
 866 #endif
 867
 868             if (!is_marked(p+1,bd)) {
 869                 // don't forget to update the free ptr in the block desc.
 870                 free_bd->free = free;
 871                 free_bd = free_bd->link;
 872                 free = free_bd->start;
 873                 free_blocks++;
 874             }
 875
 876             unthread(p,free);
 877             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 878             info = get_itbl((StgClosure *)p);
 879             size = obj_sizeW((StgClosure *)p,info);
 880
 881             if (free != p) {
 882                 move(free,p,size);
 883             }
 884
 885             // relocate TSOs
 886             if (info->type == TSO) {
 887                 move_TSO((StgTSO *)p, (StgTSO *)free);
 888             }
 889
 890             free += size;
 891             p += size;
 892 #if 0
 893             goto next;
 894 #endif
 895         }
 896     }
 897
 898     // free the remaining blocks and count what's left.
 899     free_bd->free = free;
 900     if (free_bd->link != NULL) {
 901         freeChain(free_bd->link);
 902         free_bd->link = NULL;
 903     }
 904     stp->n_blocks = free_blocks;
 905
 906     return free_blocks;
 907 }
 908
 909 void
 910 compact( void (*get_roots)(evac_fn) )
 911 {
 912     nat g, s, blocks;
 913     step *stp;
 914
 915     // 1. thread the roots
 916     get_roots((evac_fn)thread);
 917
 918     // the weak pointer lists...
 919     if (weak_ptr_list != NULL) {
 920         thread((StgPtr)&weak_ptr_list);
 921     }
 922     if (old_weak_ptr_list != NULL) {
 923         thread((StgPtr)&old_weak_ptr_list); // tmp
 924     }
 925
 926     // mutable lists
 927     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 928         bdescr *bd;
 929         StgPtr p;
 930         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 931             for (p = bd->start; p < bd->free; p++) {
 932                 thread(p);
 933             }
 934         }
 935     }
 936
 937     // the global thread list
 938     thread((StgPtr)&all_threads);
 939
 940     // any threads resurrected during this GC
 941     thread((StgPtr)&resurrected_threads);
 942
 943     // the main threads list
 944     {
 945         StgMainThread *m;
 946         for (m = main_threads; m != NULL; m = m->link) {
 947             thread((StgPtr)&m->tso);
 948         }
 949     }
 950
 951     // the static objects
 952     thread_static(scavenged_static_objects);
 953
 954     // the stable pointer table
 955     threadStablePtrTable((evac_fn)thread);
 956
 957     // the CAF list (used by GHCi)
 958     markCAFs((evac_fn)thread);
 959
 960     // 2. update forward ptrs
 961     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 962         for (s = 0; s < generations[g].n_steps; s++) {
 963             stp = &generations[g].steps[s];
 964             IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 965
 966             update_fwd(stp->to_blocks);
 967             update_fwd_large(stp->scavenged_large_objects);
 968             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 969                 IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 970                 update_fwd_compact(stp->blocks);
 971             }
 972         }
 973     }
 974
 975     // 3. update backward ptrs
 976     stp = &oldest_gen->steps[0];
 977     if (stp->blocks != NULL) {
 978         blocks = update_bkwd_compact(stp);
 979         IF_DEBUG(gc, debugBelch("update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 980                              stp->gen->no, stp->no,
 981                              stp->n_blocks, blocks););
 982         stp->n_blocks = blocks;
 983     }
 984 }