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 void
 110 thread_static( StgClosure* p )
 111 {
 112   const StgInfoTable *info;
 113
 114   // keep going until we've threaded all the objects on the linked
 115   // list...
 116   while (p != END_OF_STATIC_LIST) {
 117
 118     info = get_itbl(p);
 119     switch (info->type) {
 120
 121     case IND_STATIC:
 122         thread((StgPtr)&((StgInd *)p)->indirectee);
 123         p = *IND_STATIC_LINK(p);
 124         continue;
 125
 126     case THUNK_STATIC:
 127         p = *THUNK_STATIC_LINK(p);
 128         continue;
 129     case FUN_STATIC:
 130         p = *FUN_STATIC_LINK(p);
 131         continue;
 132     case CONSTR_STATIC:
 133         p = *STATIC_LINK(info,p);
 134         continue;
 135
 136     default:
 137         barf("thread_static: strange closure %d", (int)(info->type));
 138     }
 139
 140   }
 141 }
 142
 143 STATIC_INLINE void
 144 thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
 145 {
 146     nat i, b;
 147     StgWord bitmap;
 148
 149     b = 0;
 150     bitmap = large_bitmap->bitmap[b];
 151     for (i = 0; i < size; ) {
 152         if ((bitmap & 1) == 0) {
 153             thread(p);
 154         }
 155         i++;
 156         p++;
 157         if (i % BITS_IN(W_) == 0) {
 158             b++;
 159             bitmap = large_bitmap->bitmap[b];
 160         } else {
 161             bitmap = bitmap >> 1;
 162         }
 163     }
 164 }
 165
 166 STATIC_INLINE StgPtr
 167 thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
 168 {
 169     StgPtr p;
 170     StgWord bitmap;
 171     nat size;
 172
 173     p = (StgPtr)args;
 174     switch (fun_info->f.fun_type) {
 175     case ARG_GEN:
 176         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
 177         size = BITMAP_SIZE(fun_info->f.b.bitmap);
 178         goto small_bitmap;
 179     case ARG_GEN_BIG:
 180         size = GET_FUN_LARGE_BITMAP(fun_info)->size;
 181         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 182         p += size;
 183         break;
 184     default:
 185         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 186         size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 187     small_bitmap:
 188         while (size > 0) {
 189             if ((bitmap & 1) == 0) {
 190                 thread(p);
 191             }
 192             p++;
 193             bitmap = bitmap >> 1;
 194             size--;
 195         }
 196         break;
 197     }
 198     return p;
 199 }
 200
 201 static void
 202 thread_stack(StgPtr p, StgPtr stack_end)
 203 {
 204     const StgRetInfoTable* info;
 205     StgWord bitmap;
 206     nat size;
 207
 208     // highly similar to scavenge_stack, but we do pointer threading here.
 209
 210     while (p < stack_end) {
 211
 212         // *p must be the info pointer of an activation
 213         // record.  All activation records have 'bitmap' style layout
 214         // info.
 215         //
 216         info  = get_ret_itbl((StgClosure *)p);
 217
 218         switch (info->i.type) {
 219
 220             // Dynamic bitmap: the mask is stored on the stack
 221         case RET_DYN:
 222         {
 223             StgWord dyn;
 224             dyn = ((StgRetDyn *)p)->liveness;
 225
 226             // traverse the bitmap first
 227             bitmap = RET_DYN_LIVENESS(dyn);
 228             p      = (P_)&((StgRetDyn *)p)->payload[0];
 229             size   = RET_DYN_BITMAP_SIZE;
 230             while (size > 0) {
 231                 if ((bitmap & 1) == 0) {
 232                     thread(p);
 233                 }
 234                 p++;
 235                 bitmap = bitmap >> 1;
 236                 size--;
 237             }
 238
 239             // skip over the non-ptr words
 240             p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
 241
 242             // follow the ptr words
 243             for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
 244                 thread(p);
 245                 p++;
 246             }
 247             continue;
 248         }
 249
 250             // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
 251         case CATCH_RETRY_FRAME:
 252         case CATCH_STM_FRAME:
 253         case ATOMICALLY_FRAME:
 254         case UPDATE_FRAME:
 255         case STOP_FRAME:
 256         case CATCH_FRAME:
 257         case RET_SMALL:
 258         case RET_VEC_SMALL:
 259             bitmap = BITMAP_BITS(info->i.layout.bitmap);
 260             size   = BITMAP_SIZE(info->i.layout.bitmap);
 261             p++;
 262             // NOTE: the payload starts immediately after the info-ptr, we
 263             // don't have an StgHeader in the same sense as a heap closure.
 264             while (size > 0) {
 265                 if ((bitmap & 1) == 0) {
 266                     thread(p);
 267                 }
 268                 p++;
 269                 bitmap = bitmap >> 1;
 270                 size--;
 271             }
 272             continue;
 273
 274         case RET_BCO: {
 275             StgBCO *bco;
 276             nat size;
 277
 278             p++;
 279             bco = (StgBCO *)*p;
 280             thread(p);
 281             p++;
 282             size = BCO_BITMAP_SIZE(bco);
 283             thread_large_bitmap(p, BCO_BITMAP(bco), size);
 284             p += size;
 285             continue;
 286         }
 287
 288             // large bitmap (> 32 entries, or 64 on a 64-bit machine)
 289         case RET_BIG:
 290         case RET_VEC_BIG:
 291             p++;
 292             size = GET_LARGE_BITMAP(&info->i)->size;
 293             thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
 294             p += size;
 295             continue;
 296
 297         case RET_FUN:
 298         {
 299             StgRetFun *ret_fun = (StgRetFun *)p;
 300             StgFunInfoTable *fun_info;
 301
 302             fun_info = itbl_to_fun_itbl(
 303                 get_threaded_info((StgPtr)ret_fun->fun));
 304                  // *before* threading it!
 305             thread((StgPtr)&ret_fun->fun);
 306             p = thread_arg_block(fun_info, ret_fun->payload);
 307             continue;
 308         }
 309
 310         default:
 311             barf("thread_stack: weird activation record found on stack: %d",
 312                  (int)(info->i.type));
 313         }
 314     }
 315 }
 316
 317 STATIC_INLINE StgPtr
 318 thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
 319 {
 320     StgPtr p;
 321     StgWord bitmap;
 322     StgFunInfoTable *fun_info;
 323
 324     fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)fun));
 325     ASSERT(fun_info->i.type != PAP);
 326
 327     p = (StgPtr)payload;
 328
 329     switch (fun_info->f.fun_type) {
 330     case ARG_GEN:
 331         bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
 332         goto small_bitmap;
 333     case ARG_GEN_BIG:
 334         thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
 335         p += size;
 336         break;
 337     case ARG_BCO:
 338         thread_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
 339         p += size;
 340         break;
 341     default:
 342         bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 343     small_bitmap:
 344         while (size > 0) {
 345             if ((bitmap & 1) == 0) {
 346                 thread(p);
 347             }
 348             p++;
 349             bitmap = bitmap >> 1;
 350             size--;
 351         }
 352         break;
 353     }
 354
 355     return p;
 356 }
 357
 358 STATIC_INLINE StgPtr
 359 thread_PAP (StgPAP *pap)
 360 {
 361     StgPtr p;
 362     p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
 363     thread((StgPtr)&pap->fun);
 364     return p;
 365 }
 366
 367 STATIC_INLINE StgPtr
 368 thread_AP (StgAP *ap)
 369 {
 370     StgPtr p;
 371     p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
 372     thread((StgPtr)&ap->fun);
 373     return p;
 374 }
 375
 376 STATIC_INLINE StgPtr
 377 thread_AP_STACK (StgAP_STACK *ap)
 378 {
 379     thread((StgPtr)&ap->fun);
 380     thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
 381     return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
 382 }
 383
 384 static StgPtr
 385 thread_TSO (StgTSO *tso)
 386 {
 387     thread((StgPtr)&tso->link);
 388     thread((StgPtr)&tso->global_link);
 389
 390     if (   tso->why_blocked == BlockedOnMVar
 391         || tso->why_blocked == BlockedOnBlackHole
 392         || tso->why_blocked == BlockedOnException
 393 #if defined(PAR)
 394         || tso->why_blocked == BlockedOnGA
 395         || tso->why_blocked == BlockedOnGA_NoSend
 396 #endif
 397         ) {
 398         thread((StgPtr)&tso->block_info.closure);
 399     }
 400     if ( tso->blocked_exceptions != NULL ) {
 401         thread((StgPtr)&tso->blocked_exceptions);
 402     }
 403
 404     thread((StgPtr)&tso->trec);
 405
 406     thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
 407     return (StgPtr)tso + tso_sizeW(tso);
 408 }
 409
 410
 411 static void
 412 update_fwd_large( bdescr *bd )
 413 {
 414   StgPtr p;
 415   const StgInfoTable* info;
 416
 417   for (; bd != NULL; bd = bd->link) {
 418
 419     p = bd->start;
 420     info  = get_itbl((StgClosure *)p);
 421
 422     switch (info->type) {
 423
 424     case ARR_WORDS:
 425       // nothing to follow
 426       continue;
 427
 428     case MUT_ARR_PTRS_CLEAN:
 429     case MUT_ARR_PTRS_DIRTY:
 430     case MUT_ARR_PTRS_FROZEN:
 431     case MUT_ARR_PTRS_FROZEN0:
 432       // follow everything
 433       {
 434         StgPtr next;
 435
 436         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 437         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 438             thread(p);
 439         }
 440         continue;
 441       }
 442
 443     case TSO:
 444         thread_TSO((StgTSO *)p);
 445         continue;
 446
 447     case AP_STACK:
 448         thread_AP_STACK((StgAP_STACK *)p);
 449         continue;
 450
 451     case PAP:
 452         thread_PAP((StgPAP *)p);
 453         continue;
 454
 455     case TREC_CHUNK:
 456     {
 457         StgWord i;
 458         StgTRecChunk *tc = (StgTRecChunk *)p;
 459         TRecEntry *e = &(tc -> entries[0]);
 460         thread((StgPtr)&tc->prev_chunk);
 461         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 462           thread((StgPtr)&e->tvar);
 463           thread((StgPtr)&e->expected_value);
 464           thread((StgPtr)&e->new_value);
 465         }
 466         continue;
 467     }
 468
 469     default:
 470       barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
 471     }
 472   }
 473 }
 474
 475 STATIC_INLINE StgPtr
 476 thread_obj (StgInfoTable *info, StgPtr p)
 477 {
 478     switch (info->type) {
 479     case THUNK_0_1:
 480         return p + sizeofW(StgThunk) + 1;
 481
 482     case FUN_0_1:
 483     case CONSTR_0_1:
 484         return p + sizeofW(StgHeader) + 1;
 485
 486     case FUN_1_0:
 487     case CONSTR_1_0:
 488         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 489         return p + sizeofW(StgHeader) + 1;
 490
 491     case THUNK_1_0:
 492         thread((StgPtr)&((StgThunk *)p)->payload[0]);
 493         return p + sizeofW(StgThunk) + 1;
 494
 495     case THUNK_0_2:
 496         return p + sizeofW(StgThunk) + 2;
 497
 498     case FUN_0_2:
 499     case CONSTR_0_2:
 500         return p + sizeofW(StgHeader) + 2;
 501
 502     case THUNK_1_1:
 503         thread((StgPtr)&((StgThunk *)p)->payload[0]);
 504         return p + sizeofW(StgThunk) + 2;
 505
 506     case FUN_1_1:
 507     case CONSTR_1_1:
 508         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 509         return p + sizeofW(StgHeader) + 2;
 510
 511     case THUNK_2_0:
 512         thread((StgPtr)&((StgThunk *)p)->payload[0]);
 513         thread((StgPtr)&((StgThunk *)p)->payload[1]);
 514         return p + sizeofW(StgThunk) + 2;
 515
 516     case FUN_2_0:
 517     case CONSTR_2_0:
 518         thread((StgPtr)&((StgClosure *)p)->payload[0]);
 519         thread((StgPtr)&((StgClosure *)p)->payload[1]);
 520         return p + sizeofW(StgHeader) + 2;
 521
 522     case BCO: {
 523         StgBCO *bco = (StgBCO *)p;
 524         thread((StgPtr)&bco->instrs);
 525         thread((StgPtr)&bco->literals);
 526         thread((StgPtr)&bco->ptrs);
 527         thread((StgPtr)&bco->itbls);
 528         return p + bco_sizeW(bco);
 529     }
 530
 531     case THUNK:
 532     {
 533         StgPtr end;
 534
 535         end = (P_)((StgThunk *)p)->payload +
 536             info->layout.payload.ptrs;
 537         for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
 538             thread(p);
 539         }
 540         return p + info->layout.payload.nptrs;
 541     }
 542
 543     case FUN:
 544     case CONSTR:
 545     case STABLE_NAME:
 546     case IND_PERM:
 547     case MUT_VAR_CLEAN:
 548     case MUT_VAR_DIRTY:
 549     case CAF_BLACKHOLE:
 550     case SE_CAF_BLACKHOLE:
 551     case SE_BLACKHOLE:
 552     case BLACKHOLE:
 553     {
 554         StgPtr end;
 555
 556         end = (P_)((StgClosure *)p)->payload +
 557             info->layout.payload.ptrs;
 558         for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
 559             thread(p);
 560         }
 561         return p + info->layout.payload.nptrs;
 562     }
 563
 564     case WEAK:
 565     {
 566         StgWeak *w = (StgWeak *)p;
 567         thread((StgPtr)&w->key);
 568         thread((StgPtr)&w->value);
 569         thread((StgPtr)&w->finalizer);
 570         if (w->link != NULL) {
 571             thread((StgPtr)&w->link);
 572         }
 573         return p + sizeofW(StgWeak);
 574     }
 575
 576     case MVAR:
 577     {
 578         StgMVar *mvar = (StgMVar *)p;
 579         thread((StgPtr)&mvar->head);
 580         thread((StgPtr)&mvar->tail);
 581         thread((StgPtr)&mvar->value);
 582         return p + sizeofW(StgMVar);
 583     }
 584
 585     case IND_OLDGEN:
 586     case IND_OLDGEN_PERM:
 587         thread((StgPtr)&((StgInd *)p)->indirectee);
 588         return p + sizeofW(StgInd);
 589
 590     case THUNK_SELECTOR:
 591     {
 592         StgSelector *s = (StgSelector *)p;
 593         thread((StgPtr)&s->selectee);
 594         return p + THUNK_SELECTOR_sizeW();
 595     }
 596
 597     case AP_STACK:
 598         return thread_AP_STACK((StgAP_STACK *)p);
 599
 600     case PAP:
 601         return thread_PAP((StgPAP *)p);
 602
 603     case AP:
 604         return thread_AP((StgAP *)p);
 605
 606     case ARR_WORDS:
 607         return p + arr_words_sizeW((StgArrWords *)p);
 608
 609     case MUT_ARR_PTRS_CLEAN:
 610     case MUT_ARR_PTRS_DIRTY:
 611     case MUT_ARR_PTRS_FROZEN:
 612     case MUT_ARR_PTRS_FROZEN0:
 613         // follow everything
 614     {
 615         StgPtr next;
 616
 617         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
 618         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
 619             thread(p);
 620         }
 621         return p;
 622     }
 623
 624     case TSO:
 625         return thread_TSO((StgTSO *)p);
 626
 627     case TVAR_WAIT_QUEUE:
 628     {
 629         StgTVarWaitQueue *wq = (StgTVarWaitQueue *)p;
 630         thread((StgPtr)&wq->waiting_tso);
 631         thread((StgPtr)&wq->next_queue_entry);
 632         thread((StgPtr)&wq->prev_queue_entry);
 633         return p + sizeofW(StgTVarWaitQueue);
 634     }
 635
 636     case TVAR:
 637     {
 638         StgTVar *tvar = (StgTVar *)p;
 639         thread((StgPtr)&tvar->current_value);
 640         thread((StgPtr)&tvar->first_wait_queue_entry);
 641         return p + sizeofW(StgTVar);
 642     }
 643
 644     case TREC_HEADER:
 645     {
 646         StgTRecHeader *trec = (StgTRecHeader *)p;
 647         thread((StgPtr)&trec->enclosing_trec);
 648         thread((StgPtr)&trec->current_chunk);
 649         return p + sizeofW(StgTRecHeader);
 650     }
 651
 652     case TREC_CHUNK:
 653     {
 654         StgWord i;
 655         StgTRecChunk *tc = (StgTRecChunk *)p;
 656         TRecEntry *e = &(tc -> entries[0]);
 657         thread((StgPtr)&tc->prev_chunk);
 658         for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
 659           thread((StgPtr)&e->tvar);
 660           thread((StgPtr)&e->expected_value);
 661           thread((StgPtr)&e->new_value);
 662         }
 663         return p + sizeofW(StgTRecChunk);
 664     }
 665
 666     default:
 667         barf("update_fwd: unknown/strange object  %d", (int)(info->type));
 668         return NULL;
 669     }
 670 }
 671
 672 static void
 673 update_fwd( bdescr *blocks )
 674 {
 675     StgPtr p;
 676     bdescr *bd;
 677     StgInfoTable *info;
 678
 679     bd = blocks;
 680
 681 #if defined(PAR)
 682     barf("update_fwd: ToDo");
 683 #endif
 684
 685     // cycle through all the blocks in the step
 686     for (; bd != NULL; bd = bd->link) {
 687         p = bd->start;
 688
 689         // linearly scan the objects in this block
 690         while (p < bd->free) {
 691             ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 692             info = get_itbl((StgClosure *)p);
 693             p = thread_obj(info, p);
 694         }
 695     }
 696 }
 697
 698 static void
 699 update_fwd_compact( bdescr *blocks )
 700 {
 701     StgPtr p, q, free;
 702 #if 0
 703     StgWord m;
 704 #endif
 705     bdescr *bd, *free_bd;
 706     StgInfoTable *info;
 707     nat size;
 708
 709     bd = blocks;
 710     free_bd = blocks;
 711     free = free_bd->start;
 712
 713 #if defined(PAR)
 714     barf("update_fwd: ToDo");
 715 #endif
 716
 717     // cycle through all the blocks in the step
 718     for (; bd != NULL; bd = bd->link) {
 719         p = bd->start;
 720
 721         while (p < bd->free ) {
 722
 723             while ( p < bd->free && !is_marked(p,bd) ) {
 724                 p++;
 725             }
 726             if (p >= bd->free) {
 727                 break;
 728             }
 729
 730 #if 0
 731     next:
 732         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 733         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 734
 735         while ( p < bd->free ) {
 736
 737             if ((m & 1) == 0) {
 738                 m >>= 1;
 739                 p++;
 740                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 741                     goto next;
 742                 } else {
 743                     continue;
 744                 }
 745             }
 746 #endif
 747
 748             // Problem: we need to know the destination for this cell
 749             // in order to unthread its info pointer.  But we can't
 750             // know the destination without the size, because we may
 751             // spill into the next block.  So we have to run down the
 752             // threaded list and get the info ptr first.
 753             info = get_threaded_info(p);
 754
 755             q = p;
 756
 757             p = thread_obj(info, p);
 758
 759             size = p - q;
 760             if (free + size > free_bd->start + BLOCK_SIZE_W) {
 761                 // unset the next bit in the bitmap to indicate that
 762                 // this object needs to be pushed into the next
 763                 // block.  This saves us having to run down the
 764                 // threaded info pointer list twice during the next pass.
 765                 unmark(q+1,bd);
 766                 free_bd = free_bd->link;
 767                 free = free_bd->start;
 768             } else {
 769                 ASSERT(is_marked(q+1,bd));
 770             }
 771
 772             unthread(q,free);
 773             free += size;
 774 #if 0
 775             goto next;
 776 #endif
 777         }
 778     }
 779 }
 780
 781 static nat
 782 update_bkwd_compact( step *stp )
 783 {
 784     StgPtr p, free;
 785 #if 0
 786     StgWord m;
 787 #endif
 788     bdescr *bd, *free_bd;
 789     StgInfoTable *info;
 790     nat size, free_blocks;
 791
 792     bd = free_bd = stp->old_blocks;
 793     free = free_bd->start;
 794     free_blocks = 1;
 795
 796 #if defined(PAR)
 797     barf("update_bkwd: ToDo");
 798 #endif
 799
 800     // cycle through all the blocks in the step
 801     for (; bd != NULL; bd = bd->link) {
 802         p = bd->start;
 803
 804         while (p < bd->free ) {
 805
 806             while ( p < bd->free && !is_marked(p,bd) ) {
 807                 p++;
 808             }
 809             if (p >= bd->free) {
 810                 break;
 811             }
 812
 813 #if 0
 814     next:
 815         m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
 816         m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));
 817
 818         while ( p < bd->free ) {
 819
 820             if ((m & 1) == 0) {
 821                 m >>= 1;
 822                 p++;
 823                 if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
 824                     goto next;
 825                 } else {
 826                     continue;
 827                 }
 828             }
 829 #endif
 830
 831             if (!is_marked(p+1,bd)) {
 832                 // don't forget to update the free ptr in the block desc.
 833                 free_bd->free = free;
 834                 free_bd = free_bd->link;
 835                 free = free_bd->start;
 836                 free_blocks++;
 837             }
 838
 839             unthread(p,free);
 840             ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
 841             info = get_itbl((StgClosure *)p);
 842             size = closure_sizeW_((StgClosure *)p,info);
 843
 844             if (free != p) {
 845                 move(free,p,size);
 846             }
 847
 848             // relocate TSOs
 849             if (info->type == TSO) {
 850                 move_TSO((StgTSO *)p, (StgTSO *)free);
 851             }
 852
 853             free += size;
 854             p += size;
 855 #if 0
 856             goto next;
 857 #endif
 858         }
 859     }
 860
 861     // free the remaining blocks and count what's left.
 862     free_bd->free = free;
 863     if (free_bd->link != NULL) {
 864         freeChain(free_bd->link);
 865         free_bd->link = NULL;
 866     }
 867
 868     return free_blocks;
 869 }
 870
 871 void
 872 compact( void (*get_roots)(evac_fn) )
 873 {
 874     nat g, s, blocks;
 875     step *stp;
 876
 877     // 1. thread the roots
 878     get_roots((evac_fn)thread);
 879
 880     // the weak pointer lists...
 881     if (weak_ptr_list != NULL) {
 882         thread((StgPtr)(void *)&weak_ptr_list);
 883     }
 884     if (old_weak_ptr_list != NULL) {
 885         thread((StgPtr)(void *)&old_weak_ptr_list); // tmp
 886     }
 887
 888     // mutable lists
 889     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 890         bdescr *bd;
 891         StgPtr p;
 892         for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 893             for (p = bd->start; p < bd->free; p++) {
 894                 thread(p);
 895             }
 896         }
 897     }
 898
 899     // the global thread list
 900     thread((StgPtr)(void *)&all_threads);
 901
 902     // any threads resurrected during this GC
 903     thread((StgPtr)(void *)&resurrected_threads);
 904
 905     // the task list
 906     {
 907         Task *task;
 908         for (task = all_tasks; task != NULL; task = task->all_link) {
 909             if (task->tso) {
 910                 thread((StgPtr)&task->tso);
 911             }
 912         }
 913     }
 914
 915     // the static objects
 916     thread_static(scavenged_static_objects);
 917
 918     // the stable pointer table
 919     threadStablePtrTable((evac_fn)thread);
 920
 921     // the CAF list (used by GHCi)
 922     markCAFs((evac_fn)thread);
 923
 924     // 2. update forward ptrs
 925     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
 926         for (s = 0; s < generations[g].n_steps; s++) {
 927             if (g==0 && s ==0) continue;
 928             stp = &generations[g].steps[s];
 929             IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d\n", stp->gen->no, stp->no););
 930
 931             update_fwd(stp->blocks);
 932             update_fwd_large(stp->scavenged_large_objects);
 933             if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
 934                 IF_DEBUG(gc, debugBelch("update_fwd:  %d.%d (compact)\n", stp->gen->no, stp->no););
 935                 update_fwd_compact(stp->old_blocks);
 936             }
 937         }
 938     }
 939
 940     // 3. update backward ptrs
 941     stp = &oldest_gen->steps[0];
 942     if (stp->old_blocks != NULL) {
 943         blocks = update_bkwd_compact(stp);
 944         IF_DEBUG(gc, debugBelch("update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)\n",
 945                              stp->gen->no, stp->no,
 946                              stp->n_old_blocks, blocks););
 947         stp->n_old_blocks = blocks;
 948     }
 949 }