Compact.c 26.2 KB
Newer Older
1 2
/* -----------------------------------------------------------------------------
 *
3
 * (c) The GHC Team 2001-2008
4 5 6
 *
 * Compacting garbage collector
 *
7 8
 * Documentation on the architecture of the Garbage Collector can be
 * found in the online commentary:
9
 *
10
 *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC
11
 *
12 13
 * ---------------------------------------------------------------------------*/

14
#include "PosixSource.h"
15
#include "Rts.h"
Simon Marlow's avatar
Simon Marlow committed
16

Simon Marlow's avatar
Simon Marlow committed
17
#include "GCThread.h"
Simon Marlow's avatar
Simon Marlow committed
18
#include "Storage.h"
19 20
#include "RtsUtils.h"
#include "BlockAlloc.h"
21 22
#include "GC.h"
#include "Compact.h"
23
#include "Schedule.h"
24
#include "Apply.h"
Simon Marlow's avatar
Simon Marlow committed
25
#include "Trace.h"
Simon Marlow's avatar
Simon Marlow committed
26 27 28
#include "Weak.h"
#include "MarkWeak.h"
#include "Stable.h"
29

30
// Turn off inlining when debugging - it obfuscates things
Ben Gamari's avatar
Ben Gamari committed
31
#if defined(DEBUG)
sof's avatar
sof committed
32 33
# undef  STATIC_INLINE
# define STATIC_INLINE static
34 35
#endif

36
/* ----------------------------------------------------------------------------
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
   Threading / unthreading pointers.

   The basic idea here is to chain together all the fields pointing at
   a particular object, with the root of the chain in the object's
   info table field.  The original contents of the info pointer goes
   at the end of the chain.

   Adding a new field to the chain is a matter of swapping the
   contents of the field with the contents of the object's info table
   field.

   To unthread the chain, we walk down it updating all the fields on
   the chain with the new location of the object.  We stop when we
   reach the info pointer at the end.

52 53 54 55 56 57 58
   The main difficulty here is that we need to be able to identify the
   info pointer at the end of the chain.  We can't use the low bits of
   the pointer for this; they are already being used for
   pointer-tagging.  What's more, we need to retain the
   pointer-tagging tag bits on each pointer during the
   threading/unthreading process.

59
   Our solution is as follows:
60 61 62 63 64 65 66 67 68 69 70
     - an info pointer (chain length zero) is identified by having tag 0
     - in a threaded chain of length > 0:
        - the pointer-tagging tag bits are attached to the info pointer
        - the first entry in the chain has tag 1
        - second and subsequent entries in the chain have tag 2

   This exploits the fact that the tag on each pointer to a given
   closure is normally the same (if they are not the same, then
   presumably the tag is not essential and it therefore doesn't matter
   if we throw away some of the tags).
   ------------------------------------------------------------------------- */
71

sof's avatar
sof committed
72
STATIC_INLINE void
73
thread (StgClosure **p)
74
{
75 76 77
    StgClosure *q0;
    StgPtr q;
    StgWord iptr;
78 79
    bdescr *bd;

80 81 82
    q0  = *p;
    q   = (StgPtr)UNTAG_CLOSURE(q0);

83 84 85
    // It doesn't look like a closure at the moment, because the info
    // ptr is possibly threaded:
    // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
86

87
    if (HEAP_ALLOCED(q)) {
88
        bd = Bdescr(q);
89

90
        if (bd->flags & BF_MARKED)
Simon Marlow's avatar
Simon Marlow committed
91
        {
92 93 94
            iptr = *q;
            switch (GET_CLOSURE_TAG((StgClosure *)iptr))
            {
95
            case 0:
96 97 98 99 100 101 102 103 104 105 106 107 108
                // this is the info pointer; we are creating a new chain.
                // save the original tag at the end of the chain.
                *p = (StgClosure *)((StgWord)iptr + GET_CLOSURE_TAG(q0));
                *q = (StgWord)p + 1;
                break;
            case 1:
            case 2:
                // this is a chain of length 1 or more
                *p = (StgClosure *)iptr;
                *q = (StgWord)p + 2;
                break;
            }
        }
109 110 111
    }
}

