[project @ 2000-04-10 12:12:27 by simonpj]

[ghc-hetmet.git] / ghc / compiler / basicTypes / Unique.lhs

diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index bdd8513..a04fbd6 100644 (file)
--- 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,
@@ -95,19 +98,17 @@ module Unique (
        funTyConKey,
        functorClassKey,
        geClassOpKey,
+       getTagIdKey,
        intDataConKey,
        intPrimTyConKey,
        intTyConKey,
        int8TyConKey,
-       int8DataConKey,
        int16TyConKey,
-       int16DataConKey,
        int32TyConKey,
-       int32DataConKey,
-       int64DataConKey,
        int64PrimTyConKey,
        int64TyConKey,
-       integerDataConKey,
+       smallIntegerDataConKey,
+       largeIntegerDataConKey,
        integerMinusOneIdKey,
        integerPlusOneIdKey,
        integerPlusTwoIdKey,
@@ -137,7 +138,6 @@ module Unique (
        ordClassKey,
        orderingTyConKey,
        otherwiseIdKey,
-       packCStringIdKey,
        parErrorIdKey,
        parIdKey,
        patErrorIdKey,
@@ -153,7 +153,9 @@ module Unique (
        recConErrorIdKey,
        recSelErrIdKey,
        recUpdErrorIdKey,
+       returnIOIdKey,
        returnMClassOpKey,
+       runSTRepIdKey,
        showClassKey,
        ioTyConKey,
        ioDataConKey,
@@ -187,12 +189,8 @@ module Unique (
        wordPrimTyConKey,
        wordTyConKey,
        word8TyConKey,
-       word8DataConKey,
        word16TyConKey,
-       word16DataConKey,
        word32TyConKey,
-       word32DataConKey,
-       word64DataConKey,
        word64PrimTyConKey,
        word64TyConKey,
        zipIdKey
@@ -238,6 +236,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}
 
 
@@ -249,6 +250,10 @@ getKey (MkUnique x) = x
 
 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)
 
 -- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
@@ -258,12 +263,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
@@ -370,7 +378,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 ->
@@ -409,6 +421,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
 
@@ -420,9 +433,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
@@ -548,31 +572,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
-int8DataConKey                         = mkPreludeDataConUnique  8
-int16DataConKey                                = mkPreludeDataConUnique  9
-int32DataConKey                                = mkPreludeDataConUnique 10
-int64DataConKey                                = mkPreludeDataConUnique 11
-integerDataConKey                      = mkPreludeDataConUnique 12
-foreignObjDataConKey                   = mkPreludeDataConUnique 13
-nilDataConKey                          = mkPreludeDataConUnique 14
-ratioDataConKey                                = mkPreludeDataConUnique 15
-stablePtrDataConKey                    = mkPreludeDataConUnique 16
-stableNameDataConKey                   = mkPreludeDataConUnique 17
-trueDataConKey                         = mkPreludeDataConUnique 34
-wordDataConKey                         = mkPreludeDataConUnique 35
-word8DataConKey                                = mkPreludeDataConUnique 36
-word16DataConKey                       = mkPreludeDataConUnique 37
-word32DataConKey                       = mkPreludeDataConUnique 38
-word64DataConKey                       = mkPreludeDataConUnique 39
-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}
 
 %************************************************************************
@@ -600,7 +617,6 @@ irrefutPatErrorIdKey              = mkPreludeMiscIdUnique 15
 lexIdKey                     = mkPreludeMiscIdUnique 16
 noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 17
 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
-packCStringIdKey             = mkPreludeMiscIdUnique 19
 parErrorIdKey                = mkPreludeMiscIdUnique 20
 parIdKey                     = mkPreludeMiscIdUnique 21
 patErrorIdKey                = mkPreludeMiscIdUnique 22
@@ -618,8 +634,10 @@ concatIdKey                      = mkPreludeMiscIdUnique 33
 filterIdKey                  = mkPreludeMiscIdUnique 34
 zipIdKey                     = mkPreludeMiscIdUnique 35
 bindIOIdKey                  = mkPreludeMiscIdUnique 36
-deRefStablePtrIdKey          = mkPreludeMiscIdUnique 37
-makeStablePtrIdKey           = mkPreludeMiscIdUnique 38
+returnIOIdKey                = mkPreludeMiscIdUnique 37
+deRefStablePtrIdKey          = mkPreludeMiscIdUnique 38
+makeStablePtrIdKey           = mkPreludeMiscIdUnique 39
+getTagIdKey                  = mkPreludeMiscIdUnique 40
 \end{code}
 
 Certain class operations from Prelude classes.  They get their own
@@ -652,4 +670,5 @@ mapIdKey                  = mkPreludeMiscIdUnique 120
 
 \begin{code}
 assertIdKey                  = mkPreludeMiscIdUnique 121
+runSTRepIdKey                = mkPreludeMiscIdUnique 122
 \end{code}