Compact.c 27.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
#include "Hash.h"
31

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

38
/* ----------------------------------------------------------------------------
39 40
   Threading / unthreading pointers.

41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
   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:

       *field, **field = **field, 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.

   The main difficulty here is that not all pointers to the same object are
   tagged: pointers from roots (e.g. mut_lists) are not tagged, but pointers
   from mutators are. So when unthreading a chain we need to distinguish a field
   that had a tagged pointer from a field that had an untagged pointer.

    Our solution is as follows: when chaining a field, if the field is NOT
    tagged then we tag the pointer to the field with 1. I.e.

        *field, **field = **field, field + 1

    If the field is tagged then we tag to the pointer to it with 2.

    When unchaining we look at the tag in the pointer to the field, if it's 1
    then we write an untagged pointer to "free" to it, otherwise we tag the
    pointer.
70
   ------------------------------------------------------------------------- */
71

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
72 73 74 75 76 77 78 79 80 81 82 83
STATIC_INLINE W_
UNTAG_PTR(W_ p)
{
    return p & ~TAG_MASK;
}

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

84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
static W_
get_iptr_tag(StgInfoTable *iptr)
{
    const StgInfoTable *info = INFO_PTR_TO_STRUCT(iptr);
    switch (info->type) {
    case CONSTR:
    case CONSTR_1_0:
    case CONSTR_0_1:
    case CONSTR_2_0:
    case CONSTR_1_1:
    case CONSTR_0_2:
    case CONSTR_NOCAF:
    {
        W_ con_tag = info->srt + 1;
        if (con_tag > TAG_MASK) {
            return TAG_MASK;
        } else {
            return con_tag;
        }
    }

    case FUN:
    case FUN_1_0:
    case FUN_0_1:
    case FUN_2_0:
    case FUN_1_1:
    case FUN_0_2:
    case FUN_STATIC:
    {
        const StgFunInfoTable *fun_itbl = FUN_INFO_PTR_TO_STRUCT(iptr);
        W_ arity = fun_itbl->f.arity;
        if (arity <= TAG_MASK) {
            return arity;
        } else {
            return 0;
        }
    }

    default:
        return 0;
    }
}

sof's avatar
sof committed
127
STATIC_INLINE void
128
thread (StgClosure **p)
129
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
130
    StgClosure *q0  = *p;
131
    bool q0_tagged = GET_CLOSURE_TAG(q0) != 0;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
132
    P_ q = (P_)UNTAG_CLOSURE(q0);
133

134 135 136
    // It doesn't look like a closure at the moment, because the info
    // ptr is possibly threaded:
    // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
137

138
    if (HEAP_ALLOCED(q)) {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
139
        bdescr *bd = Bdescr(q);
140

141
        if (bd->flags & BF_MARKED)
Simon Marlow's avatar
Simon Marlow committed
142
        {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
143
            W_ iptr = *q;
144 145
            *p = (StgClosure *)iptr;
            *q = (W_)p + 1 + (q0_tagged ? 1 : 0);
146
        }
147 148 149
    }
}

150 151 152 153 154 155
static void
thread_root (void *user STG_UNUSED, StgClosure **p)
{
    thread(p);
}

156 157 158 159
// 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
160
STATIC_INLINE void
161
unthread( const P_ p, W_ free, W_ tag )
162
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
163
    W_ q = *p;
164
loop:
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
165
    switch (GET_PTR_TAG(q))
166 167 168
    {
    case 0:
        // nothing to do; the chain is length zero
169
        *p = q;
170 171
        return;
    case 1:
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
172 173
    {
        P_ q0 = (P_)(q-1);
174
        W_ r = *q0;
175
        *q0 = free;
176 177
        q = r;
        goto loop;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
178
    }
179
    case 2:
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
180 181 182
    {
        P_ q0 = (P_)(q-2);
        W_ r = *q0;
183
        *q0 = free + tag;
184 185
        q = r;
        goto loop;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
186
    }
187 188
    default:
        barf("unthread");
189 190 191
    }
}