112 113 114 115 116 117
static void
thread_root (void *user STG_UNUSED, StgClosure **p)
{
    thread(p);
}

118 119 120 121
// This version of thread() takes a (void *), used to circumvent
// warnings from gcc about pointer punning and strict aliasing.
STATIC_INLINE void thread_ (void *p) { thread((StgClosure **)p); }

sof's avatar
sof committed
122
STATIC_INLINE void
123
unthread( StgPtr p, StgWord free )
124
{
125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
    StgWord q, r;
    StgPtr q0;

    q = *p;
loop:
    switch (GET_CLOSURE_TAG((StgClosure *)q))
    {
    case 0:
        // nothing to do; the chain is length zero
        return;
    case 1:
        q0 = (StgPtr)(q-1);
        r = *q0;  // r is the info ptr, tagged with the pointer-tag
        *q0 = free;
        *p = (StgWord)UNTAG_CLOSURE((StgClosure *)r);
        return;
    case 2:
        q0 = (StgPtr)(q-2);
        r = *q0;
        *q0 = free;
        q = r;
        goto loop;
    default:
        barf("unthread");
149 150 151
    }
}

152 153 154 155 156
// Traverse a threaded chain and pull out the info pointer at the end.
// The info pointer is also tagged with the appropriate pointer tag
// for this closure, which should be attached to the pointer
// subsequently passed to unthread().
STATIC_INLINE StgWord
157 158
get_threaded_info( StgPtr p )
{
159
    StgWord q;
160

161
    q = (W_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
162

163
loop:
164
    switch (GET_CLOSURE_TAG((StgClosure *)q))
165 166 167 168 169 170 171
    {
    case 0:
        ASSERT(LOOKS_LIKE_INFO_PTR(q));
        return q;
    case 1:
    {
        StgWord r = *(StgPtr)(q-1);
172 173
        ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)
               UNTAG_CONST_CLOSURE((StgClosure *)r)));
174 175 176 177 178 179 180
        return r;
    }
    case 2:
        q = *(StgPtr)(q-2);
        goto loop;
    default:
        barf("get_threaded_info");
181 182 183 184 185
    }
}

// A word-aligned memmove will be faster for small objects than libc's or gcc's.
// Remember, the two regions *might* overlap, but: to <= from.
sof's avatar
sof committed
186
STATIC_INLINE void
187
move(StgPtr to, StgPtr from, StgWord size)
188 189
{
    for(; size > 0; --size) {
190
        *to++ = *from++;
191 192 193 194 195 196 197 198 199
    }
}

static void
thread_static( StgClosure* p )
{
  const StgInfoTable *info;

  // keep going until we've threaded all the objects on the linked
200
  // list...
201 202
  while (p != END_OF_STATIC_OBJECT_LIST) {
    p = UNTAG_STATIC_LIST_PTR(p);
203 204
    info = get_itbl(p);
    switch (info->type) {
205

206
    case IND_STATIC:
207 208 209 210
        thread(&((StgInd *)p)->indirectee);
        p = *IND_STATIC_LINK(p);
        continue;

211
    case THUNK_STATIC:
212 213
        p = *THUNK_STATIC_LINK(p);
        continue;
214
    case FUN_STATIC:
215
        p = *STATIC_LINK(info,p);
216
        continue;
Simon Marlow's avatar
Simon Marlow committed
217 218 219 220 221 222 223
    case CONSTR:
    case CONSTR_NOCAF:
    case CONSTR_1_0:
    case CONSTR_0_1:
    case CONSTR_2_0:
    case CONSTR_1_1:
    case CONSTR_0_2:
224 225 226
        p = *STATIC_LINK(info,p);
        continue;

227
    default:
228
        barf("thread_static: strange closure %d", (int)(info->type));
229 230 231 232 233
    }

  }
}

