ghc/rts/GCCompact.c

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