X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=includes%2FCmm.h;h=cecf92640bf807cfa8b19b5273c440ee3ed664d0;hb=2b52b76bf04d6bcb2f62971126451d9dc5d90871;hp=d58eebc424015603667ef6fced915491286f3685;hpb=93db1991b5cacf8357493a2e17fbbfb485f3205b;p=ghc-hetmet.git

diff --git a/includes/Cmm.h b/includes/Cmm.h
index d58eebc..cecf926 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)
 
@@ -513,8 +547,9 @@
    Misc junk
    -------------------------------------------------------------------------- */
 
-#define NO_TREC        stg_NO_TREC_closure
-#define END_TSO_QUEUE  stg_END_TSO_QUEUE_closure
+#define NO_TREC                   stg_NO_TREC_closure
+#define END_TSO_QUEUE             stg_END_TSO_QUEUE_closure
+#define END_INVARIANT_CHECK_QUEUE stg_END_INVARIANT_CHECK_QUEUE_closure
 
 #define dirtyTSO(tso) \
     StgTSO_flags(tso) = StgTSO_flags(tso) | TSO_DIRTY::I32;
@@ -526,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;						\