sof's avatar
sof committed
234
STATIC_INLINE void
235
thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, StgWord size )
236
{
237
    W_ i, b;
238 239 240 241 242
    StgWord bitmap;

    b = 0;
    bitmap = large_bitmap->bitmap[b];
    for (i = 0; i < size; ) {
243 244 245 246 247 248 249 250 251 252 253
        if ((bitmap & 1) == 0) {
            thread((StgClosure **)p);
        }
        i++;
        p++;
        if (i % BITS_IN(W_) == 0) {
            b++;
            bitmap = large_bitmap->bitmap[b];
        } else {
            bitmap = bitmap >> 1;
        }
254 255 256
    }
}

257 258 259 260 261 262 263 264 265 266 267 268 269 270
STATIC_INLINE StgPtr
thread_small_bitmap (StgPtr p, StgWord size, StgWord bitmap)
{
    while (size > 0) {
        if ((bitmap & 1) == 0) {
            thread((StgClosure **)p);
        }
        p++;
        bitmap = bitmap >> 1;
        size--;
    }
    return p;
}

sof's avatar
sof committed
271
STATIC_INLINE StgPtr
272 273 274 275
thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
{
    StgPtr p;
    StgWord bitmap;
276
    StgWord size;
277 278

    p = (StgPtr)args;
279
    switch (fun_info->f.fun_type) {
280
    case ARG_GEN:
281 282 283
        bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
        size = BITMAP_SIZE(fun_info->f.b.bitmap);
        goto small_bitmap;
284
    case ARG_GEN_BIG:
285 286 287 288
        size = GET_FUN_LARGE_BITMAP(fun_info)->size;
        thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
        p += size;
        break;
289
    default:
290 291
        bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
        size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
292
    small_bitmap:
293
        p = thread_small_bitmap(p, size, bitmap);
294
        break;
295 296 297 298
    }
    return p;
}

299 300 301
static void
thread_stack(StgPtr p, StgPtr stack_end)
{
302
    const StgRetInfoTable* info;
ken's avatar
ken committed
303
    StgWord bitmap;
304
    StgWord size;
305

306
    // highly similar to scavenge_stack, but we do pointer threading here.
307

308 309
    while (p < stack_end) {

310 311 312 313 314 315 316 317
        // *p must be the info pointer of an activation
        // record.  All activation records have 'bitmap' style layout
        // info.
        //
        info  = get_ret_itbl((StgClosure *)p);

        switch (info->i.type) {

318
            // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
319 320 321
        case CATCH_RETRY_FRAME:
        case CATCH_STM_FRAME:
        case ATOMICALLY_FRAME:
322
        case UPDATE_FRAME:
323 324 325
        case UNDERFLOW_FRAME:
        case STOP_FRAME:
        case CATCH_FRAME:
326 327 328 329 330 331
        case RET_SMALL:
            bitmap = BITMAP_BITS(info->i.layout.bitmap);
            size   = BITMAP_SIZE(info->i.layout.bitmap);
            p++;
            // NOTE: the payload starts immediately after the info-ptr, we
            // don't have an StgHeader in the same sense as a heap closure.
332
            p = thread_small_bitmap(p, size, bitmap);
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361
            continue;

        case RET_BCO: {
            StgBCO *bco;

            p++;
            bco = (StgBCO *)*p;
            thread((StgClosure **)p);
            p++;
            size = BCO_BITMAP_SIZE(bco);
            thread_large_bitmap(p, BCO_BITMAP(bco), size);
            p += size;
            continue;
        }

            // large bitmap (> 32 entries, or 64 on a 64-bit machine)
        case RET_BIG:
            p++;
            size = GET_LARGE_BITMAP(&info->i)->size;
            thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
            p += size;
            continue;

        case RET_FUN:
        {
            StgRetFun *ret_fun = (StgRetFun *)p;
            StgFunInfoTable *fun_info;

            fun_info = FUN_INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_CLOSURE((StgClosure *)
362
                           get_threaded_info((StgPtr)ret_fun->fun)));
363 364 365 366 367 368 369 370 371 372
                 // *before* threading it!
            thread(&ret_fun->fun);
            p = thread_arg_block(fun_info, ret_fun->payload);
            continue;
        }

        default:
            barf("thread_stack: weird activation record found on stack: %d",
                 (int)(info->i.type));
        }
373 374 375
    }
}

