Compact.c 26.5 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
 *   https://gitlab.haskell.org/ghc/ghc/wikis/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
#include "Weak.h"
#include "MarkWeak.h"
David Feuer's avatar
David Feuer committed
28 29
#include "StablePtr.h"
#include "StableName.h"
30

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

37
/* ----------------------------------------------------------------------------
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
   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.

53 54 55 56 57 58 59
   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.

60
   Our solution is as follows:
61 62 63 64 65 66 67 68 69 70 71
     - 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).
   ------------------------------------------------------------------------- */
72

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

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

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

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

91
        if (bd->flags & BF_MARKED)
Simon Marlow's avatar
Simon Marlow committed
92
        {
93 94 95
            iptr = *q;
            switch (GET_CLOSURE_TAG((StgClosure *)iptr))
            {
96
            case 0:
97 98 99 100 101 102 103 104 105 106 107 108 109
                // 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;
            }
        }
110 111 112
    }
}

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

119 120 121 122
// 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
123
STATIC_INLINE void
124
unthread( StgPtr p, StgWord free )
125
{
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
    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");
150 151 152
    }
}

153 154 155 156 157
// 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
158 159
get_threaded_info( StgPtr p )
{
160
    StgWord q;
161

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

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

// 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
187
STATIC_INLINE void
188
move(StgPtr to, StgPtr from, StgWord size)
189 190
{
    for(; size > 0; --size) {
191
        *to++ = *from++;
192 193 194 195 196 197 198 199 200
    }
}

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

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

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

212
    case THUNK_STATIC:
213 214
        p = *THUNK_STATIC_LINK(p);
        continue;
215
    case FUN_STATIC:
216
        p = *STATIC_LINK(info,p);
217
        continue;
Simon Marlow's avatar
Simon Marlow committed
218 219 220 221 222 223 224
    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:
225 226 227
        p = *STATIC_LINK(info,p);
        continue;

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

  }
}

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

    b = 0;
    bitmap = large_bitmap->bitmap[b];
    for (i = 0; i < size; ) {
244 245 246 247 248 249 250 251 252 253 254
        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;
        }
255 256 257
    }
}

258 259 260 261 262 263 264 265 266 267 268 269 270 271
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
272
STATIC_INLINE StgPtr
273 274 275 276
thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
{
    StgPtr p;
    StgWord bitmap;
277
    StgWord size;
278 279

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

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

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

309 310
    while (p < stack_end) {

311 312 313 314 315 316 317 318
        // *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) {

319
            // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
320 321 322
        case CATCH_RETRY_FRAME:
        case CATCH_STM_FRAME:
        case ATOMICALLY_FRAME:
323
        case UPDATE_FRAME:
324 325 326
        case UNDERFLOW_FRAME:
        case STOP_FRAME:
        case CATCH_FRAME:
327 328 329 330 331 332
        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.
333
            p = thread_small_bitmap(p, size, bitmap);
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 362
            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 *)
363
                           get_threaded_info((StgPtr)ret_fun->fun)));
364 365 366 367 368 369 370 371 372 373
                 // *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));
        }
374 375 376
    }
}

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

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

388
    p = (StgPtr)payload;
389

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

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

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

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

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

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

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

455
    thread_(&tso->trec);
456

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


462 463 464 465 466 467 468 469
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
470 471 472 473
    // nothing to do in a pinned block; it might not even have an object
    // at the beginning.
    if (bd->flags & BF_PINNED) continue;

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

    switch (info->type) {

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

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

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

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

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

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

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

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

529 530 531 532
    case TREC_CHUNK:
    {
        StgWord i;
        StgTRecChunk *tc = (StgTRecChunk *)p;
533 534 535 536 537 538 539 540
        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;
541 542
    }

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

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

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

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

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

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

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

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

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

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

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

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

605
    case THUNK:
606
    {
607 608 609 610 611 612 613 614
        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;
615 616 617
    }

    case FUN:
618
    case CONSTR:
Simon Marlow's avatar
Simon Marlow committed
619
    case CONSTR_NOCAF:
620 621
    case PRIM:
    case MUT_PRIM:
622 623
    case MUT_VAR_CLEAN:
    case MUT_VAR_DIRTY:
624
    case TVAR:
625
    case BLACKHOLE:
626
    case BLOCKING_QUEUE:
627
    {
628 629 630 631 632 633 634 635
        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;
636
    }
637

638 639
    case WEAK:
    {
640 641 642 643 644 645 646 647 648
        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);
649
    }