192 193 194 195
// 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().
196
STATIC_INLINE StgInfoTable*
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
197
get_threaded_info( P_ p )
198
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
199
    W_ q = (W_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
200

201
loop:
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
202
    switch (GET_PTR_TAG(q))
203 204 205
    {
    case 0:
        ASSERT(LOOKS_LIKE_INFO_PTR(q));
206
        return (StgInfoTable*)q;
207 208
    case 1:
    case 2:
209 210
    {
        q = *(P_)(UNTAG_PTR(q));
211
        goto loop;
212
    }
213 214
    default:
        barf("get_threaded_info");
215 216 217 218 219
    }
}

// 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
220
STATIC_INLINE void
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
221
move(P_ to, P_ from, W_ size)
222 223
{
    for(; size > 0; --size) {
224
        *to++ = *from++;
225 226 227 228 229 230 231
    }
}

static void
thread_static( StgClosure* p )
{
  // keep going until we've threaded all the objects on the linked
232
  // list...
233 234
  while (p != END_OF_STATIC_OBJECT_LIST) {
    p = UNTAG_STATIC_LIST_PTR(p);
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
235
    const StgInfoTable *info = get_itbl(p);
236
    switch (info->type) {
237

238
    case IND_STATIC:
239 240 241 242
        thread(&((StgInd *)p)->indirectee);
        p = *IND_STATIC_LINK(p);
        continue;

243
    case THUNK_STATIC:
244 245
        p = *THUNK_STATIC_LINK(p);
        continue;
246
    case FUN_STATIC:
247
        p = *STATIC_LINK(info,p);
248
        continue;
Simon Marlow's avatar
Simon Marlow committed
249 250 251 252 253 254 255
    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:
256 257 258
        p = *STATIC_LINK(info,p);
        continue;

259
    default:
260
        barf("thread_static: strange closure %d", (int)(info->type));
261 262 263 264 265
    }

  }
}

sof's avatar
sof committed
266
STATIC_INLINE void
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
267
thread_large_bitmap( P_ p, StgLargeBitmap *large_bitmap, W_ size )
268
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
269 270 271
    W_ b = 0;
    W_ bitmap = large_bitmap->bitmap[b];
    for (W_ i = 0; i < size; ) {
272 273 274 275 276 277 278 279 280 281 282
        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;
        }
283 284 285
    }
}

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
286 287
STATIC_INLINE P_
thread_small_bitmap (P_ p, W_ size, W_ bitmap)
288 289 290 291 292 293 294 295 296 297 298 299
{
    while (size > 0) {
        if ((bitmap & 1) == 0) {
            thread((StgClosure **)p);
        }
        p++;
        bitmap = bitmap >> 1;
        size--;
    }
    return p;
}

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
300
STATIC_INLINE P_
301 302
thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
303 304
    W_ bitmap;
    W_ size;
305

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
306
    P_ p = (P_)args;
307
    switch (fun_info->f.fun_type) {
308
    case ARG_GEN:
309 310 311
        bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
        size = BITMAP_SIZE(fun_info->f.b.bitmap);
        goto small_bitmap;
312
    case ARG_GEN_BIG:
313 314 315 316
        size = GET_FUN_LARGE_BITMAP(fun_info)->size;
        thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
        p += size;
        break;
317
    default:
318 319
        bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
        size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
320
    small_bitmap:
321
        p = thread_small_bitmap(p, size, bitmap);
322
        break;
323 324 325 326
    }
    return p;
}