sof's avatar
sof committed
376
STATIC_INLINE StgPtr
377
thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
378 379
{
    StgPtr p;
380
    StgWord bitmap;
381
    StgFunInfoTable *fun_info;
382

383
    fun_info = FUN_INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_CLOSURE((StgClosure *)
384
                        get_threaded_info((StgPtr)fun)));
385 386
    ASSERT(fun_info->i.type != PAP);

387
    p = (StgPtr)payload;
388

389
    switch (fun_info->f.fun_type) {
390
    case ARG_GEN:
391 392
        bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
        goto small_bitmap;
393
    case ARG_GEN_BIG:
394 395 396
        thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
        p += size;
        break;
397
    case ARG_BCO:
398 399 400
        thread_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
        p += size;
        break;
401
    default:
402
        bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
403
    small_bitmap:
404
        p = thread_small_bitmap(p, size, bitmap);
405
        break;
406
    }
407

408 409 410 411 412 413 414 415
    return p;
}

STATIC_INLINE StgPtr
thread_PAP (StgPAP *pap)
{
    StgPtr p;
    p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
416
    thread(&pap->fun);
417 418
    return p;
}
419

420 421 422 423 424
STATIC_INLINE StgPtr
thread_AP (StgAP *ap)
{
    StgPtr p;
    p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
425
    thread(&ap->fun);
426
    return p;
427
}
428

sof's avatar
sof committed
429
STATIC_INLINE StgPtr
430 431
thread_AP_STACK (StgAP_STACK *ap)
{
432
    thread(&ap->fun);
433 434 435 436 437 438 439
    thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
    return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
}

static StgPtr
thread_TSO (StgTSO *tso)
{
440
    thread_(&tso->_link);
441
    thread_(&tso->global_link);
442 443

    if (   tso->why_blocked == BlockedOnMVar
444
        || tso->why_blocked == BlockedOnMVarRead
445 446
        || tso->why_blocked == BlockedOnBlackHole
        || tso->why_blocked == BlockedOnMsgThrowTo
447 448
        || tso->why_blocked == NotBlocked
        ) {
449
        thread_(&tso->block_info.closure);
450
    }
451
    thread_(&tso->blocked_exceptions);
452
    thread_(&tso->bq);
453

454
    thread_(&tso->trec);
455

456 457
    thread_(&tso->stackobj);
    return (StgPtr)tso + sizeofW(StgTSO);
458 459 460
}


461 462 463 464 465 466 467 468
static void
update_fwd_large( bdescr *bd )
{
  StgPtr p;
  const StgInfoTable* info;

  for (; bd != NULL; bd = bd->link) {

Simon Marlow's avatar
Simon Marlow committed
469 470 471 472
    // nothing to do in a pinned block; it might not even have an object
    // at the beginning.
    if (bd->flags & BF_PINNED) continue;

473 474 475 476 477 478
    p = bd->start;
    info  = get_itbl((StgClosure *)p);

    switch (info->type) {

    case ARR_WORDS:
gcampax's avatar
gcampax committed
479
    case COMPACT_NFDATA:
480
      // nothing to follow
481 482
      continue;

483 484
    case MUT_ARR_PTRS_CLEAN:
    case MUT_ARR_PTRS_DIRTY:
485 486
    case MUT_ARR_PTRS_FROZEN_CLEAN:
    case MUT_ARR_PTRS_FROZEN_DIRTY:
487
      // follow everything
488
      {
489
          StgMutArrPtrs *a;
490

491 492 493 494 495
          a = (StgMutArrPtrs*)p;
          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
              thread((StgClosure **)p);
          }
          continue;
496 497
      }

498 499
    case SMALL_MUT_ARR_PTRS_CLEAN:
    case SMALL_MUT_ARR_PTRS_DIRTY:
500 501
    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
502
      // follow everything
503 504 505 506 507 508 509 510 511 512
      {
          StgSmallMutArrPtrs *a;

          a = (StgSmallMutArrPtrs*)p;
          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
              thread((StgClosure **)p);
          }
          continue;
      }

513 514 515 516 517 518
    case STACK:
    {
        StgStack *stack = (StgStack*)p;
        thread_stack(stack->sp, stack->stack + stack->stack_size);
        continue;
    }
519 520

    case AP_STACK:
521 522
        thread_AP_STACK((StgAP_STACK *)p);
        continue;
523 524

    case PAP:
525 526
        thread_PAP((StgPAP *)p);
        continue;
527

528 529 530 531
    case TREC_CHUNK:
    {
        StgWord i;
        StgTRecChunk *tc = (StgTRecChunk *)p;
532 533 534 535 536 537 538 539
        TRecEntry *e = &(tc -> entries[0]);
        thread_(&tc->prev_chunk);
        for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
          thread_(&e->tvar);
          thread(&e->expected_value);
          thread(&e->new_value);
        }
        continue;
540 541
    }

