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

7 files changed, 99 insertions, 7 deletions

diff --git a/includes/Closures.h b/includes/Closures.h
index 64582ba6b5..df53ceedd3 100644
--- a/includes/Closures.h
+++ b/includes/Closures.h
@@ -306,7 +306,8 @@ typedef struct {
  */
 typedef struct {
     const struct _StgInfoTable* info;
-    StgWord        size;
+    StgHalfWord    size;
+    StgHalfWord    tag;
     StgClosure *   fun;
     StgClosure *   payload[FLEXIBLE_ARRAY];
 } StgRetFun;
diff --git a/includes/Cmm.h b/includes/Cmm.h
index b23a37be04..cecf92640b 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -91,12 +91,34 @@
 
 #if SIZEOF_VOID_P == 4
 #define W_ bits32
+/* Maybe it's better to include MachDeps.h */
+#define TAG_BITS                2
 #elif SIZEOF_VOID_P == 8
 #define W_ bits64
+/* Maybe it's better to include MachDeps.h */
+#define TAG_BITS                3
 #else
 #error Unknown word size
 #endif
 
+/*
+ * The RTS must UNTAG a pointer before dereferencing it.
+ * The use of UNTAG follows the following rules of thumb:
+ *
+ * - Any pointer might be tagged.
+ * - Except the pointers that are passed in R1 to RTS functions.
+ * - R1 is also untagged when entering constructor code.
+ * 
+ * TODO:
+ *
+ * - Remove redundancies of tagging and untagging in code generation.
+ * - Optimize getTag or dataToTag# ?
+ *
+ */
+#define TAG_MASK ((1 << TAG_BITS) - 1)
+#define UNTAG(p) (p & ~TAG_MASK)
+#define GETTAG(p) (p & TAG_MASK)
+
 #if SIZEOF_INT == 4
 #define CInt bits32
 #elif SIZEOF_INT == 8
@@ -228,11 +250,23 @@
 
    ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES,
    but switch doesn't allow us to use exprs there yet.
+
+   If R1 points to a tagged object it points either to
+   * A constructor.
+   * A function with arity <= TAG_MASK.
+   In both cases the right thing to do is to return.
+   Note: it is rather lucky that we can use the tag bits to do this
+         for both objects. Maybe it points to a brittle design?
+
+   Indirections can contain tagged pointers, so their tag is checked.
    -------------------------------------------------------------------------- */
 
 #define ENTER()						\
  again:							\
   W_ info;						\
+  if (GETTAG(R1) != 0) {                                \
+      jump %ENTRY_CODE(Sp(0));				\
+  }                                                     \
   info = %INFO_PTR(R1);					\
   switch [INVALID_OBJECT .. N_CLOSURE_TYPES]		\
          (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {	\
@@ -247,14 +281,13 @@
       goto again;					\
    }							\
   case							\
-    BCO,						\
     FUN,						\
     FUN_1_0,						\
     FUN_0_1,						\
     FUN_2_0,						\
     FUN_1_1,						\
-    FUN_0_2,						\
-    FUN_STATIC,						\
+    FUN_STATIC,                                         \
+    BCO,						\
     PAP:						\
    {							\
       jump %ENTRY_CODE(Sp(0));				\
@@ -265,6 +298,10 @@
    }							\
   }
 
+// The FUN cases almost never happen: a pointer to a non-static FUN
+// should always be tagged.  This unfortunately isn't true for the
+// interpreter right now, which leaves untagged FUNs on the stack.
+
 /* -----------------------------------------------------------------------------
    Constants.
    -------------------------------------------------------------------------- */
@@ -375,7 +412,7 @@
      (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) &&	\
      (TO_W_(%INFO_TYPE(%STD_INFO(p))) <  N_CLOSURE_TYPES))
 
