Compact.c 24.6 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"
16

Simon Marlow's avatar
Simon Marlow committed
17
#include "GCThread.h"
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"
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
32
#if defined(DEBUG)
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

73 74 75 76 77 78 79 80 81 82 83 84
STATIC_INLINE W_
UNTAG_PTR(W_ p)
{
    return p & ~TAG_MASK;
}

STATIC_INLINE W_
GET_PTR_TAG(W_ p)
{
    return p & TAG_MASK;
}

85
STATIC_INLINE void
86
thread (StgClosure **p)
87
{
88 89
    StgClosure *q0  = *p;
    P_ q = (P_)UNTAG_CLOSURE(q0);
90

91 92 93
    // It doesn't look like a closure at the moment, because the info
    // ptr is possibly threaded:
    // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
94

95
    if (HEAP_ALLOCED(q)) {
96
        bdescr *bd = Bdescr(q);
97

98
        if (bd->flags & BF_MARKED)
Simon Marlow's avatar
Simon Marlow committed
99
        {
100 101
            W_ iptr = *q;
            switch (GET_PTR_TAG(iptr))
102
            {
103
            case 0:
104 105
                // this is the info pointer; we are creating a new chain.
                // save the original tag at the end of the chain.
106 107
                *p = (StgClosure *)((W_)iptr + GET_CLOSURE_TAG(q0));
                *q = (W_)p + 1;
108 109 110 111 112
                break;
            case 1:
            case 2:
                // this is a chain of length 1 or more
                *p = (StgClosure *)iptr;
113
                *q = (W_)p + 2;
114 115 116
                break;
            }
        }
117 118 119
    }
}

120 121 122 123 124 125
static void
thread_root (void *user STG_UNUSED, StgClosure **p)
{
    thread(p);
}

126 127 128 129
// 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); }

130
STATIC_INLINE void
131
unthread( P_ p, W_ free )
132
{
133
    W_ q = *p;
134
loop:
135
    switch (GET_PTR_TAG(q))
136 137 138 139 140
    {
    case 0:
        // nothing to do; the chain is length zero
        return;
    case 1:
141 142 143
    {
        P_ q0 = (P_)(q-1);
        W_ r = *q0;  // r is the info ptr, tagged with the pointer-tag
144
        *q0 = free;
145
        *p = (W_)UNTAG_PTR(r);
146
        return;
147
    }
148
    case 2:
149 150 151
    {
        P_ q0 = (P_)(q-2);
        W_ r = *q0;
152 153 154
        *q0 = free;
        q = r;
        goto loop;
155
    }
156 157
    default:
        barf("unthread");
158 159 160
    }
}

