Pointer Tagging

  
This patch implements pointer tagging as per our ICFP'07 paper "Faster
laziness using dynamic pointer tagging".  It improves performance by
10-15% for most workloads, including GHC itself.

The original patches were by Alexey Rodriguez Yakushev
<mrchebas@gmail.com>, with additions and improvements by me.  I've
re-recorded the development as a single patch.

The basic idea is this: we use the low 2 bits of a pointer to a heap
object (3 bits on a 64-bit architecture) to encode some information
about the object pointed to.  For a constructor, we encode the "tag"
of the constructor (e.g. True vs. False), for a function closure its
arity.  This enables some decisions to be made without dereferencing
the pointer, which speeds up some common operations.  In particular it
enables us to avoid costly indirect jumps in many cases.

More information in the commentary:

http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/HaskellExecution/PointerTagging

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;
     }