327
static void
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
328
thread_stack(P_ p, P_ stack_end)
329 330
{
    // highly similar to scavenge_stack, but we do pointer threading here.
331

332 333
    while (p < stack_end) {

334 335 336 337
        // *p must be the info pointer of an activation
        // record.  All activation records have 'bitmap' style layout
        // info.
        //
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
338
        const StgRetInfoTable *info  = get_ret_itbl((StgClosure *)p);
339 340 341

        switch (info->i.type) {

342
            // small bitmap (<= 32 entries, or 64 on a 64-bit machine)
343 344 345
        case CATCH_RETRY_FRAME:
        case CATCH_STM_FRAME:
        case ATOMICALLY_FRAME:
346
        case UPDATE_FRAME:
347 348 349
        case UNDERFLOW_FRAME:
        case STOP_FRAME:
        case CATCH_FRAME:
350
        case RET_SMALL:
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
351 352 353
        {
            W_ bitmap = BITMAP_BITS(info->i.layout.bitmap);
            W_ size   = BITMAP_SIZE(info->i.layout.bitmap);
354 355 356
            p++;
            // NOTE: the payload starts immediately after the info-ptr, we
            // don't have an StgHeader in the same sense as a heap closure.
357
            p = thread_small_bitmap(p, size, bitmap);
358
            continue;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
359
        }
360 361 362

        case RET_BCO: {
            p++;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
363
            StgBCO *bco = (StgBCO *)*p;
364 365
            thread((StgClosure **)p);
            p++;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
366
            W_ size = BCO_BITMAP_SIZE(bco);
367 368 369 370 371 372 373 374
            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++;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
375
            W_ size = GET_LARGE_BITMAP(&info->i)->size;
376 377 378 379 380 381 382
            thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
            p += size;
            continue;

        case RET_FUN:
        {
            StgRetFun *ret_fun = (StgRetFun *)p;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
383
            StgFunInfoTable *fun_info =
384
                FUN_INFO_PTR_TO_STRUCT(get_threaded_info((P_)ret_fun->fun));
385 386 387 388 389 390 391 392 393 394
                 // *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));
        }
395 396 397
    }
}

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
398 399
STATIC_INLINE P_
thread_PAP_payload (StgClosure *fun, StgClosure **payload, W_ size)
400
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
401
    StgFunInfoTable *fun_info =
402
        FUN_INFO_PTR_TO_STRUCT(get_threaded_info((P_)fun));
403 404
    ASSERT(fun_info->i.type != PAP);

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
405
    P_ p = (P_)payload;
406

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
407
    W_ bitmap;
408
    switch (fun_info->f.fun_type) {
409
    case ARG_GEN:
410 411
        bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
        goto small_bitmap;
412
    case ARG_GEN_BIG:
413 414 415
        thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
        p += size;
        break;
416
    case ARG_BCO:
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
417
        thread_large_bitmap((P_)payload, BCO_BITMAP(fun), size);
418 419
        p += size;
        break;
420
    default:
421
        bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
422
    small_bitmap:
423
        p = thread_small_bitmap(p, size, bitmap);
424
        break;
425
    }
426

427 428 429
    return p;
}

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
430
STATIC_INLINE P_
431 432
thread_PAP (StgPAP *pap)
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
433
    P_ p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
434
    thread(&pap->fun);
435 436
    return p;
}
437

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
438
STATIC_INLINE P_
439 440
thread_AP (StgAP *ap)
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
441
    P_ p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
442
    thread(&ap->fun);
443
    return p;
444
}
445

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
446
STATIC_INLINE P_
447 448
thread_AP_STACK (StgAP_STACK *ap)
{
449
    thread(&ap->fun);
450 451 452 453
    thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
    return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
}

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
454
static P_
455 456
thread_TSO (StgTSO *tso)
{
457
    thread_(&tso->_link);
458
    thread_(&tso->global_link);
459 460

    if (   tso->why_blocked == BlockedOnMVar
461
        || tso->why_blocked == BlockedOnMVarRead
462 463
        || tso->why_blocked == BlockedOnBlackHole
        || tso->why_blocked == BlockedOnMsgThrowTo
464 465
        || tso->why_blocked == NotBlocked
        ) {
466
        thread_(&tso->block_info.closure);
467
    }
468
    thread_(&tso->blocked_exceptions);
469
    thread_(&tso->bq);
470

471
    thread_(&tso->trec);
472

473
    thread_(&tso->stackobj);
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
474
    return (P_)tso + sizeofW(StgTSO);
475 476
}

477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537
/* ----------------------------------------------------------------------------
    Note [CNFs in compacting GC]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    CNF hash table keys point outside of the CNF so those need to be threaded
    and updated during compaction. After compaction we need to re-visit those
    hash tables for re-hashing. The list `nfdata_chain` is used for that
    purpose. When we thread keys of a CNF we add the CNF to the list. After
    compacting is done we re-visit the CNFs in the list and re-hash their
    tables. See also #17937 for more details.
   ------------------------------------------------------------------------- */

static StgCompactNFData *nfdata_chain = NULL;

static void
thread_nfdata_hash_key(void *data STG_UNUSED, StgWord *key, const void *value STG_UNUSED)
{
    thread_((void *)key);
}

static void
add_hash_entry(void *data, StgWord key, const void *value)
{
    HashTable *new_hash = (HashTable *)data;
    insertHashTable(new_hash, key, value);
}