161 162 163 164
// 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().
165 166
STATIC_INLINE W_
get_threaded_info( P_ p )
167
{
168
    W_ q = (W_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
169

170
loop:
171
    switch (GET_PTR_TAG(q))
172 173 174 175 176 177
    {
    case 0:
        ASSERT(LOOKS_LIKE_INFO_PTR(q));
        return q;
    case 1:
    {
178 179
        W_ r = *(P_)(q-1);
        ASSERT(LOOKS_LIKE_INFO_PTR((W_)UNTAG_CONST_CLOSURE((StgClosure *)r)));
180 181 182
        return r;
    }
    case 2:
183
        q = *(P_)(q-2);
184 185 186
        goto loop;
    default:
        barf("get_threaded_info");
187 188 189 190 191
    }
}

// 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.
192
STATIC_INLINE void
193
move(P_ to, P_ from, W_ size)
194 195
{
    for(; size > 0; --size) {
196
        *to++ = *from++;
197 198 199 200 201 202 203
    }
}

static void
thread_static( StgClosure* p )
{
  // keep going until we've threaded all the objects on the linked
204
  // list...
205 206
  while (p != END_OF_STATIC_OBJECT_LIST) {
    p = UNTAG_STATIC_LIST_PTR(p);
207
    const StgInfoTable *info = get_itbl(p);
208
    switch (info->type) {
209

210
    case IND_STATIC:
211 212 213 214
        thread(&((StgInd *)p)->indirectee);
        p = *IND_STATIC_LINK(p);
        continue;

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

231
    default:
232
        barf("thread_static: strange closure %d", (int)(info->type));
233 234 235 236 237
    }

  }
}

238
STATIC_INLINE void
239
thread_large_bitmap( P_ p, StgLargeBitmap *large_bitmap, W_ size )
240
{
241 242 243
    W_ b = 0;
    W_ bitmap = large_bitmap->bitmap[b];
    for (W_ 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
STATIC_INLINE P_
thread_small_bitmap (P_ p, W_ size, W_ bitmap)
260 261 262 263 264 265 266 267 268 269 270 271
{
    while (size > 0) {
        if ((bitmap & 1) == 0) {
            thread((StgClosure **)p);
        }
        p++;
        bitmap = bitmap >> 1;
        size--;
    }
    return p;
}

272
STATIC_INLINE P_
273 274
thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
{
275 276
    W_ bitmap;
    W_ size;
277

278
    P_ p = (P_)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
static void
300
thread_stack(P_ p, P_ stack_end)
301 302
{
    // highly similar to scavenge_stack, but we do pointer threading here.
303

304 305
    while (p < stack_end) {

306 307 308 309
        // *p must be the info pointer of an activation
        // record.  All activation records have 'bitmap' style layout
        // info.
        //
310
        const StgRetInfoTable *info  = get_ret_itbl((StgClosure *)p);
311 312 313

        switch (info->i.type) {

314
            // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
315 316 317
        case CATCH_RETRY_FRAME:
        case CATCH_STM_FRAME:
        case ATOMICALLY_FRAME:
318
        case UPDATE_FRAME:
319 320 321
        case UNDERFLOW_FRAME:
        case STOP_FRAME:
        case CATCH_FRAME:
322
        case RET_SMALL:
323 324 325
        {
            W_ bitmap = BITMAP_BITS(info->i.layout.bitmap);
            W_ size   = BITMAP_SIZE(info->i.layout.bitmap);
326 327 328
            p++;
            // NOTE: the payload starts immediately after the info-ptr, we
            // don't have an StgHeader in the same sense as a heap closure.
329
            p = thread_small_bitmap(p, size, bitmap);
330
            continue;
331
        }
332 333 334

        case RET_BCO: {
            p++;
335
            StgBCO *bco = (StgBCO *)*p;
336 337
            thread((StgClosure **)p);
            p++;
338
            W_ size = BCO_BITMAP_SIZE(bco);
339 340 341 342 343 344 345 346
            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++;
347
            W_ size = GET_LARGE_BITMAP(&info->i)->size;
348 349 350 351 352 353 354
            thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
            p += size;
            continue;

        case RET_FUN:
        {
            StgRetFun *ret_fun = (StgRetFun *)p;
355 356 357
            StgFunInfoTable *fun_info =
                FUN_INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_PTR(
                           get_threaded_info((P_)ret_fun->fun)));
358 359 360 361 362 363 364 365 366 367
                 // *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));
        }
368 369 370
    }
}

371 372
STATIC_INLINE P_
thread_PAP_payload (StgClosure *fun, StgClosure **payload, W_ size)
373
{
374 375
    StgFunInfoTable *fun_info =
        FUN_INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_PTR(get_threaded_info((P_)fun)));
376 377
    ASSERT(fun_info->i.type != PAP);

378
    P_ p = (P_)payload;
379

380
    W_ bitmap;
381
    switch (fun_info->f.fun_type) {
382
    case ARG_GEN:
383 384
        bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
        goto small_bitmap;
385
    case ARG_GEN_BIG:
386 387 388
        thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
        p += size;
        break;
389
    case ARG_BCO:
390
        thread_large_bitmap((P_)payload, BCO_BITMAP(fun), size);
391 392
        p += size;
        break;
393
    default:
394
        bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
395
    small_bitmap:
396
        p = thread_small_bitmap(p, size, bitmap);
397
        break;
398
    }
399

400 401 402
    return p;
}

403
STATIC_INLINE P_
404 405
thread_PAP (StgPAP *pap)
{
406
    P_ p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
407
    thread(&pap->fun);
408 409
    return p;
}
410

411
STATIC_INLINE P_
412 413
thread_AP (StgAP *ap)
{
414
    P_ p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
415
    thread(&ap->fun);
416
    return p;
417
}
418

419
STATIC_INLINE P_
420 421
thread_AP_STACK (StgAP_STACK *ap)
{
422
    thread(&ap->fun);
423 424 425 426
    thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
    return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
}

427
static P_
428 429
thread_TSO (StgTSO *tso)
{
430
    thread_(&tso->_link);
431
    thread_(&tso->global_link);
432 433

    if (   tso->why_blocked == BlockedOnMVar
434
        || tso->why_blocked == BlockedOnMVarRead
435 436
        || tso->why_blocked == BlockedOnBlackHole
        || tso->why_blocked == BlockedOnMsgThrowTo
437 438
        || tso->why_blocked == NotBlocked
        ) {
439
        thread_(&tso->block_info.closure);
440
    }
441
    thread_(&tso->blocked_exceptions);
442
    thread_(&tso->bq);
443

444
    thread_(&tso->trec);
445

446
    thread_(&tso->stackobj);
447
    return (P_)tso + sizeofW(StgTSO);
448 449 450
}


451 452 453 454 455
static void
update_fwd_large( bdescr *bd )
{
  for (; bd != NULL; bd = bd->link) {

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

460 461
    P_ p = bd->start;
    const StgInfoTable *info = get_itbl((StgClosure *)p);
462 463 464 465

    switch (info->type) {

    case ARR_WORDS:
gcampax's avatar
gcampax committed
466
    case COMPACT_NFDATA:
467
      // nothing to follow
468 469
      continue;

470 471
    case MUT_ARR_PTRS_CLEAN:
    case MUT_ARR_PTRS_DIRTY:
472 473
    case MUT_ARR_PTRS_FROZEN_CLEAN:
    case MUT_ARR_PTRS_FROZEN_DIRTY:
474
      // follow everything
475
      {
476
          StgMutArrPtrs *a;
477

478 479 480 481 482
          a = (StgMutArrPtrs*)p;
          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
              thread((StgClosure **)p);
          }
          continue;
483 484
      }

485 486
    case SMALL_MUT_ARR_PTRS_CLEAN:
    case SMALL_MUT_ARR_PTRS_DIRTY:
487 488
    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
489
      // follow everything
490
      {
491
          StgSmallMutArrPtrs *a = (StgSmallMutArrPtrs*)p;
492 493 494 495 496 497
          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
              thread((StgClosure **)p);
          }
          continue;
      }

498 499 500 501 502 503
    case STACK:
    {
        StgStack *stack = (StgStack*)p;
        thread_stack(stack->sp, stack->stack + stack->stack_size);
        continue;
    }
504 505

    case AP_STACK:
506 507
        thread_AP_STACK((StgAP_STACK *)p);
        continue;
508 509

    case PAP:
510 511
        thread_PAP((StgPAP *)p);
        continue;
512

513 514 515
    case TREC_CHUNK:
    {
        StgTRecChunk *tc = (StgTRecChunk *)p;
516 517
        TRecEntry *e = &(tc -> entries[0]);
        thread_(&tc->prev_chunk);
518
        for (W_ i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
519 520 521 522 523
          thread_(&e->tvar);
          thread(&e->expected_value);
          thread(&e->new_value);
        }
        continue;
524 525
    }

526 527 528 529 530 531
    default:
      barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
    }
  }
}

532
// ToDo: too big to inline
533 534
static /* STATIC_INLINE */ P_
thread_obj (const StgInfoTable *info, P_ p)
535 536
{
    switch (info->type) {
537
    case THUNK_0_1:
538
        return p + sizeofW(StgThunk) + 1;
539

540 541
    case FUN_0_1:
    case CONSTR_0_1:
542 543
        return p + sizeofW(StgHeader) + 1;

544 545
    case FUN_1_0:
    case CONSTR_1_0:
546 547 548
        thread(&((StgClosure *)p)->payload[0]);
        return p + sizeofW(StgHeader) + 1;

549
    case THUNK_1_0:
550 551 552
        thread(&((StgThunk *)p)->payload[0]);
        return p + sizeofW(StgThunk) + 1;

553
    case THUNK_0_2:
554
        return p + sizeofW(StgThunk) + 2;
555

556 557
    case FUN_0_2:
    case CONSTR_0_2:
558 559
        return p + sizeofW(StgHeader) + 2;

560
    case THUNK_1_1:
561 562
        thread(&((StgThunk *)p)->payload[0]);
        return p + sizeofW(StgThunk) + 2;
563

564 565
    case FUN_1_1:
    case CONSTR_1_1:
566 567 568
        thread(&((StgClosure *)p)->payload[0]);
        return p + sizeofW(StgHeader) + 2;

569
    case THUNK_2_0:
570 571 572
        thread(&((StgThunk *)p)->payload[0]);
        thread(&((StgThunk *)p)->payload[1]);
        return p + sizeofW(StgThunk) + 2;
573

574 575
    case FUN_2_0:
    case CONSTR_2_0:
576 577 578 579
        thread(&((StgClosure *)p)->payload[0]);
        thread(&((StgClosure *)p)->payload[1]);
        return p + sizeofW(StgHeader) + 2;

580
    case BCO: {
581 582 583 584 585
        StgBCO *bco = (StgBCO *)p;
        thread_(&bco->instrs);
        thread_(&bco->literals);
        thread_(&bco->ptrs);
        return p + bco_sizeW(bco);
586 587
    }

588
    case THUNK:
589
    {
590
        P_ end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
591 592 593 594
        for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
            thread((StgClosure **)p);
        }
        return p + info->layout.payload.nptrs;
595 596 597
    }

    case FUN:
598
    case CONSTR:
Simon Marlow's avatar
Simon Marlow committed
599
    case CONSTR_NOCAF:
600 601
    case PRIM:
    case MUT_PRIM:
602 603
    case MUT_VAR_CLEAN:
    case MUT_VAR_DIRTY:
604
    case TVAR:
605
    case BLACKHOLE:
606
    case BLOCKING_QUEUE:
607
    {
608
        P_ end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
609 610 611 612
        for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
            thread((StgClosure **)p);
        }
        return p + info->layout.payload.nptrs;
613
    }
614

615 616
    case WEAK:
    {
617 618 619 620 621 622 623 624 625
        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);
626
    }
627

628 629
    case MVAR_CLEAN:
    case MVAR_DIRTY:
630 631 632 633 634 635
    {
        StgMVar *mvar = (StgMVar *)p;
        thread_(&mvar->head);
        thread_(&mvar->tail);
        thread(&mvar->value);
        return p + sizeofW(StgMVar);
636
    }
637

638
    case IND:
639 640
        thread(&((StgInd *)p)->indirectee);
        return p + sizeofW(StgInd);
641 642

    case THUNK_SELECTOR:
643 644 645 646
    {
        StgSelector *s = (StgSelector *)p;
        thread(&s->selectee);
        return p + THUNK_SELECTOR_sizeW();
647
    }
648

649
    case AP_STACK:
650 651
        return thread_AP_STACK((StgAP_STACK *)p);

652
    case PAP:
653
        return thread_PAP((StgPAP *)p);
654 655

    case AP:
656 657
        return thread_AP((StgAP *)p);

658
    case ARR_WORDS:
659
        return p + arr_words_sizeW((StgArrBytes *)p);
660

661 662
    case MUT_ARR_PTRS_CLEAN:
    case MUT_ARR_PTRS_DIRTY:
663 664
    case MUT_ARR_PTRS_FROZEN_CLEAN:
    case MUT_ARR_PTRS_FROZEN_DIRTY:
665
        // follow everything
666
    {
667
        StgMutArrPtrs *a = (StgMutArrPtrs *)p;
668 669 670
        for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
            thread((StgClosure **)p);
        }
671

672
        return (P_)a + mut_arr_ptrs_sizeW(a);
673
    }
