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