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

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

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

29 30
// Turn off inlining when debugging - it obfuscates things
#ifdef DEBUG
sof's avatar
sof committed
31 32
# undef  STATIC_INLINE
# define STATIC_INLINE static
33 34
#endif

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

51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
   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.

   Our solution is as follows: 
     - 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).
   ------------------------------------------------------------------------- */
70

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

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

82 83 84
    // It doesn't look like a closure at the moment, because the info
    // ptr is possibly threaded:
    // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
Simon Marlow's avatar
Simon Marlow committed
85
    
86
    if (HEAP_ALLOCED(q)) {
87
	bd = Bdescr(q); 
88

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

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

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

151 152 153 154 155
// 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
156 157
get_threaded_info( StgPtr p )
{
158 159 160
    StgWord q;
    
    q = (W_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
161

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

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

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

  // keep going until we've threaded all the objects on the linked
  // list... 
  while (p != END_OF_STATIC_LIST) {

    info = get_itbl(p);
    switch (info->type) {
      
    case IND_STATIC:
205
	thread(&((StgInd *)p)->indirectee);
206
	p = *IND_STATIC_LINK(p);
207
	continue;
208 209
      
    case THUNK_STATIC:
210
	p = *THUNK_STATIC_LINK(p);
211
	continue;
212
    case FUN_STATIC:
213
	p = *FUN_STATIC_LINK(p);
214
	continue;
215
    case CONSTR_STATIC:
216
	p = *STATIC_LINK(info,p);
217
	continue;
218 219 220 221 222 223 224 225
      
    default:
	barf("thread_static: strange closure %d", (int)(info->type));
    }

  }
}

sof's avatar
sof committed
226
STATIC_INLINE void
227 228 229 230 231 232 233 234 235
thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
{
    nat i, b;
    StgWord bitmap;

    b = 0;
    bitmap = large_bitmap->bitmap[b];
    for (i = 0; i < size; ) {
	if ((bitmap & 1) == 0) {
236
	    thread((StgClosure **)p);
237 238 239 240 241 242 243 244 245 246 247 248
	}
	i++;
	p++;
	if (i % BITS_IN(W_) == 0) {
	    b++;
	    bitmap = large_bitmap->bitmap[b];
	} else {
	    bitmap = bitmap >> 1;
	}
    }
}

sof's avatar
sof committed
249
STATIC_INLINE StgPtr
250 251 252 253 254 255 256
thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
{
    StgPtr p;
    StgWord bitmap;
    nat size;

    p = (StgPtr)args;
257
    switch (fun_info->f.fun_type) {
258
    case ARG_GEN:
259 260
	bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
	size = BITMAP_SIZE(fun_info->f.b.bitmap);
261 262
	goto small_bitmap;
    case ARG_GEN_BIG:
263 264
	size = GET_FUN_LARGE_BITMAP(fun_info)->size;
	thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
265 266 267
	p += size;
	break;
    default:
268 269
	bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
	size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
270 271 272
    small_bitmap:
	while (size > 0) {
	    if ((bitmap & 1) == 0) {
273
		thread((StgClosure **)p);
274 275 276 277 278 279 280 281 282 283
	    }
	    p++;
	    bitmap = bitmap >> 1;
	    size--;
	}
	break;
    }
    return p;
}

284 285 286
static void
thread_stack(StgPtr p, StgPtr stack_end)
{
287
    const StgRetInfoTable* info;
ken's avatar
ken committed
288
    StgWord bitmap;
289
    nat size;
290 291 292 293 294
    
    // highly similar to scavenge_stack, but we do pointer threading here.
    
    while (p < stack_end) {

295
	// *p must be the info pointer of an activation
296 297 298
	// record.  All activation records have 'bitmap' style layout
	// info.
	//
299
	info  = get_ret_itbl((StgClosure *)p);
300
	
301
	switch (info->i.type) {
302 303 304
	    
	    // Dynamic bitmap: the mask is stored on the stack 
	case RET_DYN:
305 306 307 308 309
	{
	    StgWord dyn;
	    dyn = ((StgRetDyn *)p)->liveness;

	    // traverse the bitmap first
310
	    bitmap = RET_DYN_LIVENESS(dyn);
311
	    p      = (P_)&((StgRetDyn *)p)->payload[0];
312
	    size   = RET_DYN_BITMAP_SIZE;
313 314
	    while (size > 0) {
		if ((bitmap & 1) == 0) {
315
		    thread((StgClosure **)p);
316 317 318 319 320
		}
		p++;
		bitmap = bitmap >> 1;
		size--;
	    }
321
	    
322
	    // skip over the non-ptr words
323
	    p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
324 325
	    
	    // follow the ptr words
326
	    for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
327
		thread((StgClosure **)p);
328 329
		p++;
	    }
330
	    continue;
331
	}
332
	    
ken's avatar
ken committed
333
	    // small bitmap (<= 32 entries, or 64 on a 64-bit machine) 
334 335 336
        case CATCH_RETRY_FRAME:
        case CATCH_STM_FRAME:
        case ATOMICALLY_FRAME:
337
	case UPDATE_FRAME:
338 339 340
        case UNDERFLOW_FRAME:
        case STOP_FRAME:
        case CATCH_FRAME:
341
	case RET_SMALL:
342 343
	    bitmap = BITMAP_BITS(info->i.layout.bitmap);
	    size   = BITMAP_SIZE(info->i.layout.bitmap);
344
	    p++;
345 346 347
	    // NOTE: the payload starts immediately after the info-ptr, we
	    // don't have an StgHeader in the same sense as a heap closure.
	    while (size > 0) {
348
		if ((bitmap & 1) == 0) {
349
		    thread((StgClosure **)p);
350 351 352
		}
		p++;
		bitmap = bitmap >> 1;
353
		size--;
354 355 356
	    }
	    continue;

357 358 359 360 361 362
	case RET_BCO: {
	    StgBCO *bco;
	    nat size;
	    
	    p++;
	    bco = (StgBCO *)*p;
363
	    thread((StgClosure **)p);
364 365 366 367 368 369 370
	    p++;
	    size = BCO_BITMAP_SIZE(bco);
	    thread_large_bitmap(p, BCO_BITMAP(bco), size);
	    p += size;
	    continue;
	}

ken's avatar
ken committed
371
	    // large bitmap (> 32 entries, or 64 on a 64-bit machine) 
372 373
	case RET_BIG:
	    p++;
374 375
	    size = GET_LARGE_BITMAP(&info->i)->size;
	    thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
376 377
	    p += size;
	    continue;
378

379 380 381 382 383
	case RET_FUN:
	{
	    StgRetFun *ret_fun = (StgRetFun *)p;
	    StgFunInfoTable *fun_info;
	    
384 385
	    fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
                           get_threaded_info((StgPtr)ret_fun->fun)));
386
	         // *before* threading it!
387
	    thread(&ret_fun->fun);
388
	    p = thread_arg_block(fun_info, ret_fun->payload);
389 390 391 392 393
	    continue;
	}

	default:
	    barf("thread_stack: weird activation record found on stack: %d", 
394
		 (int)(info->i.type));
395 396 397 398
	}
    }
}

