/* -----------------------------------------------------------------------------
*
- * (c) The GHC Team 2001-2006
+ * (c) The GHC Team 2001-2008
*
* Compacting garbage collector
*
#include "PosixSource.h"
#include "Rts.h"
+
+#include "Storage.h"
#include "RtsUtils.h"
-#include "RtsFlags.h"
-#include "OSThreads.h"
#include "BlockAlloc.h"
-#include "MBlock.h"
#include "GC.h"
#include "Compact.h"
#include "Schedule.h"
#include "Apply.h"
#include "Trace.h"
+#include "Weak.h"
+#include "MarkWeak.h"
+#include "Stable.h"
// Turn off inlining when debugging - it obfuscates things
#ifdef DEBUG
# define STATIC_INLINE static
#endif
-/* -----------------------------------------------------------------------------
+/* ----------------------------------------------------------------------------
Threading / unthreading pointers.
The basic idea here is to chain together all the fields pointing at
the chain with the new location of the object. We stop when we
reach the info pointer at the end.
- We use a trick to identify the info pointer: when swapping pointers
- for threading, we set the low bit of the original pointer, with the
- result that all the pointers in the chain have their low bits set
- except for the info pointer.
- -------------------------------------------------------------------------- */
+ 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).
+ ------------------------------------------------------------------------- */
STATIC_INLINE void
thread (StgClosure **p)
{
- StgClosure *q0 = *p;
- StgPtr q = (StgPtr)UNTAG_CLOSURE(q0);
- nat tag = GET_CLOSURE_TAG(q0);
+ StgClosure *q0;
+ StgPtr q;
+ StgWord iptr;
bdescr *bd;
+ q0 = *p;
+ q = (StgPtr)UNTAG_CLOSURE(q0);
+
// It doesn't look like a closure at the moment, because the info
// ptr is possibly threaded:
// ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
- // We need one tag value here, because we a non-zero tag to
- // indicate "not an info pointer". So we add one to the existing
- // tag. If this would overflow the tag bits, we throw away the
- // original tag (which is safe but pessimistic; tags are optional).
- if (tag == TAG_MASK) tag = 0;
-
- if (HEAP_ALLOCED(q))
- {
+ if (HEAP_ALLOCED(q)) {
bd = Bdescr(q);
- // a handy way to discover whether the ptr is into the
- // compacted area of the old gen, is that the EVACUATED flag
- // is zero (it's non-zero for all the other areas of live
- // memory).
- if ((bd->flags & BF_EVACUATED) == 0)
+
+ if (bd->flags & BF_MARKED)
{
- *(StgPtr)p = (StgWord)*q;
- *q = (StgWord)p + tag + 1; // set the low bit
- }
+ 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;
+ }
+ }
}
}
+static void
+thread_root (void *user STG_UNUSED, StgClosure **p)
+{
+ thread(p);
+}
+
// 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); }
STATIC_INLINE void
-unthread( StgPtr p, StgPtr free )
+unthread( StgPtr p, StgWord free )
{
- StgWord q = *p, r;
- nat tag;
- StgPtr q1;
-
- while (GET_CLOSURE_TAG((StgClosure *)q) != 0) {
- q -= 1; // restore the original tag
- tag = GET_CLOSURE_TAG((StgClosure *)q);
- q1 = (StgPtr)UNTAG_CLOSURE((StgClosure *)q);
- r = *q1;
- *q1 = (StgWord)free + tag;
- q = r;
- }
- *p = q;
+ 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");
+ }
}
-STATIC_INLINE StgInfoTable *
+// 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
get_threaded_info( StgPtr p )
{
- StgPtr q = (P_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
+ StgWord q;
+
+ q = (W_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
- while (GET_CLOSURE_TAG((StgClosure *)q) != 0) {
- q = (P_)*((StgPtr)((StgWord)(UNTAG_CLOSURE((StgClosure *)q))));
+loop:
+ switch (GET_CLOSURE_TAG((StgClosure *)q))
+ {
+ case 0:
+ ASSERT(LOOKS_LIKE_INFO_PTR(q));
+ return q;
+ case 1:
+ {
+ StgWord r = *(StgPtr)(q-1);
+ ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)UNTAG_CLOSURE((StgClosure *)r)));
+ return r;
+ }
+ case 2:
+ q = *(StgPtr)(q-2);
+ goto loop;
+ default:
+ barf("get_threaded_info");
}
-
- ASSERT(LOOKS_LIKE_INFO_PTR(q));
- return INFO_PTR_TO_STRUCT((StgInfoTable *)q);
}
// A word-aligned memmove will be faster for small objects than libc's or gcc's.
StgRetFun *ret_fun = (StgRetFun *)p;
StgFunInfoTable *fun_info;
- fun_info = itbl_to_fun_itbl(
- get_threaded_info((StgPtr)ret_fun->fun));
+ fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
+ get_threaded_info((StgPtr)ret_fun->fun)));
// *before* threading it!
thread(&ret_fun->fun);
p = thread_arg_block(fun_info, ret_fun->payload);
StgWord bitmap;
StgFunInfoTable *fun_info;
- fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)fun));
+ fun_info = FUN_INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)
+ get_threaded_info((StgPtr)fun)));
ASSERT(fun_info->i.type != PAP);
p = (StgPtr)payload;
static StgPtr
thread_TSO (StgTSO *tso)
{
- thread_(&tso->link);
+ thread_(&tso->_link);
thread_(&tso->global_link);
if ( tso->why_blocked == BlockedOnMVar
|| tso->why_blocked == BlockedOnBlackHole
- || tso->why_blocked == BlockedOnException
+ || tso->why_blocked == BlockedOnMsgThrowTo
+ || tso->why_blocked == BlockedOnMsgWakeup
) {
thread_(&tso->block_info.closure);
}
for (; bd != NULL; bd = bd->link) {
+ // nothing to do in a pinned block; it might not even have an object
+ // at the beginning.
+ if (bd->flags & BF_PINNED) continue;
+
p = bd->start;
info = get_itbl((StgClosure *)p);
case MUT_ARR_PTRS_FROZEN0:
// follow everything
{
- StgPtr next;
+ StgMutArrPtrs *a;
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- thread((StgClosure **)p);
- }
- continue;
+ a = (StgMutArrPtrs*)p;
+ for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
+ thread((StgClosure **)p);
+ }
+ continue;
}
case TSO:
case FUN:
case CONSTR:
- case STABLE_NAME:
+ case PRIM:
+ case MUT_PRIM:
case IND_PERM:
case MUT_VAR_CLEAN:
case MUT_VAR_DIRTY:
- case CAF_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
- case SE_BLACKHOLE:
case BLACKHOLE:
+ case BLOCKING_QUEUE:
{
StgPtr end;
case WEAK:
{
StgWeak *w = (StgWeak *)p;
+ thread(&w->cfinalizer);
thread(&w->key);
thread(&w->value);
thread(&w->finalizer);
return p + sizeofW(StgWeak);
}
- case MVAR:
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
{
StgMVar *mvar = (StgMVar *)p;
thread_(&mvar->head);
case MUT_ARR_PTRS_FROZEN0:
// follow everything
{
- StgPtr next;
-
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ StgMutArrPtrs *a;
+
+ a = (StgMutArrPtrs *)p;
+ for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
thread((StgClosure **)p);
}
- return p;
+
+ return (StgPtr)a + mut_arr_ptrs_sizeW(a);
}
case TSO:
return thread_TSO((StgTSO *)p);
- case TVAR_WATCH_QUEUE:
- {
- StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p;
- thread_(&wq->closure);
- thread_(&wq->next_queue_entry);
- thread_(&wq->prev_queue_entry);
- return p + sizeofW(StgTVarWatchQueue);
- }
-
- case TVAR:
- {
- StgTVar *tvar = (StgTVar *)p;
- thread((void *)&tvar->current_value);
- thread((void *)&tvar->first_watch_queue_entry);
- return p + sizeofW(StgTVar);
- }
-
- case TREC_HEADER:
- {
- StgTRecHeader *trec = (StgTRecHeader *)p;
- thread_(&trec->enclosing_trec);
- thread_(&trec->current_chunk);
- thread_(&trec->invariants_to_check);
- return p + sizeofW(StgTRecHeader);
- }
-
case TREC_CHUNK:
{
StgWord i;
return p + sizeofW(StgTRecChunk);
}
- case ATOMIC_INVARIANT:
- {
- StgAtomicInvariant *invariant = (StgAtomicInvariant *)p;
- thread_(&invariant->code);
- thread_(&invariant->last_execution);
- return p + sizeofW(StgAtomicInvariant);
- }
-
- case INVARIANT_CHECK_QUEUE:
- {
- StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p;
- thread_(&queue->invariant);
- thread_(&queue->my_execution);
- thread_(&queue->next_queue_entry);
- return p + sizeofW(StgInvariantCheckQueue);
- }
-
default:
barf("update_fwd: unknown/strange object %d", (int)(info->type));
return NULL;
bdescr *bd, *free_bd;
StgInfoTable *info;
nat size;
+ StgWord iptr;
bd = blocks;
free_bd = blocks;
// 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.
- info = get_threaded_info(p);
+ iptr = get_threaded_info(p);
+ info = INFO_PTR_TO_STRUCT(UNTAG_CLOSURE((StgClosure *)iptr));
q = p;
size = p - q;
if (free + size > free_bd->start + BLOCK_SIZE_W) {
- // unset the next bit in the bitmap to indicate that
+ // 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.
- unmark(q+1,bd);
+ mark(q+1,bd);
free_bd = free_bd->link;
free = free_bd->start;
} else {
- ASSERT(is_marked(q+1,bd));
+ ASSERT(!is_marked(q+1,bd));
}
- unthread(q,free);
+ unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
free += size;
#if 0
goto next;
}
static nat
-update_bkwd_compact( step *stp )
+update_bkwd_compact( generation *gen )
{
StgPtr p, free;
#if 0
bdescr *bd, *free_bd;
StgInfoTable *info;
nat size, free_blocks;
+ StgWord iptr;
- bd = free_bd = stp->old_blocks;
+ bd = free_bd = gen->old_blocks;
free = free_bd->start;
free_blocks = 1;
}
#endif
- if (!is_marked(p+1,bd)) {
+ 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_blocks++;
}
- unthread(p,free);
- ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
+ iptr = get_threaded_info(p);
+ unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
+ ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
info = get_itbl((StgClosure *)p);
size = closure_sizeW_((StgClosure *)p,info);
}
void
-compact(void)
+compact(StgClosure *static_objects)
{
- nat g, s, blocks;
- step *stp;
+ nat g, blocks;
+ generation *gen;
// 1. thread the roots
- GetRoots((evac_fn)thread);
+ markCapabilities((evac_fn)thread_root, NULL);
// the weak pointer lists...
if (weak_ptr_list != NULL) {
for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
bdescr *bd;
StgPtr p;
+ nat n;
for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
for (p = bd->start; p < bd->free; p++) {
thread((StgClosure **)p);
}
}
+ 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);
+ }
+ }
+ }
}
// the global thread list
- thread((void *)&all_threads);
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ thread((void *)&generations[g].threads);
+ }
// any threads resurrected during this GC
thread((void *)&resurrected_threads);
// the task list
{
Task *task;
+ InCall *incall;
for (task = all_tasks; task != NULL; task = task->all_link) {
- if (task->tso) {
- thread_(&task->tso);
- }
+ for (incall = task->incall; incall != NULL;
+ incall = incall->prev_stack) {
+ if (incall->tso) {
+ thread_(&incall->tso);
+ }
+ }
}
}
// the static objects
- thread_static(scavenged_static_objects);
+ thread_static(static_objects /* ToDo: ok? */);
// the stable pointer table
- threadStablePtrTable((evac_fn)thread);
+ threadStablePtrTable((evac_fn)thread_root, NULL);
// the CAF list (used by GHCi)
- markCAFs((evac_fn)thread);
+ markCAFs((evac_fn)thread_root, NULL);
// 2. update forward ptrs
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
- for (s = 0; s < generations[g].n_steps; s++) {
- if (g==0 && s ==0) continue;
- stp = &generations[g].steps[s];
- debugTrace(DEBUG_gc, "update_fwd: %d.%d",
- stp->gen->no, stp->no);
-
- update_fwd(stp->blocks);
- update_fwd_large(stp->scavenged_large_objects);
- if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
- debugTrace(DEBUG_gc, "update_fwd: %d.%d (compact)",
- stp->gen->no, stp->no);
- update_fwd_compact(stp->old_blocks);
- }
+ 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);
}
}
// 3. update backward ptrs
- stp = &oldest_gen->steps[0];
- if (stp->old_blocks != NULL) {
- blocks = update_bkwd_compact(stp);
+ gen = oldest_gen;
+ if (gen->old_blocks != NULL) {
+ blocks = update_bkwd_compact(gen);
debugTrace(DEBUG_gc,
- "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
- stp->gen->no, stp->no,
- stp->n_old_blocks, blocks);
- stp->n_old_blocks = blocks;
+ "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
+ gen->no, gen->n_old_blocks, blocks);
+ gen->n_old_blocks = blocks;
}
}
projects / ghc-hetmet.git / blobdiff