542 543 544 545 546 547
    default:
      barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
    }
  }
}

548 549
// ToDo: too big to inline
static /* STATIC_INLINE */ StgPtr
550
thread_obj (const StgInfoTable *info, StgPtr p)
551 552
{
    switch (info->type) {
553
    case THUNK_0_1:
554
        return p + sizeofW(StgThunk) + 1;
555

556 557
    case FUN_0_1:
    case CONSTR_0_1:
558 559
        return p + sizeofW(StgHeader) + 1;

560 561
    case FUN_1_0:
    case CONSTR_1_0:
562 563 564
        thread(&((StgClosure *)p)->payload[0]);
        return p + sizeofW(StgHeader) + 1;

565
    case THUNK_1_0:
566 567 568
        thread(&((StgThunk *)p)->payload[0]);
        return p + sizeofW(StgThunk) + 1;

569
    case THUNK_0_2:
570
        return p + sizeofW(StgThunk) + 2;
571

572 573
    case FUN_0_2:
    case CONSTR_0_2:
574 575
        return p + sizeofW(StgHeader) + 2;

576
    case THUNK_1_1:
577 578
        thread(&((StgThunk *)p)->payload[0]);
        return p + sizeofW(StgThunk) + 2;
579

580 581
    case FUN_1_1:
    case CONSTR_1_1:
582 583 584
        thread(&((StgClosure *)p)->payload[0]);
        return p + sizeofW(StgHeader) + 2;

585
    case THUNK_2_0:
586 587 588
        thread(&((StgThunk *)p)->payload[0]);
        thread(&((StgThunk *)p)->payload[1]);
        return p + sizeofW(StgThunk) + 2;
589

590 591
    case FUN_2_0:
    case CONSTR_2_0:
592 593 594 595
        thread(&((StgClosure *)p)->payload[0]);
        thread(&((StgClosure *)p)->payload[1]);
        return p + sizeofW(StgHeader) + 2;

596
    case BCO: {
597 598 599 600 601
        StgBCO *bco = (StgBCO *)p;
        thread_(&bco->instrs);
        thread_(&bco->literals);
        thread_(&bco->ptrs);
        return p + bco_sizeW(bco);
602 603
    }

604
    case THUNK:
605
    {
606 607 608 609 610 611 612 613
        StgPtr end;

        end = (P_)((StgThunk *)p)->payload +
            info->layout.payload.ptrs;
        for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
            thread((StgClosure **)p);
        }
        return p + info->layout.payload.nptrs;
614 615 616
    }

    case FUN:
617
    case CONSTR:
Simon Marlow's avatar
Simon Marlow committed
618
    case CONSTR_NOCAF:
619 620
    case PRIM:
    case MUT_PRIM:
621 622
    case MUT_VAR_CLEAN:
    case MUT_VAR_DIRTY:
623
    case TVAR:
624
    case BLACKHOLE:
625
    case BLOCKING_QUEUE:
626
    {
627 628 629 630 631 632 633 634
        StgPtr end;

        end = (P_)((StgClosure *)p)->payload +
            info->layout.payload.ptrs;
        for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
            thread((StgClosure **)p);
        }
        return p + info->layout.payload.nptrs;
635
    }
