X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=includes%2FCmm.h;h=715d2b2b0f915fe6dac5c2da29c7dd146f09e62f;hb=87c93cf56c83abf0148c91d5972dbe65dc72c38a;hp=25ffb5d24f61ff10a751b648c2fc4cfd64e6ce51;hpb=9cef40bd4dd2536c7a370a1a9b78461c152805cc;p=ghc-hetmet.git

diff --git a/includes/Cmm.h b/includes/Cmm.h
index 25ffb5d..715d2b2 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.
    -------------------------------------------------------------------------- */
@@ -273,6 +310,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
@@ -373,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
@@ -463,18 +502,13 @@
 #define TICK_SLOW_CALL_ppppp()  	TICK_BUMP(SLOW_CALL_ppppp_ctr)
 #define TICK_SLOW_CALL_pppppp()  	TICK_BUMP(SLOW_CALL_pppppp_ctr)
 
-#ifdef TICKY_TICKY
-#define TICK_HISTO_BY(histo,n,i)			\
-	 W_ __idx;					\
-	 __idx = (n);					\
-	 if (__idx > 8) {				\
-	    __idx = 8;					\
-         }						\
-	 CLong[histo##_hst + _idx*SIZEOF_LONG]		\
-	   = histo##_hst + __idx*SIZEOF_LONG] + i;
-#else
+/* NOTE: TICK_HISTO_BY and TICK_HISTO 
+   currently have no effect.
+   The old code for it didn't typecheck and I 
+   just commented it out to get ticky to work.
+   - krc 1/2007 */
+
 #define TICK_HISTO_BY(histo,n,i) /* nothing */
-#endif
 
 #define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1)
 
@@ -527,7 +561,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;						\
@@ -537,9 +571,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 */