static void
rehash_CNFs(void)
{
    while (nfdata_chain != NULL) {
        StgCompactNFData *str = nfdata_chain;
        nfdata_chain = str->link;
        str->link = NULL;

        HashTable *new_hash = allocHashTable();
        mapHashTable(str->hash, (void*)new_hash, add_hash_entry);
        freeHashTable(str->hash, NULL);
        str->hash = new_hash;
    }
}

static void
update_fwd_cnf( bdescr *bd )
{
    while (bd) {
        ASSERT(bd->flags & BF_COMPACT);
        StgCompactNFData *str = ((StgCompactNFDataBlock*)bd->start)->owner;

        // Thread hash table keys. Values won't be moved as those are inside the
        // CNF, and the CNF is a large object and so won't ever move.
        if (str->hash) {
            mapHashTableKeys(str->hash, NULL, thread_nfdata_hash_key);
            ASSERT(str->link == NULL);
            str->link = nfdata_chain;
            nfdata_chain = str;
        }

        bd = bd->link;
    }
}
538

539 540 541 542 543
static void
update_fwd_large( bdescr *bd )
{
  for (; bd != NULL; bd = bd->link) {

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

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
548 549
    P_ p = bd->start;
    const StgInfoTable *info = get_itbl((StgClosure *)p);
550 551 552 553

    switch (info->type) {

    case ARR_WORDS:
554
      // nothing to follow
555 556
      continue;

557 558
    case MUT_ARR_PTRS_CLEAN:
    case MUT_ARR_PTRS_DIRTY:
559 560
    case MUT_ARR_PTRS_FROZEN_CLEAN:
    case MUT_ARR_PTRS_FROZEN_DIRTY:
561
      // follow everything
562
      {
563
          StgMutArrPtrs *a;
564

565 566 567 568 569
          a = (StgMutArrPtrs*)p;
          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
              thread((StgClosure **)p);
          }
          continue;
570 571
      }

572 573
    case SMALL_MUT_ARR_PTRS_CLEAN:
    case SMALL_MUT_ARR_PTRS_DIRTY:
574 575
    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
576
      // follow everything
577
      {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
578
          StgSmallMutArrPtrs *a = (StgSmallMutArrPtrs*)p;
579 580 581 582 583 584
          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
              thread((StgClosure **)p);
          }
          continue;
      }

585 586 587 588 589 590
    case STACK:
    {
        StgStack *stack = (StgStack*)p;
        thread_stack(stack->sp, stack->stack + stack->stack_size);
        continue;
    }
591 592

    case AP_STACK:
593 594
        thread_AP_STACK((StgAP_STACK *)p);
        continue;
595 596

    case PAP:
597 598
        thread_PAP((StgPAP *)p);
        continue;
599

600 601 602
    case TREC_CHUNK:
    {
        StgTRecChunk *tc = (StgTRecChunk *)p;
603 604
        TRecEntry *e = &(tc -> entries[0]);
        thread_(&tc->prev_chunk);
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
605
        for (W_ i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
606 607 608 609 610
          thread_(&e->tvar);
          thread(&e->expected_value);
          thread(&e->new_value);
        }
        continue;
611 612
    }

613 614 615 616 617 618
    default:
      barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
    }
  }
}