674 675 676

    case SMALL_MUT_ARR_PTRS_CLEAN:
    case SMALL_MUT_ARR_PTRS_DIRTY:
677 678
    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
679
        // follow everything
680
    {
681
        StgSmallMutArrPtrs *a = (StgSmallMutArrPtrs *)p;
682 683 684
        for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
            thread((StgClosure **)p);
        }
685

686
        return (P_)a + small_mut_arr_ptrs_sizeW(a);
687
    }
688

689
    case TSO:
690 691
        return thread_TSO((StgTSO *)p);

692 693 694 695 696 697 698
    case STACK:
    {
        StgStack *stack = (StgStack*)p;
        thread_stack(stack->sp, stack->stack + stack->stack_size);
        return p + stack_sizeW(stack);
    }

699 700 701
    case TREC_CHUNK:
    {
        StgTRecChunk *tc = (StgTRecChunk *)p;
702 703
        TRecEntry *e = &(tc -> entries[0]);
        thread_(&tc->prev_chunk);
704
        for (W_ i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
705 706 707 708 709
          thread_(&e->tvar);
          thread(&e->expected_value);
          thread(&e->new_value);
        }
        return p + sizeofW(StgTRecChunk);
710 711
    }

712
    default:
713 714
        barf("update_fwd: unknown/strange object  %d", (int)(info->type));
        return NULL;