650

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

726 727
    case TREC_CHUNK:
    {
728
        StgWord i;
729
        StgTRecChunk *tc = (StgTRecChunk *)p;
730 731 732 733 734 735 736 737
        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);
738 739
    }

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

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

    bd = blocks;

    // cycle through all the blocks in the step
    for (; bd != NULL; bd = bd->link) {
757 758 759 760 761 762 763 764
        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);
        }
765
    }
766
}
767 768 769 770 771

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

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

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

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

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

#if 0
    next:
799 800 801 802 803 804 805 806 807 808 809 810 811 812
        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;
                }
            }
813 814
#endif

815 816 817 818 819
            // 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.
820 821 822 823
            //
            // 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.
824
            iptr = get_threaded_info(p);
825 826 827 828 829 830 831 832
            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) {
833 834 835 836 837
                // 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. See Note [Mark bits in mark-compact collector] in
                // Compact.h.
838 839 840 841 842 843 844 845 846
                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;
847
#if 0
848
            goto next;
849
#endif
850
        }
851 852 853
    }
}

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

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

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

875
        while (p < bd->free ) {
876

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

#if 0
    next:
886 887 888 889 890 891 892 893 894 895 896 897 898 899
        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;
                }
            }
900 901
#endif

902 903 904 905 906 907 908
            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++;
            }
909

910
            iptr = get_threaded_info(p);
911 912 913 914
            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);
915

916 917 918
            if (free != p) {
                move(free,p,size);
            }
919

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

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

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

    return free_blocks;
941 942
}

943
void
Ben Gamari's avatar
Ben Gamari committed
944 945 946
compact(StgClosure *static_objects,
        StgWeak **dead_weak_ptr_list,
        StgTSO **resurrected_threads)
947
{
948
    W_ n, g, blocks;
949
    generation *gen;
950 951

    // 1. thread the roots
952
    markCapabilities((evac_fn)thread_root, NULL);
953

Simon Marlow's avatar
Simon Marlow committed
954 955
    markScheduler((evac_fn)thread_root, NULL);

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

    if (dead_weak_ptr_list != NULL) {
Ben Gamari's avatar
Ben Gamari committed
964
        thread((void *)dead_weak_ptr_list); // tmp
965 966
    }

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

    // the global thread list
982 983
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
        thread((void *)&generations[g].threads);
984
    }
985

986
    // any threads resurrected during this GC
Ben Gamari's avatar
Ben Gamari committed
987
    thread((void *)resurrected_threads);
988

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

1003
    // the static objects
1004
    thread_static(static_objects /* ToDo: ok? */);
1005 1006

    // the stable pointer table
David Feuer's avatar
David Feuer committed
1007 1008 1009 1010
    threadStablePtrTable((evac_fn)thread_root, NULL);

    // the stable name table
    threadStableNameTable((evac_fn)thread_root, NULL);
1011

1012
    // the CAF list (used by GHCi)
1013
    markCAFs((evac_fn)thread_root, NULL);
1014

1015 1016
    // 2. update forward ptrs
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1017 1018 1019 1020
        gen = &generations[g];
        debugTrace(DEBUG_gc, "update_fwd:  %d", g);

        update_fwd(gen->blocks);
Simon Marlow's avatar
Simon Marlow committed
1021 1022 1023 1024
        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);
        }
1025 1026 1027 1028
        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);
1029
        }
1030 1031 1032
    }

    // 3. update backward ptrs
1033 1034
    gen = oldest_gen;
    if (gen->old_blocks != NULL) {
1035 1036 1037 1038 1039
        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;
1040 1041
    }
}