619
// ToDo: too big to inline
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
620 621
static /* STATIC_INLINE */ P_
thread_obj (const StgInfoTable *info, P_ p)
622 623
{
    switch (info->type) {
624
    case THUNK_0_1:
625
        return p + sizeofW(StgThunk) + 1;
626

627 628
    case FUN_0_1:
    case CONSTR_0_1:
629 630
        return p + sizeofW(StgHeader) + 1;

631 632
    case FUN_1_0:
    case CONSTR_1_0:
633 634 635
        thread(&((StgClosure *)p)->payload[0]);
        return p + sizeofW(StgHeader) + 1;

636
    case THUNK_1_0:
637 638 639
        thread(&((StgThunk *)p)->payload[0]);
        return p + sizeofW(StgThunk) + 1;

640
    case THUNK_0_2:
641
        return p + sizeofW(StgThunk) + 2;
642

643 644
    case FUN_0_2:
    case CONSTR_0_2:
645 646
        return p + sizeofW(StgHeader) + 2;

647
    case THUNK_1_1:
648 649
        thread(&((StgThunk *)p)->payload[0]);
        return p + sizeofW(StgThunk) + 2;
650

651 652
    case FUN_1_1:
    case CONSTR_1_1:
653 654 655
        thread(&((StgClosure *)p)->payload[0]);
        return p + sizeofW(StgHeader) + 2;

656
    case THUNK_2_0:
657 658 659
        thread(&((StgThunk *)p)->payload[0]);
        thread(&((StgThunk *)p)->payload[1]);
        return p + sizeofW(StgThunk) + 2;
660

661 662
    case FUN_2_0:
    case CONSTR_2_0:
663 664 665 666
        thread(&((StgClosure *)p)->payload[0]);
        thread(&((StgClosure *)p)->payload[1]);
        return p + sizeofW(StgHeader) + 2;

667
    case BCO: {
668 669 670 671 672
        StgBCO *bco = (StgBCO *)p;
        thread_(&bco->instrs);
        thread_(&bco->literals);
        thread_(&bco->ptrs);
        return p + bco_sizeW(bco);
673 674
    }

675
    case THUNK:
676
    {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
677
        P_ end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
678 679 680 681
        for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
            thread((StgClosure **)p);
        }
        return p + info->layout.payload.nptrs;
682 683 684
    }

    case FUN:
685
    case CONSTR:
Simon Marlow's avatar
Simon Marlow committed
686
    case CONSTR_NOCAF:
687 688
    case PRIM:
    case MUT_PRIM:
689 690
    case MUT_VAR_CLEAN:
    case MUT_VAR_DIRTY:
691
    case TVAR:
692
    case BLACKHOLE:
693
    case BLOCKING_QUEUE:
694
    {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
695
        P_ end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
696 697 698 699
        for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
            thread((StgClosure **)p);
        }
        return p + info->layout.payload.nptrs;
700
    }
701

702 703
    case WEAK:
    {
704 705 706 707 708 709 710 711 712
        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);
713
    }
714

715 716
    case MVAR_CLEAN:
    case MVAR_DIRTY:
717 718 719 720 721 722
    {
        StgMVar *mvar = (StgMVar *)p;
        thread_(&mvar->head);
        thread_(&mvar->tail);
        thread(&mvar->value);
        return p + sizeofW(StgMVar);
723
    }
724

725
    case IND:
726 727
        thread(&((StgInd *)p)->indirectee);
        return p + sizeofW(StgInd);
728 729

    case THUNK_SELECTOR:
730 731 732 733
    {
        StgSelector *s = (StgSelector *)p;
        thread(&s->selectee);
        return p + THUNK_SELECTOR_sizeW();
734
    }
735

736
    case AP_STACK:
737 738
        return thread_AP_STACK((StgAP_STACK *)p);

739
    case PAP:
740
        return thread_PAP((StgPAP *)p);
741 742

    case AP:
743 744
        return thread_AP((StgAP *)p);

745
    case ARR_WORDS:
siddhanathan's avatar
siddhanathan committed
746
        return p + arr_words_sizeW((StgArrBytes *)p);
747

748 749
    case MUT_ARR_PTRS_CLEAN:
    case MUT_ARR_PTRS_DIRTY:
750 751
    case MUT_ARR_PTRS_FROZEN_CLEAN:
    case MUT_ARR_PTRS_FROZEN_DIRTY:
752
        // follow everything
753
    {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
754
        StgMutArrPtrs *a = (StgMutArrPtrs *)p;
755 756 757
        for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
            thread((StgClosure **)p);
        }
758

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
759
        return (P_)a + mut_arr_ptrs_sizeW(a);
760
    }
761 762 763

    case SMALL_MUT_ARR_PTRS_CLEAN:
    case SMALL_MUT_ARR_PTRS_DIRTY:
764 765
    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
766
        // follow everything
767
    {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
768
        StgSmallMutArrPtrs *a = (StgSmallMutArrPtrs *)p;
769 770 771
        for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
            thread((StgClosure **)p);
        }
772

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
773
        return (P_)a + small_mut_arr_ptrs_sizeW(a);
774
    }
775

776
    case TSO:
777 778
        return thread_TSO((StgTSO *)p);

779 780 781 782 783 784 785
    case STACK:
    {
        StgStack *stack = (StgStack*)p;
        thread_stack(stack->sp, stack->stack + stack->stack_size);
        return p + stack_sizeW(stack);
    }

