X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=includes%2FCmm.h;h=4cfb432811f6da84f719f06b150772e1454da34c;hb=b0ca990457eaf7991e72b13d0040d937b5759b36;hp=4a4d0eab770b2c83b79275cb471af1300b73a85b;hpb=5ddee764beb312933256096d03df7c3ec47ac452;p=ghc-hetmet.git

diff --git a/includes/Cmm.h b/includes/Cmm.h
index 4a4d0ea..4cfb432 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -91,12 +91,24 @@
 
 #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 sometimes UNTAG a pointer before dereferencing it.
+ * See the wiki page Commentary/Rts/HaskellExecution/PointerTagging 
+ */
+#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 +240,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 +271,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 +288,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.
    -------------------------------------------------------------------------- */
@@ -273,6 +300,8 @@
 #include "DerivedConstants.h"
 #include "ClosureTypes.h"
 #include "StgFun.h"
+#include "OSThreads.h"
+#include "SMP.h"
 
 /*
  * Need MachRegs, because some of the RTS code is conditionally
@@ -368,12 +397,15 @@
 #define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)
 
 /* Debugging macros */
-#define LOOKS_LIKE_INFO_PTR(p)				\
-   ((p) != NULL && 					\
-     (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) &&	\
+#define LOOKS_LIKE_INFO_PTR(p)                                  \
+   ((p) != NULL &&                                              \
+    LOOKS_LIKE_INFO_PTR_NOT_NULL(p))
+
+#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p)                         \
+   ( (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
@@ -522,7 +554,7 @@
  __bd = W_[mut_list];							\
   if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) {		\
       W_ __new_bd;							\
-      "ptr" __new_bd = foreign "C" allocBlock_lock() [regs];		\
+      ("ptr" __new_bd) = foreign "C" allocBlock_lock() [regs];		\
       bdescr_link(__new_bd) = __bd;					\
       __bd = __new_bd;							\
       W_[mut_list] = __bd;						\
@@ -532,9 +564,13 @@
   W_[free] = p;								\
   bdescr_free(__bd) = free + WDS(1);
 
-#define recordMutable(p, regs)						\
-      W_ __p;								\
-      __p = p;								\
-      recordMutableCap(__p, TO_W_(bdescr_gen_no(Bdescr(__p))), regs)
+#define recordMutable(p, regs)                                  \
+      W_ __p;                                                   \
+      W_ __bd;                                                  \
+      W_ __gen;                                                 \
+      __p = p;                                                  \
+      __bd = Bdescr(__p);                                       \
+      __gen = TO_W_(bdescr_gen_no(__bd));                       \
+      if (__gen > 0) { recordMutableCap(__p, __gen, regs); }
 
 #endif /* CMM_H */