summaryrefslogtreecommitdiff
path: root/rts
diff options
context:
space:
mode:
Diffstat (limited to 'rts')
-rw-r--r--rts/Apply.cmm34
-rw-r--r--rts/HeapStackCheck.cmm32
-rw-r--r--rts/Interpreter.c11
-rw-r--r--rts/PrimOps.cmm9
-rw-r--r--rts/RetainerProfile.c22
-rw-r--r--rts/RtsAPI.c38
-rw-r--r--rts/Sanity.c17
-rw-r--r--rts/Sparks.c6
-rw-r--r--rts/Stable.c11
-rw-r--r--rts/Stats.c55
-rw-r--r--rts/StgMiscClosures.cmm10
-rw-r--r--rts/StgStartup.cmm1
-rw-r--r--rts/StgStdThunks.cmm29
-rw-r--r--rts/sm/Compact.c37
-rw-r--r--rts/sm/Evac.c82
-rw-r--r--rts/sm/GC.c13
-rw-r--r--rts/sm/Scav.c4
17 files changed, 300 insertions, 111 deletions
diff --git a/rts/Apply.cmm b/rts/Apply.cmm
index e0ca03944c..cf8a108006 100644
--- a/rts/Apply.cmm
+++ b/rts/Apply.cmm
@@ -90,8 +90,6 @@ stg_PAP_apply
// Enter PAP cost centre
ENTER_CCS_PAP_CL(pap);
- R1 = StgPAP_fun(pap);
-
// Reload the stack
W_ i;
W_ p;
@@ -105,14 +103,30 @@ for:
goto for;
}
+ R1 = StgPAP_fun(pap);
+
+/* DEBUGGING CODE, ensures that arity 1 and 2 functions are entered tagged
+ if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == 1 ) {
+ if (GETTAG(R1)!=1) {
+ W_[0]=1;
+ }
+ }
+
+ if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == 2 ) {
+ if (GETTAG(R1)!=2) {
+ W_[0]=1;
+ }
+ }
+*/
+
// Off we go!
TICK_ENT_VIA_NODE();
#ifdef NO_ARG_REGS
- jump %GET_ENTRY(R1);
+ jump %GET_ENTRY(UNTAG(R1));
#else
W_ info;
- info = %GET_FUN_INFO(R1);
+ info = %GET_FUN_INFO(UNTAG(R1));
W_ type;
type = TO_W_(StgFunInfoExtra_fun_type(info));
if (type == ARG_GEN) {
@@ -167,8 +181,6 @@ INFO_TABLE(stg_AP,/*special layout*/0,0,AP,"AP","AP")
// Enter PAP cost centre
ENTER_CCS_PAP_CL(ap); // ToDo: ENTER_CC_AP_CL
- R1 = StgAP_fun(ap);
-
// Reload the stack
W_ i;
W_ p;
@@ -182,14 +194,16 @@ for:
goto for;
}
+ R1 = StgAP_fun(ap);
+
// Off we go!
TICK_ENT_VIA_NODE();
#ifdef NO_ARG_REGS
- jump %GET_ENTRY(R1);
+ jump %GET_ENTRY(UNTAG(R1));
#else
W_ info;
- info = %GET_FUN_INFO(R1);
+ info = %GET_FUN_INFO(UNTAG(R1));
W_ type;
type = TO_W_(StgFunInfoExtra_fun_type(info));
if (type == ARG_GEN) {
@@ -246,8 +260,6 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK")
// Enter PAP cost centre
ENTER_CCS_PAP_CL(ap); // ToDo: ENTER_CC_AP_CL
- R1 = StgAP_STACK_fun(ap);
-
// Reload the stack
W_ i;
W_ p;
@@ -264,5 +276,7 @@ for:
// Off we go!
TICK_ENT_VIA_NODE();
+ R1 = StgAP_STACK_fun(ap);
+
ENTER();
}
diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm
index f40fbf5519..3c66e7806f 100644
--- a/rts/HeapStackCheck.cmm
+++ b/rts/HeapStackCheck.cmm
@@ -551,6 +551,8 @@ INFO_TABLE_RET( stg_ut_1_0_unreg, RET_SMALL, "ptr" W_ unused )
+---------------------+
| f_closure |
+---------------------+
+ | tag |
+ +- - - - - - - - - - -+
| size |
+---------------------+
| stg_gc_fun_info |
@@ -567,8 +569,11 @@ __stg_gc_fun
W_ size;
W_ info;
W_ type;
+ W_ tag;
+ W_ ret_fun;
- info = %GET_FUN_INFO(R1);
+ tag = GETTAG(R1);
+ info = %GET_FUN_INFO(UNTAG(R1));
// cache the size
type = TO_W_(StgFunInfoExtra_fun_type(info));
@@ -579,7 +584,7 @@ __stg_gc_fun
#ifdef TABLES_NEXT_TO_CODE
// bitmap field holds an offset
size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info)
- + %GET_ENTRY(R1) /* ### */ );
+ + %GET_ENTRY(UNTAG(R1)) /* ### */ );
#else
size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
#endif
@@ -591,9 +596,11 @@ __stg_gc_fun
#ifdef NO_ARG_REGS
// we don't have to save any registers away
Sp_adj(-3);
- Sp(2) = R1;
- Sp(1) = size;
Sp(0) = stg_gc_fun_info;
+ ret_fun = Sp;
+ StgRetFun_size(ret_fun) = HALF_W_(size);
+ StgRetFun_tag(ret_fun) = HALF_W_(tag);
+ StgRetFun_fun(ret_fun) = R1;
GC_GENERIC
#else
W_ type;
@@ -602,9 +609,11 @@ __stg_gc_fun
if (type == ARG_GEN || type == ARG_GEN_BIG) {
// regs already saved by the heap check code
Sp_adj(-3);
- Sp(2) = R1;
- Sp(1) = size;
Sp(0) = stg_gc_fun_info;
+ ret_fun = Sp;
+ StgRetFun_size(ret_fun) = HALF_W_(size);
+ StgRetFun_tag(ret_fun) = HALF_W_(tag);
+ StgRetFun_fun(ret_fun) = R1;
// DEBUG_ONLY(foreign "C" debugBelch("stg_fun_gc_gen(ARG_GEN)"););
GC_GENERIC
} else {
@@ -624,17 +633,22 @@ __stg_gc_fun
INFO_TABLE_RET( stg_gc_fun, RET_FUN )
{
- R1 = Sp(2);
+ // Grab the fun, but remember to add in the tag. The GC doesn't
+ // guarantee to retain the tag on the pointer, so we have to do
+ // it manually, because the function entry code assumes it.
+ W_ ret_fun;
+ ret_fun = Sp;
+ R1 = StgRetFun_fun(ret_fun) | TO_W_(StgRetFun_tag(ret_fun));
Sp_adj(3);
#ifdef NO_ARG_REGS
// Minor optimisation: there are no argument registers to load up,
// so we can just jump straight to the function's entry point.
- jump %GET_ENTRY(R1);
+ jump %GET_ENTRY(UNTAG(R1));
#else
W_ info;
W_ type;
- info = %GET_FUN_INFO(R1);
+ info = %GET_FUN_INFO(UNTAG(R1));
type = TO_W_(StgFunInfoExtra_fun_type(info));
if (type == ARG_GEN || type == ARG_GEN_BIG) {
jump StgFunInfoExtra_slow_apply(info);
diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 6663445995..527ebde0d0 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -224,7 +224,7 @@ interpretBCO (Capability* cap)
// +---------------+
//
else if (Sp[0] == (W_)&stg_apply_interp_info) {
- obj = (StgClosure *)Sp[1];
+ obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
Sp += 2;
goto run_BCO_fun;
}
@@ -244,6 +244,7 @@ eval:
obj = (StgClosure*)Sp[0]; Sp++;
eval_obj:
+ obj = UNTAG_CLOSURE(obj);
INTERP_TICK(it_total_evals);
IF_DEBUG(interpreter,
@@ -327,7 +328,7 @@ eval_obj:
Sp[i] = (W_)ap->payload[i];
}
- obj = (StgClosure*)ap->fun;
+ obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
ASSERT(get_itbl(obj)->type == BCO);
goto run_BCO_fun;
}
@@ -531,7 +532,7 @@ do_apply:
pap = (StgPAP *)obj;
// we only cope with PAPs whose function is a BCO
- if (get_itbl(pap->fun)->type != BCO) {
+ if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
goto defer_apply_to_sched;
}
@@ -556,7 +557,7 @@ do_apply:
for (i = 0; i < pap->n_args; i++) {
Sp[i] = (W_)pap->payload[i];
}
- obj = pap->fun;
+ obj = UNTAG_CLOSURE(pap->fun);
goto run_BCO_fun;
}
else if (arity == n) {
@@ -564,7 +565,7 @@ do_apply:
for (i = 0; i < pap->n_args; i++) {
Sp[i] = (W_)pap->payload[i];
}
- obj = pap->fun;
+ obj = UNTAG_CLOSURE(pap->fun);
goto run_BCO_fun;
}
else /* arity > n */ {
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 7c75fca0e8..cb8626e5dd 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1869,7 +1869,7 @@ unpackClosurezh_fast
// TODO: Consider the absence of ptrs or nonptrs as a special case ?
W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
- info = %GET_STD_INFO(R1);
+ info = %GET_STD_INFO(UNTAG(R1));
// Some closures have non-standard layout, so we omit those here.
W_ type;
@@ -1899,6 +1899,9 @@ out:
ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, unpackClosurezh_fast);
+ W_ clos;
+ clos = UNTAG(R1);
+
ptrs_arr = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
@@ -1907,7 +1910,7 @@ out:
p = 0;
for:
if(p < ptrs) {
- W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(R1,p);
+ W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
p = p + 1;
goto for;
}
@@ -1917,7 +1920,7 @@ for:
p = 0;
for2:
if(p < nptrs) {
- W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(R1, p+ptrs);
+ W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
p = p + 1;
goto for2;
}
diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c
index 9f29acae19..2613b9e4bc 100644
--- a/rts/RetainerProfile.c
+++ b/rts/RetainerProfile.c
@@ -1486,7 +1486,9 @@ retainStack( StgClosure *c, retainer c_child_r,
* ------------------------------------------------------------------------- */
static INLINE StgPtr
-retain_PAP_payload (StgClosure *pap, retainer c_child_r, StgClosure *fun,
+retain_PAP_payload (StgClosure *pap, /* NOT tagged */
+ retainer c_child_r, /* NOT tagged */
+ StgClosure *fun, /* tagged */
StgClosure** payload, StgWord n_args)
{
StgPtr p;
@@ -1494,6 +1496,7 @@ retain_PAP_payload (StgClosure *pap, retainer c_child_r, StgClosure *fun,
StgFunInfoTable *fun_info;
retainClosure(fun, pap, c_child_r);
+ fun = UNTAG_CLOSURE(fun);
fun_info = get_fun_itbl(fun);
ASSERT(fun_info->i.type != PAP);
@@ -1542,9 +1545,9 @@ retain_PAP_payload (StgClosure *pap, retainer c_child_r, StgClosure *fun,
static void
retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
{
- // c = Current closure
- // cp = Current closure's Parent
- // r = current closures' most recent Retainer
+ // c = Current closure (possibly tagged)
+ // cp = Current closure's Parent (NOT tagged)
+ // r = current closures' most recent Retainer (NOT tagged)
// c_child_r = current closure's children's most recent retainer
// first_child = first child of c
StgClosure *c, *cp, *first_child;
@@ -1582,6 +1585,8 @@ loop:
//debugBelch("inner_loop");
inner_loop:
+ c = UNTAG_CLOSURE(c);
+
// c = current closure under consideration,
// cp = current closure's parent,
// r = current closure's most recent retainer
@@ -1794,16 +1799,19 @@ inner_loop:
static void
retainRoot( StgClosure **tl )
{
+ StgClosure *c;
+
// We no longer assume that only TSOs and WEAKs are roots; any closure can
// be a root.
ASSERT(isEmptyRetainerStack());
currentStackBoundary = stackTop;
- if (*tl != &stg_END_TSO_QUEUE_closure && isRetainer(*tl)) {
- retainClosure(*tl, *tl, getRetainerFrom(*tl));
+ c = UNTAG_CLOSURE(*tl);
+ if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
+ retainClosure(c, c, getRetainerFrom(c));
} else {
- retainClosure(*tl, *tl, CCS_SYSTEM);
+ retainClosure(c, c, CCS_SYSTEM);
}
// NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index 69fac8d474..716b4a2f2b 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -22,6 +22,10 @@
/* ----------------------------------------------------------------------------
Building Haskell objects from C datatypes.
+
+ TODO: Currently this code does not tag created pointers,
+ however it is not unsafe (the contructor code will do it)
+ just inefficient.
------------------------------------------------------------------------- */
HaskellObj
rts_mkChar (Capability *cap, HsChar c)
@@ -221,7 +225,7 @@ rts_getChar (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == Czh_con_info ||
// p->header.info == Czh_static_info);
- return (StgChar)(StgWord)(p->payload[0]);
+ return (StgChar)(StgWord)(UNTAG_CLOSURE(p)->payload[0]);
}
HsInt
@@ -230,7 +234,7 @@ rts_getInt (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == Izh_con_info ||
// p->header.info == Izh_static_info);
- return (HsInt)(p->payload[0]);
+ return (HsInt)(UNTAG_CLOSURE(p)->payload[0]);
}
HsInt8
@@ -239,7 +243,7 @@ rts_getInt8 (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == I8zh_con_info ||
// p->header.info == I8zh_static_info);
- return (HsInt8)(HsInt)(p->payload[0]);
+ return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
}
HsInt16
@@ -248,7 +252,7 @@ rts_getInt16 (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == I16zh_con_info ||
// p->header.info == I16zh_static_info);
- return (HsInt16)(HsInt)(p->payload[0]);
+ return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
}
HsInt32
@@ -257,7 +261,7 @@ rts_getInt32 (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == I32zh_con_info ||
// p->header.info == I32zh_static_info);
- return (HsInt32)(HsInt)(p->payload[0]);
+ return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
}
HsInt64
@@ -267,7 +271,7 @@ rts_getInt64 (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == I64zh_con_info ||
// p->header.info == I64zh_static_info);
- tmp = (HsInt64*)&(p->payload[0]);
+ tmp = (HsInt64*)&(UNTAG_CLOSURE(p)->payload[0]);
return *tmp;
}
HsWord
@@ -276,7 +280,7 @@ rts_getWord (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == Wzh_con_info ||
// p->header.info == Wzh_static_info);
- return (HsWord)(p->payload[0]);
+ return (HsWord)(UNTAG_CLOSURE(p)->payload[0]);
}
HsWord8
@@ -285,7 +289,7 @@ rts_getWord8 (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == W8zh_con_info ||
// p->header.info == W8zh_static_info);
- return (HsWord8)(HsWord)(p->payload[0]);
+ return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
}
HsWord16
@@ -294,7 +298,7 @@ rts_getWord16 (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == W16zh_con_info ||
// p->header.info == W16zh_static_info);
- return (HsWord16)(HsWord)(p->payload[0]);
+ return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
}
HsWord32
@@ -303,7 +307,7 @@ rts_getWord32 (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == W32zh_con_info ||
// p->header.info == W32zh_static_info);
- return (HsWord32)(HsWord)(p->payload[0]);
+ return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
}
@@ -314,7 +318,7 @@ rts_getWord64 (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == W64zh_con_info ||
// p->header.info == W64zh_static_info);
- tmp = (HsWord64*)&(p->payload[0]);
+ tmp = (HsWord64*)&(UNTAG_CLOSURE(p)->payload[0]);
return *tmp;
}
@@ -324,7 +328,7 @@ rts_getFloat (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == Fzh_con_info ||
// p->header.info == Fzh_static_info);
- return (float)(PK_FLT((P_)p->payload));
+ return (float)(PK_FLT((P_)UNTAG_CLOSURE(p)->payload));
}
HsDouble
@@ -333,7 +337,7 @@ rts_getDouble (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == Dzh_con_info ||
// p->header.info == Dzh_static_info);
- return (double)(PK_DBL((P_)p->payload));
+ return (double)(PK_DBL((P_)UNTAG_CLOSURE(p)->payload));
}
HsStablePtr
@@ -342,7 +346,7 @@ rts_getStablePtr (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == StablePtr_con_info ||
// p->header.info == StablePtr_static_info);
- return (StgStablePtr)(p->payload[0]);
+ return (StgStablePtr)(UNTAG_CLOSURE(p)->payload[0]);
}
HsPtr
@@ -351,7 +355,7 @@ rts_getPtr (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == Ptr_con_info ||
// p->header.info == Ptr_static_info);
- return (Capability *)(p->payload[0]);
+ return (Capability *)(UNTAG_CLOSURE(p)->payload[0]);
}
HsFunPtr
@@ -360,7 +364,7 @@ rts_getFunPtr (HaskellObj p)
// See comment above:
// ASSERT(p->header.info == FunPtr_con_info ||
// p->header.info == FunPtr_static_info);
- return (void *)(p->payload[0]);
+ return (void *)(UNTAG_CLOSURE(p)->payload[0]);
}
HsBool
@@ -368,7 +372,7 @@ rts_getBool (HaskellObj p)
{
StgInfoTable *info;
- info = get_itbl((StgClosure *)p);
+ info = get_itbl((StgClosure *)UNTAG_CLOSURE(p));
if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
return 0;
} else {
diff --git a/rts/Sanity.c b/rts/Sanity.c
index 7de8ec7d0a..a2ddff87d6 100644
--- a/rts/Sanity.c
+++ b/rts/Sanity.c
@@ -80,13 +80,16 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
static void
checkClosureShallow( StgClosure* p )
{
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+ StgClosure *q;
+
+ q = UNTAG_CLOSURE(p);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
/* Is it a static closure? */
- if (!HEAP_ALLOCED(p)) {
- ASSERT(closure_STATIC(p));
+ if (!HEAP_ALLOCED(q)) {
+ ASSERT(closure_STATIC(q));
} else {
- ASSERT(!closure_STATIC(p));
+ ASSERT(!closure_STATIC(q));
}
}
@@ -162,7 +165,7 @@ checkStackFrame( StgPtr c )
StgRetFun *ret_fun;
ret_fun = (StgRetFun *)c;
- fun_info = get_fun_itbl(ret_fun->fun);
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
size = ret_fun->size;
switch (fun_info->f.fun_type) {
case ARG_GEN:
@@ -206,6 +209,7 @@ checkPAP (StgClosure *fun, StgClosure** payload, StgWord n_args)
StgClosure *p;
StgFunInfoTable *fun_info;
+ fun = UNTAG_CLOSURE(fun);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun));
fun_info = get_fun_itbl(fun);
@@ -241,6 +245,7 @@ checkClosure( StgClosure* p )
ASSERT(LOOKS_LIKE_INFO_PTR(p->header.info));
+ p = UNTAG_CLOSURE(p);
/* Is it a static closure (i.e. in the data segment)? */
if (!HEAP_ALLOCED(p)) {
ASSERT(closure_STATIC(p));
@@ -815,7 +820,7 @@ checkStaticObjects ( StgClosure* static_objects )
switch (info->type) {
case IND_STATIC:
{
- StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
+ StgClosure *indirectee = UNTAG_CLOSURE(((StgIndStatic *)p)->indirectee);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
diff --git a/rts/Sparks.c b/rts/Sparks.c
index ca60e1338c..0ff4ee4cce 100644
--- a/rts/Sparks.c
+++ b/rts/Sparks.c
@@ -200,6 +200,12 @@ newSpark (StgRegTable *reg, StgClosure *p)
{
StgSparkPool *pool = &(reg->rSparks);
+ /* I am not sure whether this is the right thing to do.
+ * Maybe it is better to exploit the tag information
+ * instead of throwing it away?
+ */
+ p = UNTAG_CLOSURE(p);
+
ASSERT_SPARK_POOL_INVARIANTS(pool);
if (closure_SHOULD_SPARK(p)) {
diff --git a/rts/Stable.c b/rts/Stable.c
index e5e8dfbdd0..0ed18bcec2 100644
--- a/rts/Stable.c
+++ b/rts/Stable.c
@@ -177,6 +177,9 @@ exitStablePtrTable(void)
/*
* get at the real stuff...remove indirections.
+ * It untags pointers before dereferencing and
+ * retags the real stuff with its tag (if there
+ * is any) when returning.
*
* ToDo: move to a better home.
*/
@@ -184,16 +187,18 @@ static
StgClosure*
removeIndirections(StgClosure* p)
{
- StgClosure* q = p;
+ StgWord tag = GET_CLOSURE_TAG(p);
+ StgClosure* q = UNTAG_CLOSURE(p);
while (get_itbl(q)->type == IND ||
get_itbl(q)->type == IND_STATIC ||
get_itbl(q)->type == IND_OLDGEN ||
get_itbl(q)->type == IND_PERM ||
get_itbl(q)->type == IND_OLDGEN_PERM ) {
- q = ((StgInd *)q)->indirectee;
+ tag = GET_CLOSURE_TAG(q);
+ q = UNTAG_CLOSURE(((StgInd *)q)->indirectee);
}
- return q;
+ return TAG_CLOSURE(tag,q);
}
static StgWord
diff --git a/rts/Stats.c b/rts/Stats.c
index 9342118ade..f18e26fbd5 100644
--- a/rts/Stats.c
+++ b/rts/Stats.c
@@ -441,6 +441,52 @@ stat_endHeapCensus(void)
were left unused when the heap-check failed.
-------------------------------------------------------------------------- */
+#ifdef DEBUG
+#define TICK_VAR(arity) \
+ extern StgInt SLOW_CALLS_##arity; \
+ extern StgInt RIGHT_ARITY_##arity; \
+ extern StgInt TAGGED_PTR_##arity;
+
+#define TICK_VAR_INI(arity) \
+ StgInt SLOW_CALLS_##arity = 1; \
+ StgInt RIGHT_ARITY_##arity = 1; \
+ StgInt TAGGED_PTR_##arity = 0;
+
+extern StgInt TOTAL_CALLS;
+
+TICK_VAR(1)
+TICK_VAR(2)
+
+TICK_VAR_INI(1)
+TICK_VAR_INI(2)
+
+StgInt TOTAL_CALLS=1;
+#endif
+
+/* Report the value of a counter */
+#define REPORT(counter) \
+ { \
+ ullong_format_string(counter,temp,rtsTrue/*commas*/); \
+ statsPrintf(" (" #counter ") : %s\n",temp); \
+ }
+
+/* Report the value of a counter as a percentage of another counter */
+#define REPORT_PCT(counter,countertot) \
+ statsPrintf(" (" #counter ") %% of (" #countertot ") : %.1f%%\n", \
+ counter*100.0/countertot)
+
+#define TICK_PRINT(arity) \
+ REPORT(SLOW_CALLS_##arity); \
+ REPORT_PCT(RIGHT_ARITY_##arity,SLOW_CALLS_##arity); \
+ REPORT_PCT(TAGGED_PTR_##arity,RIGHT_ARITY_##arity); \
+ REPORT(RIGHT_ARITY_##arity); \
+ REPORT(TAGGED_PTR_##arity)
+
+#define TICK_PRINT_TOT(arity) \
+ statsPrintf(" (SLOW_CALLS_" #arity ") %% of (TOTAL_CALLS) : %.1f%%\n", \
+ SLOW_CALLS_##arity * 100.0/TOTAL_CALLS)
+
+
void
stat_exit(int alloc)
{
@@ -557,6 +603,15 @@ stat_exit(int alloc)
TICK_TO_DBL(time - GC_tot_time -
PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime) * 100
/ TICK_TO_DBL(etime));
+
+ /*
+ TICK_PRINT(1);
+ TICK_PRINT(2);
+ REPORT(TOTAL_CALLS);
+ TICK_PRINT_TOT(1);
+ TICK_PRINT_TOT(2);
+ */
+
#if USE_PAPI
/* PAPI reporting, should put somewhere else?
* Note that the cycles are counted _after_ the initialization of the RTS -- AR */
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index e092e3fdc0..58cbaf9d56 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -167,7 +167,7 @@ INFO_TABLE_FUN( stg_BCO, 4, 0, BCO, "BCO", "BCO", ARG_BCO )
INFO_TABLE(stg_IND,1,0,IND,"IND","IND")
{
TICK_ENT_DYN_IND(); /* tick */
- R1 = StgInd_indirectee(R1);
+ R1 = UNTAG(StgInd_indirectee(R1));
TICK_ENT_VIA_NODE();
jump %GET_ENTRY(R1);
}
@@ -183,7 +183,7 @@ INFO_TABLE(stg_IND_direct,1,0,IND,"IND","IND")
INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC")
{
TICK_ENT_STATIC_IND(); /* tick */
- R1 = StgInd_indirectee(R1);
+ R1 = UNTAG(StgInd_indirectee(R1));
TICK_ENT_VIA_NODE();
jump %GET_ENTRY(R1);
}
@@ -220,7 +220,7 @@ INFO_TABLE(stg_IND_PERM,1,0,IND_PERM,"IND_PERM","IND_PERM")
StgHeader_info(R1) = stg_IND_info;
#endif /* TICKY_TICKY */
- R1 = StgInd_indirectee(R1);
+ R1 = UNTAG(StgInd_indirectee(R1));
#if defined(TICKY_TICKY) && !defined(PROFILING)
TICK_ENT_VIA_NODE();
@@ -233,7 +233,7 @@ INFO_TABLE(stg_IND_PERM,1,0,IND_PERM,"IND_PERM","IND_PERM")
INFO_TABLE(stg_IND_OLDGEN,1,0,IND_OLDGEN,"IND_OLDGEN","IND_OLDGEN")
{
TICK_ENT_STATIC_IND(); /* tick */
- R1 = StgInd_indirectee(R1);
+ R1 = UNTAG(StgInd_indirectee(R1));
TICK_ENT_VIA_NODE();
jump %GET_ENTRY(R1);
}
@@ -262,7 +262,7 @@ INFO_TABLE(stg_IND_OLDGEN_PERM,1,0,IND_OLDGEN_PERM,"IND_OLDGEN_PERM","IND_OLDGEN
StgHeader_info(R1) = stg_IND_OLDGEN_info;
#endif /* TICKY_TICKY */
- R1 = StgInd_indirectee(R1);
+ R1 = UNTAG(StgInd_indirectee(R1));
TICK_ENT_VIA_NODE();
jump %GET_ENTRY(R1);
diff --git a/rts/StgStartup.cmm b/rts/StgStartup.cmm
index 5b0f7e2a5f..b5a5cdcb2f 100644
--- a/rts/StgStartup.cmm
+++ b/rts/StgStartup.cmm
@@ -142,6 +142,7 @@ stg_threadFinished
forceIO takes care of this, performing the IO action and entering the
results that comes back.
+
------------------------------------------------------------------------- */
INFO_TABLE_RET( stg_forceIO, RET_SMALL)
diff --git a/rts/StgStdThunks.cmm b/rts/StgStdThunks.cmm
index db9c254233..20ceb6aaba 100644
--- a/rts/StgStdThunks.cmm
+++ b/rts/StgStdThunks.cmm
@@ -39,10 +39,23 @@
#define RET_PARAMS
#endif
+/*
+ * TODO: On return, we can use a more efficient
+ * untagging (we know the constructor tag).
+ *
+ * When entering stg_sel_#_upd, we know R1 points to its closure,
+ * so it's untagged.
+ * The payload might be a thunk or a constructor,
+ * so we enter it.
+ *
+ * When returning, we know for sure it is a constructor,
+ * so we untag it before accessing the field.
+ *
+ */
#define SELECTOR_CODE_UPD(offset) \
INFO_TABLE_RET(stg_sel_ret_##offset##_upd, RET_SMALL, RET_PARAMS) \
{ \
- R1 = StgClosure_payload(R1,offset); \
+ R1 = StgClosure_payload(UNTAG(R1),offset); \
GET_SAVED_CCCS; \
Sp = Sp + SIZEOF_StgHeader; \
ENTER(); \
@@ -58,8 +71,11 @@
ENTER_CCS_THUNK(R1); \
SAVE_CCCS(WITHUPD_FRAME_SIZE); \
W_[Sp-WITHUPD_FRAME_SIZE] = stg_sel_ret_##offset##_upd_info; \
- R1 = StgThunk_payload(R1,0); \
Sp = Sp - WITHUPD_FRAME_SIZE; \
+ R1 = StgThunk_payload(R1,0); \
+ if (GETTAG(R1) != 0) { \
+ jump RET_LBL(stg_sel_ret_##offset##_upd); \
+ } \
jump %GET_ENTRY(R1); \
}
/* NOTE: no need to ENTER() here, we know the closure cannot evaluate to a function,
@@ -85,10 +101,10 @@ SELECTOR_CODE_UPD(15)
#define SELECTOR_CODE_NOUPD(offset) \
INFO_TABLE_RET(stg_sel_ret_##offset##_noupd, RET_SMALL, RET_PARAMS) \
{ \
- R1 = StgClosure_payload(R1,offset); \
+ R1 = StgClosure_payload(UNTAG(R1),offset); \
GET_SAVED_CCCS; \
Sp = Sp + SIZEOF_StgHeader; \
- jump %GET_ENTRY(R1); \
+ ENTER(); \
} \
\
INFO_TABLE_SELECTOR(stg_sel_##offset##_noupd, offset, THUNK_SELECTOR, "stg_sel_noupd", "stg_sel_noupd")\
@@ -101,8 +117,11 @@ SELECTOR_CODE_UPD(15)
ENTER_CCS_THUNK(R1); \
SAVE_CCCS(NOUPD_FRAME_SIZE); \
W_[Sp-NOUPD_FRAME_SIZE] = stg_sel_ret_##offset##_noupd_info; \
- R1 = StgThunk_payload(R1,0); \
Sp = Sp - NOUPD_FRAME_SIZE; \
+ R1 = StgThunk_payload(R1,0); \
+ if (GETTAG(R1) != 0) { \
+ jump RET_LBL(stg_sel_ret_##offset##_noupd); \
+ } \
jump %GET_ENTRY(R1); \
}
diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index feebef87aa..e8d154059b 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -55,23 +55,32 @@
STATIC_INLINE void
thread (StgClosure **p)
{
- StgPtr q = *(StgPtr *)p;
+ StgClosure *q0 = *p;
+ StgPtr q = (StgPtr)UNTAG_CLOSURE(q0);
+ nat tag = GET_CLOSURE_TAG(q0);
bdescr *bd;
// 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_EVACUATED) == 0)
+ {
*(StgPtr)p = (StgWord)*q;
- *q = (StgWord)p + 1; // set the low bit
+ *q = (StgWord)p + tag + 1; // set the low bit
}
}
}
@@ -84,11 +93,15 @@ STATIC_INLINE void
unthread( StgPtr p, StgPtr free )
{
StgWord q = *p, r;
+ nat tag;
+ StgPtr q1;
- while ((q & 1) != 0) {
- q -= 1; // unset the low bit again
- r = *((StgPtr)q);
- *((StgPtr)q) = (StgWord)free;
+ 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;
@@ -97,10 +110,10 @@ unthread( StgPtr p, StgPtr free )
STATIC_INLINE StgInfoTable *
get_threaded_info( StgPtr p )
{
- StgPtr q = (P_)GET_INFO((StgClosure *)p);
+ StgPtr q = (P_)GET_INFO(UNTAG_CLOSURE((StgClosure *)p));
- while (((StgWord)q & 1) != 0) {
- q = (P_)*((StgPtr)((StgWord)q-1));
+ while (GET_CLOSURE_TAG((StgClosure *)q) != 0) {
+ q = (P_)*((StgPtr)((StgWord)(UNTAG_CLOSURE((StgClosure *)q))));
}
ASSERT(LOOKS_LIKE_INFO_PTR(q));
diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index dda5659675..d437e3f786 100644
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -39,7 +39,7 @@ upd_evacuee(StgClosure *p, StgClosure *dest)
STATIC_INLINE StgClosure *
-copy(StgClosure *src, nat size, step *stp)
+copy_tag(StgClosure *src, nat size, step *stp,StgWord tag)
{
StgPtr to, from;
nat i;
@@ -75,6 +75,10 @@ copy(StgClosure *src, nat size, step *stp)
for (i = 0; i < size; i++) { // unroll for small i
to[i] = from[i];
}
+
+ /* retag pointer before updating EVACUATE closure and returning */
+ to = (StgPtr)TAG_CLOSURE(tag,(StgClosure*)to);
+
upd_evacuee((StgClosure *)from,(StgClosure *)to);
#ifdef PROFILING
@@ -89,7 +93,7 @@ copy(StgClosure *src, nat size, step *stp)
// that will not be scavenged. Used for object that have no pointer
// fields.
STATIC_INLINE StgClosure *
-copy_noscav(StgClosure *src, nat size, step *stp)
+copy_noscav_tag(StgClosure *src, nat size, step *stp, StgWord tag)
{
StgPtr to, from;
nat i;
@@ -125,6 +129,10 @@ copy_noscav(StgClosure *src, nat size, step *stp)
for (i = 0; i < size; i++) { // unroll for small i
to[i] = from[i];
}
+
+ /* retag pointer before updating EVACUATE closure and returning */
+ to = (StgPtr)TAG_CLOSURE(tag,(StgClosure*)to);
+
upd_evacuee((StgClosure *)from,(StgClosure *)to);
#ifdef PROFILING
@@ -184,6 +192,19 @@ copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
}
+/* Copy wrappers that don't tag the closure after copying */
+STATIC_INLINE StgClosure *
+copy(StgClosure *src, nat size, step *stp)
+{
+ return copy_tag(src,size,stp,0);
+}
+
+STATIC_INLINE StgClosure *
+copy_noscav(StgClosure *src, nat size, step *stp)
+{
+ return copy_noscav_tag(src,size,stp,0);
+}
+
/* -----------------------------------------------------------------------------
Evacuate a large object
@@ -295,13 +316,18 @@ evacuate(StgClosure *q)
bdescr *bd = NULL;
step *stp;
const StgInfoTable *info;
+ StgWord tag;
loop:
+ /* The tag and the pointer are split, to be merged after evacing */
+ tag = GET_CLOSURE_TAG(q);
+ q = UNTAG_CLOSURE(q);
+
ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
if (!HEAP_ALLOCED(q)) {
- if (!major_gc) return q;
+ if (!major_gc) return TAG_CLOSURE(tag,q);
info = get_itbl(q);
switch (info->type) {
@@ -338,14 +364,16 @@ loop:
if (*STATIC_LINK(info,(StgClosure *)q) == NULL) {
*STATIC_LINK(info,(StgClosure *)q) = static_objects;
static_objects = (StgClosure *)q;
+ /* I am assuming that static_objects pointers are not
+ * written to other objects, and thus, no need to retag. */
}
- return q;
+ return TAG_CLOSURE(tag,q);
case CONSTR_NOCAF_STATIC:
/* no need to put these on the static linked list, they don't need
* to be scavenged.
*/
- return q;
+ return TAG_CLOSURE(tag,q);
default:
barf("evacuate(static): strange closure type %d", (int)(info->type));
@@ -365,7 +393,7 @@ loop:
failed_to_evac = rtsTrue;
TICK_GC_FAILED_PROMOTION();
}
- return q;
+ return TAG_CLOSURE(tag,q);
}
if ((bd->flags & (BF_LARGE | BF_COMPACTED | BF_EVACUATED)) != 0) {
@@ -380,7 +408,7 @@ loop:
failed_to_evac = rtsTrue;
TICK_GC_FAILED_PROMOTION();
}
- return q;
+ return TAG_CLOSURE(tag,q);
}
/* evacuate large objects by re-linking them onto a different list.
@@ -393,7 +421,7 @@ loop:
goto loop;
}
evacuate_large((P_)q);
- return q;
+ return TAG_CLOSURE(tag,q);
}
/* If the object is in a step that we're compacting, then we
@@ -408,7 +436,7 @@ loop:
}
push_mark_stack((P_)q);
}
- return q;
+ return TAG_CLOSURE(tag,q);
}
}
@@ -429,20 +457,24 @@ loop:
if (q->header.info == Czh_con_info &&
// unsigned, so always true: (StgChar)w >= MIN_CHARLIKE &&
(StgChar)w <= MAX_CHARLIKE) {
- return (StgClosure *)CHARLIKE_CLOSURE((StgChar)w);
+ return TAG_CLOSURE(tag,
+ (StgClosure *)CHARLIKE_CLOSURE((StgChar)w)
+ );
}
if (q->header.info == Izh_con_info &&
(StgInt)w >= MIN_INTLIKE && (StgInt)w <= MAX_INTLIKE) {
- return (StgClosure *)INTLIKE_CLOSURE((StgInt)w);
+ return TAG_CLOSURE(tag,
+ (StgClosure *)INTLIKE_CLOSURE((StgInt)w)
+ );
}
// else
- return copy_noscav(q,sizeofW(StgHeader)+1,stp);
+ return copy_noscav_tag(q,sizeofW(StgHeader)+1,stp,tag);
}
case FUN_0_1:
case FUN_1_0:
case CONSTR_1_0:
- return copy(q,sizeofW(StgHeader)+1,stp);
+ return copy_tag(q,sizeofW(StgHeader)+1,stp,tag);
case THUNK_1_0:
case THUNK_0_1:
@@ -462,27 +494,27 @@ loop:
case FUN_1_1:
case FUN_2_0:
+ case FUN_0_2:
case CONSTR_1_1:
case CONSTR_2_0:
- case FUN_0_2:
- return copy(q,sizeofW(StgHeader)+2,stp);
+ return copy_tag(q,sizeofW(StgHeader)+2,stp,tag);
case CONSTR_0_2:
- return copy_noscav(q,sizeofW(StgHeader)+2,stp);
+ return copy_noscav_tag(q,sizeofW(StgHeader)+2,stp,tag);
case THUNK:
return copy(q,thunk_sizeW_fromITBL(info),stp);
case FUN:
- case CONSTR:
case IND_PERM:
case IND_OLDGEN_PERM:
case WEAK:
case STABLE_NAME:
- return copy(q,sizeW_fromITBL(info),stp);
+ case CONSTR:
+ return copy_tag(q,sizeW_fromITBL(info),stp,tag);
case BCO:
- return copy(q,bco_sizeW((StgBCO *)q),stp);
+ return copy(q,bco_sizeW((StgBCO *)q),stp);
case CAF_BLACKHOLE:
case SE_CAF_BLACKHOLE:
@@ -739,7 +771,9 @@ eval_thunk_selector( nat field, StgSelector * p )
const StgInfoTable *info_ptr;
StgClosure *selectee;
- selectee = p->selectee;
+ // The selectee might be a constructor closure,
+ // so we untag the pointer.
+ selectee = UNTAG_CLOSURE(p->selectee);
// Save the real info pointer (NOTE: not the same as get_itbl()).
info_ptr = p->header.info;
@@ -814,7 +848,7 @@ selector_loop:
{
StgClosure *q;
q = selectee->payload[field];
- if (is_to_space(q)) {
+ if (is_to_space(UNTAG_CLOSURE(q))) {
goto bale_out;
} else {
return q;
@@ -826,7 +860,8 @@ selector_loop:
case IND_OLDGEN:
case IND_OLDGEN_PERM:
case IND_STATIC:
- selectee = ((StgInd *)selectee)->indirectee;
+ // Again, we might need to untag a constructor.
+ selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
goto selector_loop;
case EVACUATED:
@@ -880,7 +915,8 @@ selector_loop:
// indirection.
LDV_RECORD_CREATE(selectee);
- selectee = val;
+ // Of course this pointer might be tagged
+ selectee = UNTAG_CLOSURE(val);
goto selector_loop;
}
}
diff --git a/rts/sm/GC.c b/rts/sm/GC.c
index 1fee394139..216d3cbe44 100644
--- a/rts/sm/GC.c
+++ b/rts/sm/GC.c
@@ -1031,6 +1031,7 @@ GarbageCollect ( rtsBool force_major_gc )
closure if it is alive, or NULL otherwise.
NOTE: Use it before compaction only!
+ It untags and (if needed) retags pointers to closures.
-------------------------------------------------------------------------- */
@@ -1039,8 +1040,12 @@ isAlive(StgClosure *p)
{
const StgInfoTable *info;
bdescr *bd;
+ StgWord tag;
while (1) {
+ /* The tag and the pointer are split, to be merged later when needed. */
+ tag = GET_CLOSURE_TAG(p);
+ p = UNTAG_CLOSURE(p);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl(p);
@@ -1052,18 +1057,18 @@ isAlive(StgClosure *p)
// for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
//
if (!HEAP_ALLOCED(p)) {
- return p;
+ return TAG_CLOSURE(tag,p);
}
// ignore closures in generations that we're not collecting.
bd = Bdescr((P_)p);
if (bd->gen_no > N) {
- return p;
+ return TAG_CLOSURE(tag,p);
}
// if it's a pointer into to-space, then we're done
if (bd->flags & BF_EVACUATED) {
- return p;
+ return TAG_CLOSURE(tag,p);
}
// large objects use the evacuated flag
@@ -1073,7 +1078,7 @@ isAlive(StgClosure *p)
// check the mark bit for compacted steps
if ((bd->flags & BF_COMPACTED) && is_marked((P_)p,bd)) {
- return p;
+ return TAG_CLOSURE(tag,p);
}
switch (info->type) {
diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c
index 0de029edd5..f211401b05 100644
--- a/rts/sm/Scav.c
+++ b/rts/sm/Scav.c
@@ -200,7 +200,7 @@ scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
StgWord bitmap;
StgFunInfoTable *fun_info;
- fun_info = get_fun_itbl(fun);
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(fun));
ASSERT(fun_info->i.type != PAP);
p = (StgPtr)payload;
@@ -1720,7 +1720,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
StgFunInfoTable *fun_info;
ret_fun->fun = evacuate(ret_fun->fun);
- fun_info = get_fun_itbl(ret_fun->fun);
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
p = scavenge_arg_block(fun_info, ret_fun->payload);
goto follow_srt;
}
View Lorry Controller Status