636

637 638
    case WEAK:
    {
639 640 641 642 643 644 645 646 647
        StgWeak *w = (StgWeak *)p;
        thread(&w->cfinalizers);
        thread(&w->key);
        thread(&w->value);
        thread(&w->finalizer);
        if (w->link != NULL) {
            thread_(&w->link);
        }
        return p + sizeofW(StgWeak);
648
    }
649

650 651
    case MVAR_CLEAN:
    case MVAR_DIRTY:
652 653 654 655 656 657
    {
        StgMVar *mvar = (StgMVar *)p;
        thread_(&mvar->head);
        thread_(&mvar->tail);
        thread(&mvar->value);
        return p + sizeofW(StgMVar);
658
    }
659

660
    case IND:
661 662
        thread(&((StgInd *)p)->indirectee);
        return p + sizeofW(StgInd);
663 664

    case THUNK_SELECTOR:
665 666 667 668
    {
        StgSelector *s = (StgSelector *)p;
        thread(&s->selectee);
        return p + THUNK_SELECTOR_sizeW();
669
    }
670

671
    case AP_STACK:
672 673
        return thread_AP_STACK((StgAP_STACK *)p);

674
    case PAP:
675
        return thread_PAP((StgPAP *)p);
676 677

    case AP:
678 679
        return thread_AP((StgAP *)p);

680
    case ARR_WORDS:
siddhanathan's avatar
siddhanathan committed
681
        return p + arr_words_sizeW((StgArrBytes *)p);
682

683 684
    case MUT_ARR_PTRS_CLEAN:
    case MUT_ARR_PTRS_DIRTY:
685 686
    case MUT_ARR_PTRS_FROZEN_CLEAN:
    case MUT_ARR_PTRS_FROZEN_DIRTY:
687
        // follow everything
688
    {
689 690 691
        StgMutArrPtrs *a;

        a = (StgMutArrPtrs *)p;
692 693 694
        for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
            thread((StgClosure **)p);
        }
695

696
        return (StgPtr)a + mut_arr_ptrs_sizeW(a);
697
    }
698 699 700

    case SMALL_MUT_ARR_PTRS_CLEAN:
    case SMALL_MUT_ARR_PTRS_DIRTY:
701 702
    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
703
        // follow everything
704 705 706 707
    {
        StgSmallMutArrPtrs *a;

        a = (StgSmallMutArrPtrs *)p;
708 709 710
        for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
            thread((StgClosure **)p);
        }
711

712
        return (StgPtr)a + small_mut_arr_ptrs_sizeW(a);
713
    }
714

715
    case TSO:
716 717
        return thread_TSO((StgTSO *)p);

718 719 720 721 722 723 724
    case STACK:
    {
        StgStack *stack = (StgStack*)p;
        thread_stack(stack->sp, stack->stack + stack->stack_size);
        return p + stack_sizeW(stack);
    }

725 726
    case TREC_CHUNK:
    {
727
        StgWord i;
728
        StgTRecChunk *tc = (StgTRecChunk *)p;
729 730 731 732 733 734 735 736
        TRecEntry *e = &(tc -> entries[0]);
        thread_(&tc->prev_chunk);
        for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
          thread_(&e->tvar);
          thread(&e->expected_value);
          thread(&e->new_value);
        }
        return p + sizeofW(StgTRecChunk);
737 738
    }

739
    default:
740 741
        barf("update_fwd: unknown/strange object  %d", (int)(info->type));
        return NULL;
742 743 744
    }
}

745 746 747 748 749
static void
update_fwd( bdescr *blocks )
{
    StgPtr p;
    bdescr *bd;
750
    const StgInfoTable *info;
751 752 753 754 755

    bd = blocks;

    // cycle through all the blocks in the step
    for (; bd != NULL; bd = bd->link) {
756 757 758 759 760 761 762 763
        p = bd->start;

        // linearly scan the objects in this block
        while (p < bd->free) {
            ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
            info = get_itbl((StgClosure *)p);
            p = thread_obj(info, p);
        }
764
    }
765
}
766 767 768 769 770