715 716 717
    }
}

718 719 720
static void
update_fwd( bdescr *blocks )
{
721
    bdescr *bd = blocks;
722 723 724

    // cycle through all the blocks in the step
    for (; bd != NULL; bd = bd->link) {
725
        P_ p = bd->start;
726 727 728 729

        // linearly scan the objects in this block
        while (p < bd->free) {
            ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
730
            const StgInfoTable *info = get_itbl((StgClosure *)p);
731 732
            p = thread_obj(info, p);
        }
733
    }
734
}
735 736 737 738

static void
update_fwd_compact( bdescr *blocks )
{
739 740 741
    bdescr *bd = blocks;
    bdescr *free_bd = blocks;
    P_ free = free_bd->start;
742 743 744

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

747
        while (p < bd->free ) {
748

749 750 751 752 753 754
            while ( p < bd->free && !is_marked(p,bd) ) {
                p++;
            }
            if (p >= bd->free) {
                break;
            }
755

756 757 758 759 760
            // 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.
761 762 763 764
            //
            // 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.
765 766
            W_ iptr = get_threaded_info(p);
            StgInfoTable *info = INFO_PTR_TO_STRUCT((StgInfoTable *)UNTAG_PTR(iptr));
767

768
            P_ q = p;
769 770 771

            p = thread_obj(info, p);

772
            W_ size = p - q;
773
            if (free + size > free_bd->start + BLOCK_SIZE_W) {
774 775 776 777 778
                // 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.
779 780 781 782 783 784 785
                mark(q+1,bd);
                free_bd = free_bd->link;
                free = free_bd->start;
            } else {
                ASSERT(!is_marked(q+1,bd));
            }

786
            unthread(q,(W_)free + GET_PTR_TAG(iptr));
787 788
            free += size;
        }
789 790 791
    }
}