786 787 788
    case TREC_CHUNK:
    {
        StgTRecChunk *tc = (StgTRecChunk *)p;
789 790
        TRecEntry *e = &(tc -> entries[0]);
        thread_(&tc->prev_chunk);
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
791
        for (W_ i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
792 793 794 795 796
          thread_(&e->tvar);
          thread(&e->expected_value);
          thread(&e->new_value);
        }
        return p + sizeofW(StgTRecChunk);
797 798
    }

799
    default:
800 801
        barf("update_fwd: unknown/strange object  %d", (int)(info->type));
        return NULL;
802 803 804
    }
}

805 806 807
static void
update_fwd( bdescr *blocks )
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
808
    bdescr *bd = blocks;
809 810 811

    // cycle through all the blocks in the step
    for (; bd != NULL; bd = bd->link) {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
812
        P_ p = bd->start;
813 814 815 816

        // linearly scan the objects in this block
        while (p < bd->free) {
            ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
817
            const StgInfoTable *info = get_itbl((StgClosure *)p);
818 819
            p = thread_obj(info, p);
        }
820
    }
821
}
822 823 824 825

static void
update_fwd_compact( bdescr *blocks )
{
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
826 827 828
    bdescr *bd = blocks;
    bdescr *free_bd = blocks;
    P_ free = free_bd->start;
829 830 831

    // cycle through all the blocks in the step
    for (; bd != NULL; bd = bd->link) {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
832
        P_ p = bd->start;
833

834
        while (p < bd->free ) {
835

836 837 838 839 840 841
            while ( p < bd->free && !is_marked(p,bd) ) {
                p++;
            }
            if (p >= bd->free) {
                break;
            }
842

843 844 845 846 847
            // 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.
848 849 850 851
            //
            // 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.
852 853
            StgInfoTable *iptr = get_threaded_info(p);
            StgInfoTable *info = INFO_PTR_TO_STRUCT(iptr);
854

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
855
            P_ q = p;
856 857 858

            p = thread_obj(info, p);

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
859
            W_ size = p - q;
860
            if (free + size > free_bd->start + BLOCK_SIZE_W) {
861 862 863 864 865
                // 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.
866 867 868 869 870 871 872
                mark(q+1,bd);
                free_bd = free_bd->link;
                free = free_bd->start;
            } else {
                ASSERT(!is_marked(q+1,bd));
            }

873 874
            StgWord iptr_tag = get_iptr_tag(iptr);
            unthread(q, (W_)free, iptr_tag);
875 876
            free += size;
        }
877 878 879
    }
}

880
static W_
881
update_bkwd_compact( generation *gen )
882 883
{
    bdescr *bd, *free_bd;
884
    bd = free_bd = gen->old_blocks;
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
885 886 887

    P_ free = free_bd->start;
    W_ free_blocks = 1;
888 889 890

    // cycle through all the blocks in the step
    for (; bd != NULL; bd = bd->link) {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
891
        P_ p = bd->start;
892

893
        while (p < bd->free) {
894

895
            while (p < bd->free && !is_marked(p,bd)) {
896 897
                p++;
            }
898

899 900 901
            if (p >= bd->free) {
                break;
            }
902

903
            if (is_marked(p+1,bd)) {
904
                // Don't forget to update the free ptr in the block desc
905
                free_bd->free = free;
906 907 908 909 910 911 912 913

                // Zero the remaining bytes of this block before moving on to
                // the next block
                IF_DEBUG(zero_on_gc, {
                    memset(free_bd->free, 0xaa,
                           BLOCK_SIZE - ((W_)(free_bd->free - free_bd->start) * sizeof(W_)));
                });

914 915 916 917
                free_bd = free_bd->link;
                free = free_bd->start;
                free_blocks++;
            }
918

919 920 921
            StgInfoTable *iptr = get_threaded_info(p);
            StgWord iptr_tag = get_iptr_tag(iptr);
            unthread(p, (W_)free, iptr_tag);
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
922 923 924
            ASSERT(LOOKS_LIKE_INFO_PTR((W_)((StgClosure *)p)->header.info));
            const StgInfoTable *info = get_itbl((StgClosure *)p);
            W_ size = closure_sizeW_((StgClosure *)p,info);
925

926 927 928
            if (free != p) {
                move(free,p,size);
            }
929

930
            // relocate TSOs
931 932
            if (info->type == STACK) {
                move_STACK((StgStack *)p, (StgStack *)free);
933
            }
934

935 936 937
            free += size;
            p += size;
        }
938 939
    }

940
    // Free the remaining blocks and count what's left.
941 942
    free_bd->free = free;
    if (free_bd->link != NULL) {
943 944
        freeChain(free_bd->link);
        free_bd->link = NULL;
945 946
    }

947 948 949 950 951 952 953 954
    // Zero the free bits of the last used block.
    IF_DEBUG(zero_on_gc, {
        W_ block_size_bytes = free_bd->blocks * BLOCK_SIZE;
        W_ block_in_use_bytes = (free_bd->free - free_bd->start) * sizeof(W_);
        W_ block_free_bytes = block_size_bytes - block_in_use_bytes;
        memset(free_bd->free, 0xaa, block_free_bytes);
    });

955
    return free_blocks;
956 957
}