sof's avatar
sof committed
399
STATIC_INLINE StgPtr
400
thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
401 402
{
    StgPtr p;
403
    StgWord bitmap;
404
    StgFunInfoTable *fun_info;
405

406 407
    fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
                        get_threaded_info((StgPtr)fun)));
408 409
    ASSERT(fun_info->i.type != PAP);

410
    p = (StgPtr)payload;
411

412
    switch (fun_info->f.fun_type) {
413
    case ARG_GEN:
414
	bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
415 416
	goto small_bitmap;
    case ARG_GEN_BIG:
417
	thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
418 419 420
	p += size;
	break;
    case ARG_BCO:
421
	thread_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
422 423 424
	p += size;
	break;
    default:
425
	bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
426 427 428
    small_bitmap:
	while (size > 0) {
	    if ((bitmap & 1) == 0) {
429
		thread((StgClosure **)p);
430 431 432 433 434 435 436
	    }
	    p++;
	    bitmap = bitmap >> 1;
	    size--;
	}
	break;
    }
437

438 439 440 441 442 443 444 445
    return p;
}

STATIC_INLINE StgPtr
thread_PAP (StgPAP *pap)
{
    StgPtr p;
    p = thread_PAP_payload(pap->fun, pap->payload, pap->n_args);
446
    thread(&pap->fun);
447 448
    return p;
}
449 450 451 452 453 454
    
STATIC_INLINE StgPtr
thread_AP (StgAP *ap)
{
    StgPtr p;
    p = thread_PAP_payload(ap->fun, ap->payload, ap->n_args);
455
    thread(&ap->fun);
456 457
    return p;
}    
458

sof's avatar
sof committed
459
STATIC_INLINE StgPtr
460 461
thread_AP_STACK (StgAP_STACK *ap)
{
462
    thread(&ap->fun);
463 464 465 466 467 468 469
    thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
    return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
}