792
static W_
793
update_bkwd_compact( generation *gen )
794 795
{
    bdescr *bd, *free_bd;
796
    bd = free_bd = gen->old_blocks;
797 798 799

    P_ free = free_bd->start;
    W_ free_blocks = 1;
800 801 802

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

805
        while (p < bd->free ) {
806

807 808 809 810 811 812
            while ( p < bd->free && !is_marked(p,bd) ) {
                p++;
            }
            if (p >= bd->free) {
                break;
            }
813

814 815 816 817 818 819 820
            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++;
            }
821

822 823 824 825 826
            W_ iptr = get_threaded_info(p);
            unthread(p, (W_)free + GET_PTR_TAG(iptr));
            ASSERT(LOOKS_LIKE_INFO_PTR((W_)((StgClosure *)p)->header.info));
            const StgInfoTable *info = get_itbl((StgClosure *)p);
            W_ size = closure_sizeW_((StgClosure *)p,info);
827

828 829 830
            if (free != p) {
                move(free,p,size);
            }
831

832
            // relocate TSOs
833 834
            if (info->type == STACK) {
                move_STACK((StgStack *)p, (StgStack *)free);
835
            }
836

837 838 839
            free += size;
            p += size;
        }
840 841 842 843 844
    }

    // free the remaining blocks and count what's left.
    free_bd->free = free;
    if (free_bd->link != NULL) {
845 846
        freeChain(free_bd->link);
        free_bd->link = NULL;
847 848 849
    }

    return free_blocks;
