ghc/rts/GCCompact.c

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