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_CLEAN:
 602     case MUT_VAR_DIRTY:
 603     case CAF_BLACKHOLE:
 604     case SE_CAF_BLACKHOLE:
 605     case SE_BLACKHOLE:
 606     case BLACKHOLE:
 607     {
 608         StgPtr end;
 609
 610         end = (P_)((StgClosure *)p)->payload +
 611             info->layout.payload.ptrs;
 612         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 613             thread(p);
 614         }
 615         return p + info->layout.payload.nptrs;
 616     }
 617
 618     case WEAK:
 619     {
 620         StgWeak *w = (StgWeak *)p;
 621         thread((StgPtr)&w->key);
 622         thread((StgPtr)&w->value);
 623         thread((StgPtr)&w->finalizer);
 624         if (w->link != NULL) {
 625             thread((StgPtr)&w->link);
 626         }
 627         return p + sizeofW(StgWeak);
 628     }
 629
 630     case MVAR:
 631     {
 632         StgMVar *mvar = (StgMVar *)p;
 633         thread((StgPtr)&mvar->head);
 634         thread((StgPtr)&mvar->tail);
 635         thread((StgPtr)&mvar->value);
 636         return p + sizeofW(StgMVar);
 637     }
 638
 639     case IND_OLDGEN:
 640     case IND_OLDGEN_PERM:
 641         thread((StgPtr)&((StgInd *)p)->indirectee);
 642         return p + sizeofW(StgInd);
 643
 644     case THUNK_SELECTOR:
 645     {
 646         StgSelector *s = (StgSelector *)p;
 647         thread((StgPtr)&s->selectee);
 648         return p + THUNK_SELECTOR_sizeW();
 649     }
 650
 651     case AP_STACK:
 652         return thread_AP_STACK((StgAP_STACK *)p);
 653
 654     case PAP:
 655         return thread_PAP((StgPAP *)p);
 656
 657     case AP:
 658         return thread_AP((StgAP *)p);
 659
 660     case ARR_WORDS:
 661         return p + arr_words_sizeW((StgArrWords *)p);
 662
 663     case MUT_ARR_PTRS_CLEAN:
 664     case MUT_ARR_PTRS_DIRTY:
 665     case MUT_ARR_PTRS_FROZEN:
 666     case MUT_ARR_PTRS_FROZEN0:
 667         // follow everything
 668     {
 669         StgPtr next;
 670
 671         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 672         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 673             thread(p);
 674         }
 675         return p;
 676     }
 677
 678     case TSO:
 679         return thread_TSO((StgTSO *)p);
 680
 681     case TVAR_WAIT_QUEUE:
 682     {
 683         StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
 684         thread((StgPtr)&wq->waiting_tso);
 685         thread((StgPtr)&wq->next_queue_entry);
 686         thread((StgPtr)&wq->prev_queue_entry);
 687         return p + sizeofW(StgTVarWaitQueue);
 688     }
 689
 690     case TVAR:
 691     {
 692         StgTVar *tvar = (StgTVar *)p;
 693         thread((StgPtr)&tvar->current_value);
 694         thread((StgPtr)&tvar->first_wait_queue_entry);
 695         return p + sizeofW(StgTVar);
 696     }
 697
 698     case TREC_HEADER:
 699     {
 700         StgTRecHeader *trec = (StgTRecHeader *)p;
 701         thread((StgPtr)&trec->enclosing_trec);
 702         thread((StgPtr)&trec->current_chunk);
 703         return p + sizeofW(StgTRecHeader);
 704     }
 705
 706     case TREC_CHUNK:
 707     {
 708         StgWord i;
 709         StgTRecChunk *tc = (StgTRecChunk *)p;
 710         TRecEntry *e = &(tc -> entries[0]);
 711         thread((StgPtr)&tc->prev_chunk);
 712         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 713           thread((StgPtr)&e->tvar);
 714           thread((StgPtr)&e->expected_value);
 715           thread((StgPtr)&e->new_value);
 716         }
 717         return p + sizeofW(StgTRecChunk);
 718     }
 719
 720     default:
 721         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 722         return NULL;
 723     }
 724 }
 725
 726 static void
 727 update_fwd( bdescr *blocks )
 728 {
 729     StgPtr p;
 730     bdescr *bd;
 731     StgInfoTable *info;
 732
 733     bd = blocks;
 734
 735 #if defined(PAR)
 736     barf("update_fwd: ToDo");
 737 #endif
 738
 739     // cycle through all the blocks in the step
 740     for (; bd != NULL; bd = bd->link) {
 741         p = bd->start;
 742
 743         // linearly scan the objects in this block
 744         while (p < bd->free) {
 745             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 746             info = get_itbl((StgClosure *)p);
 747             p = thread_obj(info, p);
 748         }
 749     }
 750 }
 751
 752 static void
 753 update_fwd_compact( bdescr *blocks )
 754 {
 755     StgPtr p, q, free;
 756 #if 0
 757     StgWord m;
 758 #endif
 759     bdescr *bd, *free_bd;
 760     StgInfoTable *info;
 761     nat size;
 762
 763     bd = blocks;
 764     free_bd = blocks;
 765     free = free_bd->start;
 766
 767 #if defined(PAR)
 768     barf("update_fwd: ToDo");
 769 #endif
 770
 771     // cycle through all the blocks in the step
 772     for (; bd != NULL; bd = bd->link) {
 773         p = bd->start;
 774
 775         while (p < bd->free ) {
 776
 777             while ( p < bd->free && !is_marked(p,bd) ) {
 778                 p++;
 779             }
 780             if (p >= bd->free) {
 781                 break;
 782             }
 783
 784 #if 0
 785     next:
 786         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 787         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 788
 789         while ( p < bd->free ) {
 790
 791             if ((m & 1) == 0) {
 792                 m >>= 1;
 793                 p++;
 794                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 795                     goto next;
 796                 } else {
 797                     continue;
 798                 }
 799             }
 800 #endif
 801
 802             // Problem: we need to know the destination for this cell
 803             // in order to unthread its info pointer.  But we can't
 804             // know the destination without the size, because we may
 805             // spill into the next block.  So we have to run down the
 806             // threaded list and get the info ptr first.
 807             info = get_threaded_info(p);
 808
 809             q = p;
 810
 811             p = thread_obj(info, p);
 812
 813             size = p - q;
 814             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 815                 // unset the next bit in the bitmap to indicate that
 816                 // this object needs to be pushed into the next
 817                 // block.  This saves us having to run down the
 818                 // threaded info pointer list twice during the next pass.
 819                 unmark(q+1,bd);
 820                 free_bd = free_bd->link;
 821                 free = free_bd->start;
 822             } else {
 823                 ASSERT(is_marked(q+1,bd));
 824             }
 825
 826             unthread(q,free);
 827             free += size;
 828 #if 0
 829             goto next;
 830 #endif
 831         }
 832     }
 833 }
 834
 835 static nat
 836 update_bkwd_compact( step *stp )
 837 {
 838     StgPtr p, free;
 839 #if 0
 840     StgWord m;
 841 #endif
 842     bdescr *bd, *free_bd;
 843     StgInfoTable *info;
 844     nat size, free_blocks;
 845
 846     bd = free_bd = stp->old_blocks;
 847     free = free_bd->start;
 848     free_blocks = 1;
 849
 850 #if defined(PAR)
 851     barf("update_bkwd: ToDo");
 852 #endif
 853
 854     // cycle through all the blocks in the step
 855     for (; bd != NULL; bd = bd->link) {
 856         p = bd->start;
 857
 858         while (p < bd->free ) {
 859
 860             while ( p < bd->free && !is_marked(p,bd) ) {
 861                 p++;
 862             }
 863             if (p >= bd->free) {
 864                 break;
 865             }
 866
 867 #if 0
 868     next:
 869         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 870         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 871
 872         while ( p < bd->free ) {
 873
 874             if ((m & 1) == 0) {
 875                 m >>= 1;
 876                 p++;
 877                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 878                     goto next;
 879                 } else {
 880                     continue;
 881                 }
 882             }
 883 #endif
 884
 885             if (!is_marked(p+1,bd)) {
 886                 // don't forget to update the free ptr in the block desc.
 887                 free_bd->free = free;
 888                 free_bd = free_bd->link;
 889                 free = free_bd->start;
 890                 free_blocks++;
 891             }
 892
 893             unthread(p,free);
 894             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 895             info = get_itbl((StgClosure *)p);
 896             size = obj_sizeW((StgClosure *)p,info);
 897
 898             if (free != p) {
 899                 move(free,p,size);
 900             }
 901
 902             // relocate TSOs
 903             if (info->type == TSO) {
 904                 move_TSO((StgTSO *)p, (StgTSO *)free);
 905             }
 906
 907             free += size;
 908             p += size;
 909 #if 0
 910             goto next;
 911 #endif
 912         }
 913     }
 914
 915     // free the remaining blocks and count what's left.
 916     free_bd->free = free;
 917     if (free_bd->link != NULL) {
 918         freeChain(free_bd->link);
 919         free_bd->link = NULL;
 920     }
 921
 922     return free_blocks;
 923 }
 924
 925 void
 926 compact( void (*get_roots)(evac_fn) )
 927 {
 928     nat g, s, blocks;
 929     step *stp;
 930
 931     // 1. thread the roots
 932     get_roots((evac_fn)thread);
 933
 934     // the weak pointer lists...
 935     if (weak_ptr_list != NULL) {
 936         thread((StgPtr)(void *)&weak_ptr_list);
 937     }
 938     if (old_weak_ptr_list != NULL) {
 939         thread((StgPtr)(void *)&old_weak_ptr_list); // tmp
 940     }
 941
 942     // mutable lists
 943     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 944         bdescr *bd;
 945         StgPtr p;
 946         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 947             for (p = bd->start; p < bd->free; p++) {
 948                 thread(p);
 949             }
 950         }
 951     }
 952
 953     // the global thread list
 954     thread((StgPtr)(void *)&all_threads);
 955
 956     // any threads resurrected during this GC
 957     thread((StgPtr)(void *)&resurrected_threads);
 958
 959     // the task list
 960     {
 961         Task *task;
 962         for (task = all_tasks; task != NULL; task = task->all_link) {
 963             if (task->tso) {
 964                 thread((StgPtr)&task->tso);
 965             }
 966         }
 967     }
 968
 969     // the static objects
 970     thread_static(scavenged_static_objects);
 971
 972     // the stable pointer table
 973     threadStablePtrTable((evac_fn)thread);
 974
 975     // the CAF list (used by GHCi)
 976     markCAFs((evac_fn)thread);
 977
 978     // 2. update forward ptrs
 979     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 980         for (s = 0; s < generations[g].n_steps; s++) {
 981             if (g==0 && s ==0) continue;
 982             stp = &generations[g].steps[s];
 983             IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 984
 985             update_fwd(stp->blocks);
 986             update_fwd_large(stp->scavenged_large_objects);
 987             if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
 988                 IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 989                 update_fwd_compact(stp->old_blocks);
 990             }
 991         }
 992     }
 993
 994     // 3. update backward ptrs
 995     stp = &oldest_gen->steps[0];
 996     if (stp->old_blocks != NULL) {
 997         blocks = update_bkwd_compact(stp);
 998         IF_DEBUG(gc, debugBelch("update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 999                              stp->gen->no, stp->no,
1000                              stp->n_old_blocks, blocks););
1001         stp->n_old_blocks = blocks;
1002     }
1003 }