850 851
}

852
void
Ben Gamari's avatar
Ben Gamari committed
853 854 855
compact(StgClosure *static_objects,
        StgWeak **dead_weak_ptr_list,
        StgTSO **resurrected_threads)
856 857
{
    // 1. thread the roots
858
    markCapabilities((evac_fn)thread_root, NULL);
859

Simon Marlow's avatar
Simon Marlow committed
860 861
    markScheduler((evac_fn)thread_root, NULL);

862
    // the weak pointer lists...
863
    for (W_ g = 0; g < RtsFlags.GcFlags.generations; g++) {
864
        if (generations[g].weak_ptr_list != NULL) {
865
            thread((void *)&generations[g].weak_ptr_list);
866
        }
867
    }
868 869

    if (dead_weak_ptr_list != NULL) {
Ben Gamari's avatar
Ben Gamari committed
870
        thread((void *)dead_weak_ptr_list); // tmp
871 872
    }

873
    // mutable lists
874 875 876
    for (W_ g = 1; g < RtsFlags.GcFlags.generations; g++) {
        for (W_ n = 0; n < n_capabilities; n++) {
            for (bdescr *bd = capabilities[n]->mut_lists[g];
877
                 bd != NULL; bd = bd->link) {
878
                for (P_ p = bd->start; p < bd->free; p++) {
879 880 881 882
                    thread((StgClosure **)p);
                }
            }
        }
883
    }
884 885

    // the global thread list
886
    for (W_ g = 0; g < RtsFlags.GcFlags.generations; g++) {
887
        thread((void *)&generations[g].threads);
888
    }
889

890
    // any threads resurrected during this GC
Ben Gamari's avatar
Ben Gamari committed
891
    thread((void *)resurrected_threads);
892

893
    // the task list
894 895 896 897 898
    for (Task *task = all_tasks; task != NULL; task = task->all_next) {
        for (InCall *incall = task->incall; incall != NULL;
             incall = incall->prev_stack) {
            if (incall->tso) {
                thread_(&incall->tso);
899
            }
900
        }
901 902
    }

903
    // the static objects
904
    thread_static(static_objects /* ToDo: ok? */);
905 906

    // the stable pointer table
David Feuer's avatar
David Feuer committed
907 908 909 910
    threadStablePtrTable((evac_fn)thread_root, NULL);

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

912
    // the CAF list (used by GHCi)
913
    markCAFs((evac_fn)thread_root, NULL);
914

915
    // 2. update forward ptrs
916 917
    for (W_ g = 0; g < RtsFlags.GcFlags.generations; g++) {
        generation *gen = &generations[g];
918 919 920
        debugTrace(DEBUG_gc, "update_fwd:  %d", g);

        update_fwd(gen->blocks);
921
        for (W_ n = 0; n < n_capabilities; n++) {
Simon Marlow's avatar
Simon Marlow committed
922 923 924
            update_fwd(gc_threads[n]->gens[g].todo_bd);
            update_fwd(gc_threads[n]->gens[g].part_list);
        }
925 926 927 928
        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);
929
        }
930 931 932
    }

    // 3. update backward ptrs
933
    generation *gen = oldest_gen;
934
    if (gen->old_blocks != NULL) {
935
        W_ blocks = update_bkwd_compact(gen);
936 937 938 939
        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;
940 941
    }
}