ghc/rts/GCCompact.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: GCCompact.c,v 1.1 2001/07/23 17:23:19 simonmar Exp $
   3  *
   4  * (c) The GHC Team 2001
   5  *
   6  * Compacting garbage collector
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "RtsUtils.h"
  12 #include "RtsFlags.h"
  13 #include "Storage.h"
  14 #include "BlockAlloc.h"
  15 #include "MBlock.h"
  16 #include "GCCompact.h"
  17 #include "Schedule.h"
  18 #include "StablePriv.h"
  19
  20 static inline void
  21 thread( StgPtr p )
  22 {
  23     StgPtr q = (StgPtr)*p;
  24     ASSERT(!LOOKS_LIKE_GHC_INFO(q));
  25     if (HEAP_ALLOCED(q)) {
  26         *p = (StgWord)*q;
  27         *q = (StgWord)p;
  28     }
  29 }
  30
  31 static inline void
  32 unthread( StgPtr p, StgPtr free )
  33 {
  34     StgPtr q = (StgPtr)*p, r;
  35
  36     while (!LOOKS_LIKE_GHC_INFO(q)) {
  37         r = (StgPtr)*q;
  38         *q = (StgWord)free;
  39         q = r;
  40     }
  41     *p = (StgWord)q;
  42 }
  43
  44 static inline StgInfoTable *
  45 get_threaded_info( StgPtr p )
  46 {
  47     StgPtr q = (P_)GET_INFO((StgClosure *)p);
  48
  49     while (!LOOKS_LIKE_GHC_INFO(q)) {
  50         q = (P_)*q;
  51     }
  52     return INFO_PTR_TO_STRUCT((StgInfoTable *)q);
  53 }
  54
  55 // A word-aligned memmove will be faster for small objects than libc's or gcc's.
  56 // Remember, the two regions *might* overlap, but: to <= from.
  57 static inline void
  58 move(StgPtr to, StgPtr from, nat size)
  59 {
  60     for(; size > 0; --size) {
  61         *to++ = *from++;
  62     }
  63 }
  64
  65 static inline nat
  66 obj_sizeW( StgClosure *p, StgInfoTable *info )
  67 {
  68     switch (info->type) {
  69     case FUN_0_1:
  70     case CONSTR_0_1:
  71     case FUN_1_0:
  72     case CONSTR_1_0:
  73         return sizeofW(StgHeader) + 1;
  74     case THUNK_0_1:
  75     case THUNK_0_2:
  76     case FUN_0_2:
  77     case CONSTR_0_2:
  78     case THUNK_1_0:
  79     case THUNK_1_1:
  80     case FUN_1_1:
  81     case CONSTR_1_1:
  82     case THUNK_2_0:
  83     case FUN_2_0:
  84     case CONSTR_2_0:
  85         return sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
  86     case THUNK_SELECTOR:
  87         return THUNK_SELECTOR_sizeW();
  88     case AP_UPD:
  89     case PAP:
  90         return pap_sizeW((StgPAP *)p);
  91     case ARR_WORDS:
  92         return arr_words_sizeW((StgArrWords *)p);
  93     case MUT_ARR_PTRS:
  94     case MUT_ARR_PTRS_FROZEN:
  95         return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
  96     case TSO:
  97         return tso_sizeW((StgTSO *)p);
  98     default:
  99         return sizeW_fromITBL(info);
 100     }
 101 }
 102
 103 static void
 104 thread_static( StgClosure* p )
 105 {
 106   const StgInfoTable *info;
 107
 108   // keep going until we've threaded all the objects on the linked
 109   // list...
 110   while (p != END_OF_STATIC_LIST) {
 111
 112     info = get_itbl(p);
 113     switch (info->type) {
 114
 115     case IND_STATIC:
 116         thread((StgPtr)&((StgInd *)p)->indirectee);
 117         break;
 118
 119     case THUNK_STATIC:
 120     case FUN_STATIC:
 121     case CONSTR_STATIC:
 122         break;
 123
 124     default:
 125         barf("thread_static: strange closure %d", (int)(info->type));
 126     }
 127
 128     p = STATIC_LINK(info,p);
 129   }
 130 }
 131
 132 static void
 133 thread_stack(StgPtr p, StgPtr stack_end)
 134 {
 135     StgPtr q;
 136     const StgInfoTable* info;
 137     StgWord32 bitmap;
 138
 139     // highly similar to scavenge_stack, but we do pointer threading here.
 140
 141     while (p < stack_end) {
 142         q = (StgPtr)*p;
 143
 144         // If we've got a tag, skip over that many words on the stack
 145         if ( IS_ARG_TAG((W_)q) ) {
 146             p += ARG_SIZE(q);
 147             p++; continue;
 148         }
 149
 150         // Is q a pointer to a closure?
 151         if ( !LOOKS_LIKE_GHC_INFO(q) ) {
 152             thread(p);
 153             p++;
 154             continue;
 155         }
 156
 157         // Otherwise, q must be the info pointer of an activation
 158         // record.  All activation records have 'bitmap' style layout
 159         // info.
 160         //
 161         info  = get_itbl((StgClosure *)p);
 162
 163         switch (info->type) {
 164
 165             // Dynamic bitmap: the mask is stored on the stack
 166         case RET_DYN:
 167             bitmap = ((StgRetDyn *)p)->liveness;
 168             p      = (P_)&((StgRetDyn *)p)->payload[0];
 169             goto small_bitmap;
 170
 171             // probably a slow-entry point return address:
 172         case FUN:
 173         case FUN_STATIC:
 174             p++;
 175             continue;
 176
 177             // small bitmap (< 32 entries, or 64 on a 64-bit machine)
 178         case UPDATE_FRAME:
 179         case STOP_FRAME:
 180         case CATCH_FRAME:
 181         case SEQ_FRAME:
 182         case RET_BCO:
 183         case RET_SMALL:
 184         case RET_VEC_SMALL:
 185             bitmap = info->layout.bitmap;
 186             p++;
 187             // this assumes that the payload starts immediately after the info-ptr
 188         small_bitmap:
 189             while (bitmap != 0) {
 190                 if ((bitmap & 1) == 0) {
 191                     thread(p);
 192                 }
 193                 p++;
 194                 bitmap = bitmap >> 1;
 195             }
 196             continue;
 197
 198             // large bitmap (> 32 entries)
 199         case RET_BIG:
 200         case RET_VEC_BIG:
 201         {
 202             StgPtr q;
 203             StgLargeBitmap *large_bitmap;
 204             nat i;
 205
 206             large_bitmap = info->layout.large_bitmap;
 207             p++;
 208
 209             for (i=0; i<large_bitmap->size; i++) {
 210                 bitmap = large_bitmap->bitmap[i];
 211                 q = p + sizeof(W_) * 8;
 212                 while (bitmap != 0) {
 213                     if ((bitmap & 1) == 0) {
 214                         thread(p);
 215                     }
 216                     p++;
 217                     bitmap = bitmap >> 1;
 218                 }
 219                 if (i+1 < large_bitmap->size) {
 220                     while (p < q) {
 221                         thread(p);
 222                         p++;
 223                     }
 224                 }
 225             }
 226             continue;
 227         }
 228
 229         default:
 230             barf("thread_stack: weird activation record found on stack: %d",
 231                  (int)(info->type));
 232         }
 233     }
 234 }
 235
 236 static void
 237 update_fwd_large( bdescr *bd )
 238 {
 239   StgPtr p;
 240   const StgInfoTable* info;
 241
 242   for (; bd != NULL; bd = bd->link) {
 243
 244     p = bd->start;
 245     unthread(p,p);
 246     info  = get_itbl((StgClosure *)p);
 247
 248     switch (info->type) {
 249
 250     case ARR_WORDS:
 251       // nothing to follow
 252       continue;
 253
 254     case MUT_ARR_PTRS:
 255     case MUT_ARR_PTRS_FROZEN:
 256       // follow everything
 257       {
 258         StgPtr next;
 259
 260         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 261         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 262             thread(p);
 263         }
 264         continue;
 265       }
 266
 267     case TSO:
 268     {
 269         StgTSO *tso = (StgTSO *)p;
 270         thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 271         continue;
 272     }
 273
 274     case AP_UPD:
 275     case PAP:
 276       {
 277         StgPAP* pap = (StgPAP *)p;
 278         thread((StgPtr)&pap->fun);
 279         thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
 280         continue;
 281       }
 282
 283     default:
 284       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 285     }
 286   }
 287 }
 288
 289 static void
 290 update_fwd( bdescr *blocks )
 291 {
 292     StgPtr p;
 293     bdescr *bd;
 294     StgInfoTable *info;
 295
 296     bd = blocks;
 297
 298 #if defined(PAR)
 299     barf("update_fwd: ToDo");
 300 #endif
 301
 302     // cycle through all the blocks in the step
 303     for (; bd != NULL; bd = bd->link) {
 304         p = bd->start;
 305
 306         // linearly scan the objects in this block
 307         while (p < bd->free) {
 308
 309             /* unthread the info ptr */
 310             unthread(p,p);
 311             info = get_itbl((StgClosure *)p);
 312
 313             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 314                          || IS_HUGS_CONSTR_INFO(info)));
 315
 316             switch (info->type) {
 317             case FUN_0_1:
 318             case CONSTR_0_1:
 319                 p += sizeofW(StgHeader) + 1;
 320                 break;
 321
 322             case FUN_1_0:
 323             case CONSTR_1_0:
 324                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 325                 p += sizeofW(StgHeader) + 1;
 326                 break;
 327
 328             case THUNK_1_0:
 329                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 330                 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 331                 break;
 332
 333             case THUNK_0_1: // MIN_UPD_SIZE
 334             case THUNK_0_2:
 335             case FUN_0_2:
 336             case CONSTR_0_2:
 337                 p += sizeofW(StgHeader) + 2;
 338                 break;
 339
 340             case THUNK_1_1:
 341             case FUN_1_1:
 342             case CONSTR_1_1:
 343                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 344                 p += sizeofW(StgHeader) + 2;
 345                 break;
 346
 347             case THUNK_2_0:
 348             case FUN_2_0:
 349             case CONSTR_2_0:
 350                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 351                 thread((StgPtr)&((StgClosure *)p)->payload[1]);
 352                 p += sizeofW(StgHeader) + 2;
 353                 break;
 354
 355             case FUN:
 356             case THUNK:
 357             case CONSTR:
 358             case FOREIGN:
 359             case STABLE_NAME:
 360             case BCO:
 361             case IND_PERM:
 362             case MUT_VAR:
 363             case MUT_CONS:
 364             case CAF_BLACKHOLE:
 365             case SE_CAF_BLACKHOLE:
 366             case SE_BLACKHOLE:
 367             case BLACKHOLE:
 368             case BLACKHOLE_BQ:
 369             {
 370                 StgPtr end;
 371
 372                 end = (P_)((StgClosure *)p)->payload +
 373                     info->layout.payload.ptrs;
 374                 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 375                     thread(p);
 376                 }
 377                 p += info->layout.payload.nptrs;
 378                 break;
 379             }
 380
 381             // the info table for a weak ptr lies about the number of ptrs
 382             // (because we have special GC routines for them, but we
 383             // want to use the standard evacuate code).  So we have to
 384             // special case here.
 385             case WEAK:
 386             {
 387                 StgWeak *w = (StgWeak *)p;
 388                 thread((StgPtr)&w->key);
 389                 thread((StgPtr)&w->value);
 390                 thread((StgPtr)&w->finalizer);
 391                 if (w->link != NULL) {
 392                     thread((StgPtr)&w->link);
 393                 }
 394                 p += sizeofW(StgWeak);
 395                 break;
 396             }
 397
 398             // again, the info table for MVar isn't suitable here (it includes
 399             // the mut_link field as a pointer, and we don't want to
 400             // thread it).
 401             case MVAR:
 402             {
 403                 StgMVar *mvar = (StgMVar *)p;
 404                 thread((StgPtr)&mvar->head);
 405                 thread((StgPtr)&mvar->tail);
 406                 thread((StgPtr)&mvar->value);
 407                 p += sizeofW(StgMVar);
 408                 break;
 409             }
 410
 411             // specialise this case, because we want to update the
 412             // mut_link field too.
 413             case IND_OLDGEN:
 414             case IND_OLDGEN_PERM:
 415             {
 416                 StgIndOldGen *ind = (StgIndOldGen *)p;
 417                 thread((StgPtr)&ind->indirectee);
 418                 if (ind->mut_link != NULL) {
 419                     thread((StgPtr)&ind->mut_link);
 420                 }
 421                 break;
 422             }
 423
 424             case THUNK_SELECTOR:
 425             {
 426                 StgSelector *s = (StgSelector *)p;
 427                 thread((StgPtr)&s->selectee);
 428                 p += THUNK_SELECTOR_sizeW();
 429                 break;
 430             }
 431
 432             case AP_UPD: // same as PAPs
 433             case PAP:
 434             {
 435                 StgPAP* pap = (StgPAP *)p;
 436
 437                 thread((P_)&pap->fun);
 438                 thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
 439                 p += pap_sizeW(pap);
 440                 break;
 441             }
 442
 443             case ARR_WORDS:
 444                 p += arr_words_sizeW((StgArrWords *)p);
 445                 break;
 446
 447             case MUT_ARR_PTRS:
 448             case MUT_ARR_PTRS_FROZEN:
 449                 // follow everything
 450             {
 451                 StgPtr next;
 452
 453                 next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 454                 for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 455                     thread(p);
 456                 }
 457                 break;
 458             }
 459
 460             case TSO:
 461             {
 462                 StgTSO *tso = (StgTSO *)p;
 463                 thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 464                 thread((StgPtr)&tso->link);
 465                 thread((StgPtr)&tso->global_link);
 466                 p += tso_sizeW(tso);
 467                 break;
 468             }
 469
 470             default:
 471                 barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 472             }
 473         }
 474     }
 475 }
 476
 477 static void
 478 update_fwd_compact( bdescr *blocks )
 479 {
 480     StgPtr p, q, free;
 481     StgWord m;
 482     bdescr *bd, *free_bd;
 483     StgInfoTable *info;
 484     nat size;
 485
 486     bd = blocks;
 487     free_bd = blocks;
 488     free = free_bd->start;
 489
 490 #if defined(PAR)
 491     barf("update_fwd: ToDo");
 492 #endif
 493
 494     // cycle through all the blocks in the step
 495     for (; bd != NULL; bd = bd->link) {
 496         p = bd->start;
 497
 498         while (p < bd->free ) {
 499
 500             while ( p < bd->free && !is_marked(p,bd) ) {
 501                 p++;
 502             }
 503             if (p >= bd->free) {
 504                 break;
 505             }
 506
 507 #if 0
 508     next:
 509         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 510         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 511
 512         while ( p < bd->free ) {
 513
 514             if ((m & 1) == 0) {
 515                 m >>= 1;
 516                 p++;
 517                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 518                     goto next;
 519                 } else {
 520                     continue;
 521                 }
 522             }
 523 #endif
 524
 525             // Problem: we need to know the destination for this cell
 526             // in order to unthread its info pointer.  But we can't
 527             // know the destination without the size, because we may
 528             // spill into the next block.  So we have to run down the
 529             // threaded list and get the info ptr first.
 530             info = get_threaded_info(p);
 531
 532             q = p;
 533             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 534                          || IS_HUGS_CONSTR_INFO(info)));
 535
 536             switch (info->type) {
 537             case FUN_0_1:
 538             case CONSTR_0_1:
 539                 p += sizeofW(StgHeader) + 1;
 540                 break;
 541
 542             case FUN_1_0:
 543             case CONSTR_1_0:
 544                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 545                 p += sizeofW(StgHeader) + 1;
 546                 break;
 547
 548             case THUNK_1_0:
 549                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 550                 p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
 551                 break;
 552
 553             case THUNK_0_1: // MIN_UPD_SIZE
 554             case THUNK_0_2:
 555             case FUN_0_2:
 556             case CONSTR_0_2:
 557                 p += sizeofW(StgHeader) + 2;
 558                 break;
 559
 560             case THUNK_1_1:
 561             case FUN_1_1:
 562             case CONSTR_1_1:
 563                 thread((StgPtr)&((StgClosure *)p)->payload[0]);
 564                 p += sizeofW(StgHeader) + 2;
 565                 break;
 566
 567             case THUNK_2_0:
 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                 p += sizeofW(StgHeader) + 2;
 573                 break;
 574
 575             case FUN:
 576             case THUNK:
 577             case CONSTR:
 578             case FOREIGN:
 579             case STABLE_NAME:
 580             case BCO:
 581             case IND_PERM:
 582             case MUT_VAR:
 583             case MUT_CONS:
 584             case CAF_BLACKHOLE:
 585             case SE_CAF_BLACKHOLE:
 586             case SE_BLACKHOLE:
 587             case BLACKHOLE:
 588             case BLACKHOLE_BQ:
 589             {
 590                 StgPtr end;
 591
 592                 end = (P_)((StgClosure *)p)->payload +
 593                     info->layout.payload.ptrs;
 594                 for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 595                     thread(p);
 596                 }
 597                 p += info->layout.payload.nptrs;
 598                 break;
 599             }
 600
 601             case WEAK:
 602             {
 603                 StgWeak *w = (StgWeak *)p;
 604                 thread((StgPtr)&w->key);
 605                 thread((StgPtr)&w->value);
 606                 thread((StgPtr)&w->finalizer);
 607                 if (w->link != NULL) {
 608                     thread((StgPtr)&w->link);
 609                 }
 610                 p += sizeofW(StgWeak);
 611                 break;
 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                 p += sizeofW(StgMVar);
 621                 break;
 622             }
 623
 624             case IND_OLDGEN:
 625             case IND_OLDGEN_PERM:
 626                 // specialise this case, because we want to update the
 627                 // mut_link field too.
 628             {
 629                 StgIndOldGen *ind = (StgIndOldGen *)p;
 630                 thread((StgPtr)&ind->indirectee);
 631                 if (ind->mut_link != NULL) {
 632                     thread((StgPtr)&ind->mut_link);
 633                 }
 634                 p += sizeofW(StgIndOldGen);
 635                 break;
 636             }
 637
 638             case THUNK_SELECTOR:
 639             {
 640                 StgSelector *s = (StgSelector *)p;
 641                 thread((StgPtr)&s->selectee);
 642                 p += THUNK_SELECTOR_sizeW();
 643                 break;
 644             }
 645
 646             case AP_UPD: // same as PAPs
 647             case PAP:
 648             {
 649                 StgPAP* pap = (StgPAP *)p;
 650
 651                 thread((P_)&pap->fun);
 652                 thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
 653                 p += pap_sizeW(pap);
 654                 break;
 655             }
 656
 657             case ARR_WORDS:
 658                 p += arr_words_sizeW((StgArrWords *)p);
 659                 break;
 660
 661             case MUT_ARR_PTRS:
 662             case MUT_ARR_PTRS_FROZEN:
 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                 break;
 672             }
 673
 674             case TSO:
 675             {
 676                 StgTSO *tso = (StgTSO *)p;
 677                 thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 678                 thread((StgPtr)&tso->link);
 679                 thread((StgPtr)&tso->global_link);
 680                 p += tso_sizeW(tso);
 681                 break;
 682             }
 683
 684             default:
 685                 barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 686             }
 687
 688             size = p - q;
 689             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 690                 free_bd = free_bd->link;
 691                 free = free_bd->start;
 692             }
 693
 694             unthread(q,free);
 695             free += size;
 696 #if 0
 697             goto next;
 698 #endif
 699         }
 700     }
 701 }
 702
 703 static void
 704 update_bkwd( bdescr *blocks )
 705 {
 706     StgPtr p;
 707     bdescr *bd;
 708     StgInfoTable *info;
 709
 710     bd = blocks;
 711
 712 #if defined(PAR)
 713     barf("update_bkwd: ToDo");
 714 #endif
 715
 716     // cycle through all the blocks in the step
 717     for (; bd != NULL; bd = bd->link) {
 718         p = bd->start;
 719
 720         // linearly scan the objects in this block
 721         while (p < bd->free) {
 722
 723             // must unthread before we look at the info ptr...
 724             unthread(p,p);
 725
 726             info = get_itbl((StgClosure *)p);
 727             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 728                          || IS_HUGS_CONSTR_INFO(info)));
 729
 730             p += obj_sizeW((StgClosure *)p,info);
 731         }
 732     }
 733 }
 734
 735 static nat
 736 update_bkwd_compact( step *stp )
 737 {
 738     StgPtr p, free;
 739     StgWord m;
 740     bdescr *bd, *free_bd;
 741     StgInfoTable *info;
 742     nat size, free_blocks;
 743
 744     bd = free_bd = stp->blocks;
 745     free = free_bd->start;
 746     free_blocks = 1;
 747
 748 #if defined(PAR)
 749     barf("update_bkwd: ToDo");
 750 #endif
 751
 752     // cycle through all the blocks in the step
 753     for (; bd != NULL; bd = bd->link) {
 754         p = bd->start;
 755
 756         while (p < bd->free ) {
 757
 758             while ( p < bd->free && !is_marked(p,bd) ) {
 759                 p++;
 760             }
 761             if (p >= bd->free) {
 762                 break;
 763             }
 764
 765 #if 0
 766     next:
 767         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 768         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 769
 770         while ( p < bd->free ) {
 771
 772             if ((m & 1) == 0) {
 773                 m >>= 1;
 774                 p++;
 775                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 776                     goto next;
 777                 } else {
 778                     continue;
 779                 }
 780             }
 781 #endif
 782
 783             // must unthread before we look at the info ptr...
 784             info = get_threaded_info(p);
 785
 786             ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
 787                          || IS_HUGS_CONSTR_INFO(info)));
 788
 789             size = obj_sizeW((StgClosure *)p,info);
 790
 791             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 792                 // don't forget to update the free ptr in the block desc.
 793                 free_bd->free = free;
 794                 free_bd = free_bd->link;
 795                 free = free_bd->start;
 796                 free_blocks++;
 797             }
 798
 799             unthread(p,free);
 800             move(free,p,size);
 801
 802             // Rebuild the mutable list for the old generation.
 803             // (the mut_once list is updated using threading, with
 804             // special cases for IND_OLDGEN and MUT_CONS above).
 805             if (ip_MUTABLE(info)) {
 806                 recordMutable((StgMutClosure *)free);
 807             }
 808
 809             // relocate TSOs
 810             if (info->type == TSO) {
 811                 move_TSO((StgTSO *)p, (StgTSO *)free);
 812             }
 813
 814             free += size;
 815             p += size;
 816 #if 0
 817             goto next;
 818 #endif
 819         }
 820     }
 821
 822     // free the remaining blocks and count what's left.
 823     free_bd->free = free;
 824     if (free_bd->link != NULL) {
 825         freeChain(free_bd->link);
 826         free_bd->link = NULL;
 827     }
 828     stp->n_blocks = free_blocks;
 829
 830     return free_blocks;
 831 }
 832
 833 static void
 834 update_bkwd_large( bdescr *blocks )
 835 {
 836     bdescr *bd;
 837
 838     for (bd = blocks; bd != NULL; bd = bd->link ) {
 839         unthread(bd->start, bd->start);
 840     }
 841 }
 842
 843
 844 void
 845 compact( void (*get_roots)(evac_fn) )
 846 {
 847     nat g, s, blocks;
 848     step *stp;
 849     extern StgWeak *old_weak_ptr_list; // tmp
 850
 851     // 1. thread the roots
 852     get_roots((evac_fn)thread);
 853
 854     // the weak pointer lists...
 855     if (weak_ptr_list != NULL) {
 856         thread((StgPtr)&weak_ptr_list);
 857     }
 858     if (old_weak_ptr_list != NULL) {
 859         thread((StgPtr)&old_weak_ptr_list); // tmp
 860     }
 861
 862     // mutable lists (ToDo: all gens)
 863     thread((StgPtr)&oldest_gen->mut_list);
 864     thread((StgPtr)&oldest_gen->mut_once_list);
 865
 866     // the global thread list
 867     thread((StgPtr)&all_threads);
 868
 869     // the static objects
 870     thread_static(scavenged_static_objects);
 871
 872     // the stable pointer table
 873     threadStablePtrTable((evac_fn)thread);
 874
 875     // 2. update forward ptrs
 876     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 877         for (s = 0; s < generations[g].n_steps; s++) {
 878             stp = &generations[g].steps[s];
 879             IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 880
 881             update_fwd(stp->to_blocks);
 882             update_fwd_large(stp->scavenged_large_objects);
 883             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 884                 IF_DEBUG(gc, fprintf(stderr,"update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 885                 update_fwd_compact(stp->blocks);
 886             }
 887         }
 888     }
 889
 890     // 3. update backward ptrs
 891     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 892         for (s = 0; s < generations[g].n_steps; s++) {
 893             stp = &generations[g].steps[s];
 894             IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d\n", stp->gen->no, stp->no););
 895             update_bkwd(stp->to_blocks);
 896             update_bkwd_large(stp->scavenged_large_objects);
 897             if (g == RtsFlags.GcFlags.generations-1 && stp->blocks != NULL) {
 898                 IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact)\n", stp->gen->no, stp->no););
 899                 blocks = update_bkwd_compact(stp);
 900                 IF_DEBUG(gc, fprintf(stderr,"update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 901                                      stp->gen->no, stp->no,
 902                                      stp->n_blocks, blocks););
 903                 stp->n_blocks = blocks;
 904             }
 905         }
 906     }
 907 }