static StgPtr
thread_TSO (StgTSO *tso)
{
470
    thread_(&tso->_link);
471
    thread_(&tso->global_link);
472 473 474

    if (   tso->why_blocked == BlockedOnMVar
	|| tso->why_blocked == BlockedOnBlackHole
475
	|| tso->why_blocked == BlockedOnMsgThrowTo
476
	) {
477
	thread_(&tso->block_info.closure);
478
    }
479
    thread_(&tso->blocked_exceptions);
480
    thread_(&tso->bq);
481
    
482
    thread_(&tso->trec);
483

484 485
    thread_(&tso->stackobj);
    return (StgPtr)tso + sizeofW(StgTSO);
486 487 488
}


489 490 491 492 493 494 495 496
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
497 498 499 500
    // nothing to do in a pinned block; it might not even have an object
    // at the beginning.
    if (bd->flags & BF_PINNED) continue;

501 502 503 504 505 506 507 508 509
    p = bd->start;
    info  = get_itbl((StgClosure *)p);

    switch (info->type) {

    case ARR_WORDS:
      // nothing to follow 
      continue;

510 511
    case MUT_ARR_PTRS_CLEAN:
    case MUT_ARR_PTRS_DIRTY:
512
    case MUT_ARR_PTRS_FROZEN:
513
    case MUT_ARR_PTRS_FROZEN0:
514 515
      // follow everything 
      {
516
          StgMutArrPtrs *a;
517

518 519 520 521 522
          a = (StgMutArrPtrs*)p;
          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
              thread((StgClosure **)p);
          }
          continue;
523 524
      }

525 526 527 528 529 530
    case STACK:
    {
        StgStack *stack = (StgStack*)p;
        thread_stack(stack->sp, stack->stack + stack->stack_size);
        continue;
    }
531 532 533

    case AP_STACK:
	thread_AP_STACK((StgAP_STACK *)p);
534 535 536
	continue;

    case PAP:
537
	thread_PAP((StgPAP *)p);
538 539
	continue;

540 541 542 543 544
    case TREC_CHUNK:
    {
        StgWord i;
        StgTRecChunk *tc = (StgTRecChunk *)p;
	TRecEntry *e = &(tc -> entries[0]);
545
	thread_(&tc->prev_chunk);
546
	for (i = 0; i < tc -> next_entry_idx; i ++, e++ ) {
547 548 549
	  thread_(&e->tvar);
	  thread(&e->expected_value);
	  thread(&e->new_value);
550 551 552 553
	}
	continue;
    }

554 555 556 557 558 559
    default:
      barf("update_fwd_large: unknown/strange object  %d", (int)(info->type));
    }
  }
}

560 561
// ToDo: too big to inline
static /* STATIC_INLINE */ StgPtr
562 563 564
thread_obj (StgInfoTable *info, StgPtr p)
{
    switch (info->type) {
565 566 567
    case THUNK_0_1:
	return p + sizeofW(StgThunk) + 1;

568 569 570 571 572 573
    case FUN_0_1:
    case CONSTR_0_1:
	return p + sizeofW(StgHeader) + 1;
	
    case FUN_1_0:
    case CONSTR_1_0:
574
	thread(&((StgClosure *)p)->payload[0]);
575 576 577
	return p + sizeofW(StgHeader) + 1;
	
    case THUNK_1_0:
578
	thread(&((StgThunk *)p)->payload[0]);
579
	return p + sizeofW(StgThunk) + 1;
580 581
	
    case THUNK_0_2:
582 583
	return p + sizeofW(StgThunk) + 2;

584 585 586 587 588
    case FUN_0_2:
    case CONSTR_0_2:
	return p + sizeofW(StgHeader) + 2;
	
    case THUNK_1_1:
589
	thread(&((StgThunk *)p)->payload[0]);
590 591
	return p + sizeofW(StgThunk) + 2;

592 593
    case FUN_1_1:
    case CONSTR_1_1:
594
	thread(&((StgClosure *)p)->payload[0]);
595 596 597
	return p + sizeofW(StgHeader) + 2;
	
    case THUNK_2_0:
598 599
	thread(&((StgThunk *)p)->payload[0]);
	thread(&((StgThunk *)p)->payload[1]);
600 601
	return p + sizeofW(StgThunk) + 2;

602 603
    case FUN_2_0:
    case CONSTR_2_0:
604 605
	thread(&((StgClosure *)p)->payload[0]);
	thread(&((StgClosure *)p)->payload[1]);
606 607
	return p + sizeofW(StgHeader) + 2;
	
608 609
    case BCO: {
	StgBCO *bco = (StgBCO *)p;
610 611 612
	thread_(&bco->instrs);
	thread_(&bco->literals);
	thread_(&bco->ptrs);
613 614 615
	return p + bco_sizeW(bco);
    }

616
    case THUNK:
617 618 619 620 621 622
    {
	StgPtr end;
	
	end = (P_)((StgThunk *)p)->payload + 
	    info->layout.payload.ptrs;
	for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
623
	    thread((StgClosure **)p);
624 625 626 627 628
	}
	return p + info->layout.payload.nptrs;
    }

    case FUN:
629
    case CONSTR:
630 631
    case PRIM:
    case MUT_PRIM:
632 633
    case MUT_VAR_CLEAN:
    case MUT_VAR_DIRTY:
634
    case BLACKHOLE:
635
    case BLOCKING_QUEUE:
636 637 638 639 640 641
    {
	StgPtr end;
	
	end = (P_)((StgClosure *)p)->payload + 
	    info->layout.payload.ptrs;
	for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
642
	    thread((StgClosure **)p);
643 644 645 646 647 648 649
	}
	return p + info->layout.payload.nptrs;
    }
    
    case WEAK:
    {
	StgWeak *w = (StgWeak *)p;
650
	thread(&w->cfinalizer);
651 652 653
	thread(&w->key);
	thread(&w->value);
	thread(&w->finalizer);
654
	if (w->link != NULL) {
655
	    thread_(&w->link);
656 657 658 659
	}
	return p + sizeofW(StgWeak);
    }
    