958
void
Ben Gamari's avatar
Ben Gamari committed
959 960 961
compact(StgClosure *static_objects,
        StgWeak **dead_weak_ptr_list,
        StgTSO **resurrected_threads)
962 963
{
    // 1. thread the roots
964
    markCapabilities((evac_fn)thread_root, NULL);
965

Simon Marlow's avatar
Simon Marlow committed
966 967
    markScheduler((evac_fn)thread_root, NULL);

968
    // the weak pointer lists...
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
969
    for (W_ g = 0; g < RtsFlags.GcFlags.generations; g++) {
970
        if (generations[g].weak_ptr_list != NULL) {
971
            thread((void *)&generations[g].weak_ptr_list);
972
        }
973
    }
974 975

    if (dead_weak_ptr_list != NULL) {
Ben Gamari's avatar
Ben Gamari committed
976
        thread((void *)dead_weak_ptr_list); // tmp
977 978
    }

979
    // mutable lists
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
980 981 982
    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];
983
                 bd != NULL; bd = bd->link) {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
984
                for (P_ p = bd->start; p < bd->free; p++) {
985 986 987 988
                    thread((StgClosure **)p);
                }
            }
        }
989
    }
990 991

    // the global thread list
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
992
    for (W_ g = 0; g < RtsFlags.GcFlags.generations; g++) {
993
        thread((void *)&generations[g].threads);
994
    }
995

996
    // any threads resurrected during this GC
Ben Gamari's avatar
Ben Gamari committed
997
    thread((void *)resurrected_threads);
998

999
    // the task list
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
1000 1001 1002 1003 1004
    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);
1005
            }
1006
        }
1007 1008
    }

1009
    // the static objects
1010
    thread_static(static_objects /* ToDo: ok? */);
1011 1012

    // the stable pointer table
David Feuer's avatar
David Feuer committed
1013 1014 1015 1016
    threadStablePtrTable((evac_fn)thread_root, NULL);

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

1018
    // the CAF list (used by GHCi)
1019
    markCAFs((evac_fn)thread_root, NULL);
1020

1021
    // 2. update forward ptrs
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
1022 1023
    for (W_ g = 0; g < RtsFlags.GcFlags.generations; g++) {
        generation *gen = &generations[g];
1024 1025 1026
        debugTrace(DEBUG_gc, "update_fwd:  %d", g);

        update_fwd(gen->blocks);
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
1027
        for (W_ n = 0; n < n_capabilities; n++) {
Simon Marlow's avatar
Simon Marlow committed
1028 1029 1030
            update_fwd(gc_threads[n]->gens[g].todo_bd);
            update_fwd(gc_threads[n]->gens[g].part_list);
        }
1031
        update_fwd_large(gen->scavenged_large_objects);
1032
        update_fwd_cnf(gen->live_compact_objects);
1033 1034 1035
        if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) {
            debugTrace(DEBUG_gc, "update_fwd:  %d (compact)", g);
            update_fwd_compact(gen->old_blocks);
1036
        }
1037 1038 1039
    }

    // 3. update backward ptrs
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
1040
    generation *gen = oldest_gen;
1041
    if (gen->old_blocks != NULL) {
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
1042
        W_ blocks = update_bkwd_compact(gen);
1043 1044 1045 1046
        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;
1047
    }
</