-#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(p)))
+#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p))))
 
 /*
  * The layout of the StgFunInfoExtra part of an info table changes
diff --git a/includes/InfoTables.h b/includes/InfoTables.h
index a8e76b05b3..bbffea6468 100644
--- a/includes/InfoTables.h
+++ b/includes/InfoTables.h
@@ -164,7 +164,7 @@ typedef struct {
 
 extern StgWord16 closure_flags[];
 
-#define closureFlags(c)         (closure_flags[get_itbl(c)->type])
+#define closureFlags(c)         (closure_flags[get_itbl(UNTAG_CLOSURE(c))->type])
 
 #define closure_HNF(c)          (  closureFlags(c) & _HNF)
 #define closure_BITMAP(c)       (  closureFlags(c) & _BTM)
diff --git a/includes/MachDeps.h b/includes/MachDeps.h
index abe4405d5e..7b71f7c378 100644
--- a/includes/MachDeps.h
+++ b/includes/MachDeps.h
@@ -105,4 +105,14 @@
 #endif
 #endif
 
+#ifndef TAG_BITS
+#if SIZEOF_HSWORD == 4
+#define TAG_BITS                2
+#else 
+#define TAG_BITS                3
+#endif
+#endif
+
+#define TAG_MASK ((1 << TAG_BITS) - 1)
+
 #endif /* MACHDEPS_H */
diff --git a/includes/Rts.h b/includes/Rts.h
index d009618442..eba8146fd2 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -107,6 +107,29 @@ extern void _assertFail (const char *, unsigned int);
 #define FMT_Int64  "lld"
 #endif
 
+/*
+ * Macros for untagging and retagging closure pointers
+ * For more information look at the comments in Cmm.h
+ */
+
+static inline StgWord
+GET_CLOSURE_TAG(StgClosure * p)
+{
+    return (StgWord)p & TAG_MASK;
+}
+
+static inline StgClosure *
+UNTAG_CLOSURE(StgClosure * p)
+{
+    return (StgClosure*)((StgWord)p & ~TAG_MASK);
+}
+
+static inline StgClosure *
+TAG_CLOSURE(StgWord tag,StgClosure * p)
+{
+    return (StgClosure*)((StgWord)p | tag);
+}
+
 /* -----------------------------------------------------------------------------
    Include everything STG-ish
    -------------------------------------------------------------------------- */
@@ -207,6 +230,23 @@ extern void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
 /* declarations for runtime flags/values */
 #define MAX_RTS_ARGS 32
 
+#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)
+#endif
+
 /* -----------------------------------------------------------------------------
    Assertions and Debuggery
    -------------------------------------------------------------------------- */
diff --git a/includes/Storage.h b/includes/Storage.h
index 604e49e043..92a856c963 100644
--- a/includes/Storage.h
+++ b/includes/Storage.h
@@ -303,7 +303,7 @@ void dirty_MUT_VAR(StgRegTable *reg, StgClosure *p);
     ((StgInfoTable *)(INFO_PTR_TO_STRUCT(p)))->type < N_CLOSURE_TYPES)
 
 #define LOOKS_LIKE_CLOSURE_PTR(p) \
-   (LOOKS_LIKE_INFO_PTR(((StgClosure *)(p))->header.info))
+  (LOOKS_LIKE_INFO_PTR((UNTAG_CLOSURE((StgClosure *)(p)))->header.info))
 
 /* -----------------------------------------------------------------------------
    Macros for calculating how big a closure will be (used during allocation)
diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c
index 2fe99b6ba5..aa3c6730f8 100644
--- a/includes/mkDerivedConstants.c
+++ b/includes/mkDerivedConstants.c
@@ -403,6 +403,10 @@ main(int argc, char *argv[])
     struct_field(StgLargeBitmap, size);
     field_offset(StgLargeBitmap, bitmap);
 
+    struct_field(StgRetFun, size);
+    struct_field(StgRetFun, tag);
+    struct_field(StgRetFun, fun);
+
     struct_size(snEntry);
     struct_field(snEntry,sn_obj);
     struct_field(snEntry,addr);