660 661
    case MVAR_CLEAN:
    case MVAR_DIRTY:
662 663
    { 
	StgMVar *mvar = (StgMVar *)p;
664 665 666
	thread_(&mvar->head);
	thread_(&mvar->tail);
	thread(&mvar->value);
667 668 669
	return p + sizeofW(StgMVar);
    }
    
670 671
    case IND:
    case IND_PERM:
672
	thread(&((StgInd *)p)->indirectee);
673
	return p + sizeofW(StgInd);
674 675 676 677

    case THUNK_SELECTOR:
    { 
	StgSelector *s = (StgSelector *)p;
678
	thread(&s->selectee);
679 680 681 682 683 684 685 686
	return p + THUNK_SELECTOR_sizeW();
    }
    
    case AP_STACK:
	return thread_AP_STACK((StgAP_STACK *)p);
	
    case PAP:
	return thread_PAP((StgPAP *)p);
687 688 689

    case AP:
	return thread_AP((StgAP *)p);
690 691 692 693
	
    case ARR_WORDS:
	return p + arr_words_sizeW((StgArrWords *)p);
	
694 695
    case MUT_ARR_PTRS_CLEAN:
    case MUT_ARR_PTRS_DIRTY:
696
    case MUT_ARR_PTRS_FROZEN:
697
    case MUT_ARR_PTRS_FROZEN0:
698 699
	// follow everything 
    {
700 701 702 703
        StgMutArrPtrs *a;

        a = (StgMutArrPtrs *)p;
	for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
704
	    thread((StgClosure **)p);
705
	}
706 707

	return (StgPtr)a + mut_arr_ptrs_sizeW(a);
708 709 710 711 712
    }
    
    case TSO:
	return thread_TSO((StgTSO *)p);
    
713 714 715 716 717 718 719
    case STACK:
    {
        StgStack *stack = (StgStack*)p;
        thread_stack(stack->sp, stack->stack + stack->stack_size);
        return p + stack_sizeW(stack);
    }

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

734 735
    default:
	barf("update_fwd: unknown/strange object  %d", (int)(info->type));
sof's avatar
sof committed
736
	return NULL;
737 738 739
    }
}

740 741 742 743 744 745 746 747 748 749 750 751 752 753 754
static void
update_fwd( bdescr *blocks )
{
    StgPtr p;
    bdescr *bd;
    StgInfoTable *info;

    bd = blocks;

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

	// linearly scan the objects in this block
	while (p < bd->free) {
755
	    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
756
	    info = get_itbl((StgClosure *)p);
757
	    p = thread_obj(info, p);
758 759 760 761 762 763 764 765
	}
    }
} 

static void
update_fwd_compact( bdescr *blocks )
{
    StgPtr p, q, free;
766
#if 0
767
    StgWord m;
768
#endif
769 770 771
    bdescr *bd, *free_bd;
    StgInfoTable *info;
    nat size;
772
    StgWord iptr;
773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813

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

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

	while (p < bd->free ) {

	    while ( p < bd->free && !is_marked(p,bd) ) {
		p++;
	    }
	    if (p >= bd->free) {
		break;
	    }

#if 0
    next:
	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;
		}
	    }
#endif

	    // 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.
814 815 816 817
            //
            // 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.
818 819
            iptr = get_threaded_info(p);
	    info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
820 821 822

	    q = p;