static void
update_fwd_compact( bdescr *blocks )
{
    StgPtr p, q, free;
771
#if 0
772
    StgWord m;
773
#endif
774 775
    bdescr *bd, *free_bd;
    StgInfoTable *info;
776
    StgWord size;
777
    StgWord iptr;
778 779 780 781 782 783 784

    bd = blocks;
    free_bd = blocks;
    free = free_bd->start;

    // cycle through all the blocks in the step
    for (; bd != NULL; bd = bd->link) {
785
        p = bd->start;
786

787
        while (p < bd->free ) {
788

789 790 791 792 793 794
            while ( p < bd->free && !is_marked(p,bd) ) {
                p++;
            }
            if (p >= bd->free) {
                break;
            }
795 796 797

#if 0
    next:
798 799 800 801 802 803 804 805 806 807 808 809 810 811
        m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
        m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));

        while ( p < bd->free ) {

            if ((m & 1) == 0) {
                m >>= 1;
                p++;
                if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
                    goto next;
                } else {
                    continue;
                }
            }
812 813
#endif

814 815 816 817 818
            // Problem: we need to know the destination for this cell
            // in order to unthread its info pointer.  But we can't
            // know the destination without the size, because we may
            // spill into the next block.  So we have to run down the
            // threaded list and get the info ptr first.
819 820 821 822
            //
            // ToDo: one possible avenue of attack is to use the fact
            // that if (p&BLOCK_MASK) >= (free&BLOCK_MASK), then we
            // definitely have enough room.  Also see bug #1147.
823
            iptr = get_threaded_info(p);
824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844
            info = INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_CLOSURE((StgClosure *)iptr));

            q = p;

            p = thread_obj(info, p);

            size = p - q;
            if (free + size > free_bd->start + BLOCK_SIZE_W) {
                // set the next bit in the bitmap to indicate that
                // this object needs to be pushed into the next
                // block.  This saves us having to run down the
                // threaded info pointer list twice during the next pass.
                mark(q+1,bd);
                free_bd = free_bd->link;
                free = free_bd->start;
            } else {
                ASSERT(!is_marked(q+1,bd));
            }

            unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
            free += size;
845
#if 0
846
            goto next;
847
#endif
848
        }
849 850 851
    }
}

