X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FUnique.lhs;h=868fe761be41f853df92aa1f95cc6b8e0560db96;hb=cfbedcecad9f9c4241fa1313e73468fd95db76b3;hp=ae87ce2347f10428c0ee381876177cf4c6776097;hpb=506fa77d392191e46c12b2c19387ff5b0888f6a2;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index ae87ce2..868fe76 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -26,9 +26,12 @@ module Unique (
 	getKey,				-- Used in Var only!
 
 	incrUnique,			-- Used for renumbering
+	deriveUnique,			-- Ditto
 	initTyVarUnique,
 	initTidyUniques,
 
+	isTupleKey,
+
 	-- now all the built-in Uniques (and functions to make them)
 	-- [the Oh-So-Wonderful Haskell module system wins again...]
 	mkAlphaTyVarUnique,
@@ -151,6 +154,7 @@ module Unique (
 	recConErrorIdKey,
 	recSelErrIdKey,
 	recUpdErrorIdKey,
+	returnIOIdKey,
 	returnMClassOpKey,
 	runSTRepIdKey,
 	showClassKey,
@@ -233,6 +237,9 @@ mkUniqueGrimily :: Int# -> Unique		-- A trap-door for UniqSupply
 getKey		:: Unique -> Int#		-- for Var
 
 incrUnique	:: Unique -> Unique
+deriveUnique	:: Unique -> Int -> Unique
+
+isTupleKey	:: Unique -> Bool
 \end{code}
 
 
@@ -242,9 +249,11 @@ mkUniqueGrimily x = MkUnique x
 {-# INLINE getKey #-}
 getKey (MkUnique x) = x
 
-incrUnique (MkUnique i) = MkUnique (i +# 100#)
--- Bump the unique by a lot, to get it out of the neighbourhood
--- of its friends
+incrUnique (MkUnique i) = MkUnique (i +# 1#)
+
+-- deriveUnique uses an 'X' tag so that it won't clash with
+-- any of the uniques produced any other way
+deriveUnique (MkUnique i) delta = mkUnique 'X' (I# i + delta)
 
 -- pop the Char in the top 8 bits of the Unique(Supply)
 
@@ -255,12 +264,15 @@ i2w x = int2Word# x
 i2w_s x = (x::Int#)
 
 mkUnique (C# c) (I# i)
-  = MkUnique (w2i (((i2w (ord# c)) `shiftL#` (i2w_s 24#)) `or#` (i2w i)))
+  = MkUnique (w2i (tag `or#` bits))
+  where
+    tag  = i2w (ord# c) `shiftL#` i2w_s 24#
+    bits = i2w i `and#` (i2w 16777215#){-``0x00ffffff''-}
 
 unpkUnique (MkUnique u)
   = let
 	tag = C# (chr# (w2i ((i2w u) `shiftr` (i2w_s 24#))))
-	i   = I#  (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
+	i   = I# (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
     in
     (tag, i)
   where
@@ -367,7 +379,11 @@ iToBase62 :: Int -> SDoc
 iToBase62 n@(I# n#)
   = ASSERT(n >= 0)
     let
+#if __GLASGOW_HASKELL__ < 405
 	bytes = case chars62 of { BYTE_ARRAY bounds_who_needs_'em bytes -> bytes }
+#else
+	bytes = case chars62 of { BYTE_ARRAY _ _ bytes -> bytes }
+#endif
     in
     if n# <# 62# then
 	case (indexCharArray# bytes n#) of { c ->
@@ -406,6 +422,7 @@ Allocation of unique supply characters:
 	other a-z: lower case chars for unique supplies (see Main.lhs)
 	B:   builtin
 	C-E: pseudo uniques	(used in native-code generator)
+	X:   uniques derived by deriveUnique
 	_:   unifiable tyvars   (above)
 	0-9: prelude things below
 
@@ -417,9 +434,20 @@ mkPreludeTyConUnique i		= mkUnique '3' i
 mkTupleTyConUnique a		= mkUnique '4' a
 mkUbxTupleTyConUnique a		= mkUnique '5' a
 
-mkPreludeDataConUnique i	= mkUnique '6' i -- must be alphabetic
-mkTupleDataConUnique a		= mkUnique '7' a -- ditto (*may* be used in C labels)
-mkUbxTupleDataConUnique a	= mkUnique '8' a
+-- Data constructor keys occupy *two* slots.  The first is used for the
+-- data constructor itself and its wrapper function (the function that
+-- evaluates arguments as necessary and calls the worker). The second is
+-- used for the worker function (the function that builds the constructor
+-- representation).
+
+mkPreludeDataConUnique i	= mkUnique '6' (2*i)	-- Must be alphabetic
+mkTupleDataConUnique a		= mkUnique '7' (2*a)	-- ditto (*may* be used in C labels)
+mkUbxTupleDataConUnique a	= mkUnique '8' (2*a)
+
+-- This one is used for a tiresome reason
+-- to improve a consistency-checking error check in the renamer
+isTupleKey u = case unpkUnique u of
+		(tag,_) -> tag == '4' || tag == '5' || tag == '7' || tag == '8'
 
 mkPrimOpIdUnique op		= mkUnique '9' op
 mkPreludeMiscIdUnique i		= mkUnique '0' i
@@ -545,24 +573,24 @@ threadIdPrimTyConKey			= mkPreludeTyConUnique 70
 %************************************************************************
 
 \begin{code}
-addrDataConKey				= mkPreludeDataConUnique  1
-charDataConKey				= mkPreludeDataConUnique  2
-consDataConKey				= mkPreludeDataConUnique  3
-doubleDataConKey			= mkPreludeDataConUnique  4
-falseDataConKey				= mkPreludeDataConUnique  5
-floatDataConKey				= mkPreludeDataConUnique  6
-intDataConKey				= mkPreludeDataConUnique  7
-smallIntegerDataConKey			= mkPreludeDataConUnique 12
-largeIntegerDataConKey			= mkPreludeDataConUnique 13
-foreignObjDataConKey			= mkPreludeDataConUnique 14
-nilDataConKey				= mkPreludeDataConUnique 15
-ratioDataConKey				= mkPreludeDataConUnique 16
-stablePtrDataConKey			= mkPreludeDataConUnique 17
-stableNameDataConKey			= mkPreludeDataConUnique 18
-trueDataConKey				= mkPreludeDataConUnique 34
-wordDataConKey				= mkPreludeDataConUnique 35
-stDataConKey				= mkPreludeDataConUnique 40
-ioDataConKey				= mkPreludeDataConUnique 42
+addrDataConKey				= mkPreludeDataConUnique  0
+charDataConKey				= mkPreludeDataConUnique  1
+consDataConKey				= mkPreludeDataConUnique  2
+doubleDataConKey			= mkPreludeDataConUnique  3
+falseDataConKey				= mkPreludeDataConUnique  4
+floatDataConKey				= mkPreludeDataConUnique  5
+intDataConKey				= mkPreludeDataConUnique  6
+smallIntegerDataConKey			= mkPreludeDataConUnique  7
+largeIntegerDataConKey			= mkPreludeDataConUnique  8
+foreignObjDataConKey			= mkPreludeDataConUnique  9
+nilDataConKey				= mkPreludeDataConUnique 10
+ratioDataConKey				= mkPreludeDataConUnique 11
+stablePtrDataConKey			= mkPreludeDataConUnique 12
+stableNameDataConKey			= mkPreludeDataConUnique 13
+trueDataConKey				= mkPreludeDataConUnique 14
+wordDataConKey				= mkPreludeDataConUnique 15
+stDataConKey				= mkPreludeDataConUnique 16
+ioDataConKey				= mkPreludeDataConUnique 17
 \end{code}
 
 %************************************************************************
@@ -608,9 +636,10 @@ concatIdKey		      = mkPreludeMiscIdUnique 33
 filterIdKey		      = mkPreludeMiscIdUnique 34
 zipIdKey		      = mkPreludeMiscIdUnique 35
 bindIOIdKey		      = mkPreludeMiscIdUnique 36
-deRefStablePtrIdKey	      = mkPreludeMiscIdUnique 37
-makeStablePtrIdKey	      = mkPreludeMiscIdUnique 38
-getTagIdKey		      = mkPreludeMiscIdUnique 39
+returnIOIdKey		      = mkPreludeMiscIdUnique 37
+deRefStablePtrIdKey	      = mkPreludeMiscIdUnique 38
+makeStablePtrIdKey	      = mkPreludeMiscIdUnique 39
+getTagIdKey		      = mkPreludeMiscIdUnique 40
 \end{code}
 
 Certain class operations from Prelude classes.  They get their own