823
	    p = thread_obj(info, p);
824 825 826

	    size = p - q;
	    if (free + size > free_bd->start + BLOCK_SIZE_W) {
827
		// set the next bit in the bitmap to indicate that
828 829 830
		// 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.
831
		mark(q+1,bd);
832 833
		free_bd = free_bd->link;
		free = free_bd->start;
834
	    } else {
835
		ASSERT(!is_marked(q+1,bd));
836 837
	    }

838
	    unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
839 840 841 842 843 844 845 846 847
	    free += size;
#if 0
	    goto next;
#endif
	}
    }
}

static nat
848
update_bkwd_compact( generation *gen )
849 850
{
    StgPtr p, free;
851
#if 0
852
    StgWord m;
853
#endif
854 855 856
    bdescr *bd, *free_bd;
    StgInfoTable *info;
    nat size, free_blocks;
857
    StgWord iptr;
858

859
    bd = free_bd = gen->old_blocks;
860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893
    free = free_bd->start;
    free_blocks = 1;

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

	while (p < bd->free ) {

	    while ( p < bd->free && !is_marked(p,bd) ) {
		p++;
	    }
	    if (p >= bd->free) {
		break;
	    }

#if 0
    next:
	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;
		}
	    }
#endif

894
	    if (is_marked(p+1,bd)) {
895 896 897 898 899 900 901
		// 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++;
	    }

902 903
            iptr = get_threaded_info(p);
	    unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
Simon Marlow's avatar
Simon Marlow committed
904
	    ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
905
	    info = get_itbl((StgClosure *)p);
906
	    size = closure_sizeW_((StgClosure *)p,info);
907

908 909 910
	    if (free != p) {
		move(free,p,size);
	    }
911 912

	    // relocate TSOs
913 914
            if (info->type == STACK) {
                move_STACK((StgStack *)p, (StgStack *)free);
915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932
	    }

	    free += size;
	    p += size;
#if 0
	    goto next;
#endif
	}
    }

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

    return free_blocks;
933 934
}

935
void
936
compact(StgClosure *static_objects)
937
{
938 939
    nat g, blocks;
    generation *gen;
940 941

    // 1. thread the roots
942
    markCapabilities((evac_fn)thread_root, NULL);
943 944 945

    // the weak pointer lists...
    if (weak_ptr_list != NULL) {
946
	thread((void *)&weak_ptr_list);
947 948
    }
    if (old_weak_ptr_list != NULL) {
949
	thread((void *)&old_weak_ptr_list); // tmp
950 951
    }

952 953
    // mutable lists
    for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
954 955
	bdescr *bd;
	StgPtr p;
956 957 958 959 960 961 962 963 964
        nat n;
        for (n = 0; n < n_capabilities; n++) {
            for (bd = capabilities[n].mut_lists[g]; 
                 bd != NULL; bd = bd->link) {
                for (p = bd->start; p < bd->free; p++) {
                    thread((StgClosure **)p);
                }
            }
        }
965
    }
966 967

    // the global thread list
968 969
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
        thread((void *)&generations[g].threads);
970
    }
971

972
    // any threads resurrected during this GC
973
    thread((void *)&resurrected_threads);
974

975
    // the task list
976
    {
977
	Task *task;
978
        InCall *incall;
979
	for (task = all_tasks; task != NULL; task = task->all_link) {
980 981 982 983 984 985
            for (incall = task->incall; incall != NULL; 
                 incall = incall->prev_stack) {
                if (incall->tso) {
                    thread_(&incall->tso);
                }
            }
986 987 988
	}
    }

989
    // the static objects
990
    thread_static(static_objects /* ToDo: ok? */);
991 992

    // the stable pointer table
993
    threadStablePtrTable((evac_fn)thread_root, NULL);
994

995
    // the CAF list (used by GHCi)
996
    markCAFs((evac_fn)thread_root, NULL);
997

998 999
    // 2. update forward ptrs
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
1000 1001 1002 1003 1004 1005 1006 1007
        gen = &generations[g];
        debugTrace(DEBUG_gc, "update_fwd:  %d", g);

        update_fwd(gen->blocks);
        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);
1008 1009 1010 1011
	}
    }

    // 3. update backward ptrs
1012 1013 1014
    gen = oldest_gen;
    if (gen->old_blocks != NULL) {
	blocks = update_bkwd_compact(gen);
Simon Marlow's avatar
Simon Marlow committed
1015
	debugTrace(DEBUG_gc, 
1016 1017 1018
		   "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
		   gen->no, gen->n_old_blocks, blocks);
	gen->n_old_blocks = blocks;
1019 1020
    }
}