852
static W_
853
update_bkwd_compact( generation *gen )
854 855
{
    StgPtr p, free;
856
#if 0
857
    StgWord m;
858
#endif
859
    bdescr *bd, *free_bd;
860
    const StgInfoTable *info;
861 862
    StgWord size;
    W_ free_blocks;
863
    StgWord iptr;
864

865
    bd = free_bd = gen->old_blocks;
866 867 868 869 870
    free = free_bd->start;
    free_blocks = 1;

    // cycle through all the blocks in the step
    for (; bd != NULL; bd = bd->link) {
871
        p = bd->start;
872

873
        while (p < bd->free ) {
874

875 876 877 878 879 880
            while ( p < bd->free && !is_marked(p,bd) ) {
                p++;
            }
            if (p >= bd->free) {
                break;
            }
881 882 883

#if 0
    next:
884 885 886 887 888 889 890 891 892 893 894 895 896 897
        m = * ((StgPtr)bd->u.bitmap + ((p - bd->start) / (BITS_IN(StgWord))));
        m >>= ((p - bd->start) & (BITS_IN(StgWord) - 1));

        while ( p < bd->free ) {

            if ((m & 1) == 0) {
                m >>= 1;
                p++;
                if (((StgWord)p & (sizeof(W_) * BITS_IN(StgWord))) == 0) {
                    goto next;
                } else {
                    continue;
                }
            }
898 899
#endif

900 901 902 903 904 905 906
            if (is_marked(p+1,bd)) {
                // don't forget to update the free ptr in the block desc.
                free_bd->free = free;
                free_bd = free_bd->link;
                free = free_bd->start;
                free_blocks++;
            }
907

908
            iptr = get_threaded_info(p);
909 910 911 912
            unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
            ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
            info = get_itbl((StgClosure *)p);
            size = closure_sizeW_((StgClosure *)p,info);
913

914 915 916
            if (free != p) {
                move(free,p,size);
            }
917

918
            // relocate TSOs
919 920
            if (info->type == STACK) {
                move_STACK((StgStack *)p, (StgStack *)free);
921
            }
922

923 924
            free += size;
            p += size;
925
#if 0
926
            goto next;
927
#endif
928
        }
929 930 931 932 933
    }

    // free the remaining blocks and count what's left.
    free_bd->free = free;
    if (free_bd->link != NULL) {
934 935
        freeChain(free_bd->link);
        free_bd->link = NULL;
936 937 938
    }

    return free_blocks;
939 940
}

941
void
942
compact(StgClosure *static_objects)
943
{
944
    W_ n, g, blocks;
945
    generation *gen;
946 947

    // 1. thread the roots
948
    markCapabilities((evac_fn)thread_root, NULL);
949

Simon Marlow's avatar
Simon Marlow committed
950 951
    markScheduler((evac_fn)thread_root, NULL);

952
    // the weak pointer lists...
953
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
954
        if (generations[g].weak_ptr_list != NULL) {
955
            thread((void *)&generations[g].weak_ptr_list);
956
        }
957
    }
958 959

    if (dead_weak_ptr_list != NULL) {
960
        thread((void *)&dead_weak_ptr_list); // tmp
961 962
    }

963 964
    // mutable lists
    for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
965 966
        bdescr *bd;
        StgPtr p;
967
        for (n = 0; n < n_capabilities; n++) {
968
            for (bd = capabilities[n]->mut_lists[g];
969 970 971 972 973 974
                 bd != NULL; bd = bd->link) {
                for (p = bd->start; p < bd->free; p++) {
                    thread((StgClosure **)p);
                }
            }
        }
975
    }
976 977

    // the global thread list
978 979
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
        thread((void *)&generations[g].threads);
980
    }
981

982
    // any threads resurrected during this GC
983
    thread((void *)&resurrected_threads);
984

985
    // the task list
986
    {
987
        Task *task;
988
        InCall *incall;
989
        for (task = all_tasks; task != NULL; task = task->all_next) {
990
            for (incall = task->incall; incall != NULL;
991 992 993 994 995
                 incall = incall->prev_stack) {
                if (incall->tso) {
                    thread_(&incall->tso);
                }
            }
996
        }
997 998
    }

999
    // the static objects
1000
    thread_static(static_objects /* ToDo: ok? */);
1001 1002

    // the stable pointer table
1003
    threadStableTables((evac_fn)thread_root, NULL);
1004

1005
    // the CAF list (used by GHCi)
1006
    markCAFs((evac_fn)thread_root, NULL);
1007

1008 1009
    // 2. update forward ptrs
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1010 1011 1012 1013
        gen = &generations[g];
        debugTrace(DEBUG_gc, "update_fwd:  %d", g);

        update_fwd(gen->blocks);
Simon Marlow's avatar
Simon Marlow committed
1014 1015 1016 1017
        for (n = 0; n < n_capabilities; n++) {
            update_fwd(gc_threads[n]->gens[g].todo_bd);
            update_fwd(gc_threads[n]->gens[g].part_list);
        }
1018 1019 1020 1021
        update_fwd_large(gen->scavenged_large_objects);
        if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) {
            debugTrace(DEBUG_gc, "update_fwd:  %d (compact)", g);
            update_fwd_compact(gen->old_blocks);
1022
        }
1023 1024 1025
    }

    // 3. update backward ptrs
1026 1027
    gen = oldest_gen;
    if (gen->old_blocks != NULL) {
1028 1029 1030 1031 1032
        blocks = update_bkwd_compact(gen);
        debugTrace(DEBUG_gc,
                   "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
                   gen->no, gen->n_old_blocks, blocks);
        gen->n_old_blocks = blocks;
1033 1034
    }
}