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