[project @ 2001-10-24 15:11:28 by simonpj]

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

diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs
index 206df95..2167ba0 100644 (file)
--- a/ghc/compiler/basicTypes/Literal.lhs
+++ b/ghc/compiler/basicTypes/Literal.lhs
@@ -13,13 +13,14 @@ module Literal
        , hashLiteral
 
        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
+       , isZeroLit,
 
        , word2IntLit, int2WordLit
-       , intToInt8Lit, intToInt16Lit, intToInt32Lit
-       , wordToWord8Lit, wordToWord16Lit, wordToWord32Lit
+       , narrow8IntLit, narrow16IntLit, narrow32IntLit
+       , narrow8WordLit, narrow16WordLit, narrow32WordLit
        , char2IntLit, int2CharLit
        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
-       , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
+       , nullAddrLit, float2DoubleLit, double2FloatLit
        ) where
 
 #include "HsVersions.h"
@@ -28,7 +29,8 @@ import TysPrim                ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
                          intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
                        )
 import PrimRep         ( PrimRep(..) )
-import Type            ( Type, typePrimRep )
+import TcType          ( Type, tcCmpType )
+import Type            ( typePrimRep )
 import PprType         ( pprParendType )
 import CStrings                ( pprFSInCStyle )
 
@@ -99,9 +101,9 @@ data Literal
 
   | MachAddr   Integer -- Whatever this machine thinks is a "pointer"
 
-  | MachInt    Integer         -- Int#         At least 32 bits
+  | MachInt    Integer         -- Int#         At least WORD_SIZE_IN_BITS bits
   | MachInt64  Integer         -- Int64#       At least 64 bits
-  | MachWord   Integer         -- Word#        At least 32 bits
+  | MachWord   Integer         -- Word#        At least WORD_SIZE_IN_BITS bits
   | MachWord64 Integer         -- Word64#      At least 64 bits
 
   | MachFloat  Rational
@@ -145,10 +147,16 @@ instance Ord Literal where
 \begin{code}
 mkMachInt, mkMachWord, mkMachInt64, mkMachWord64 :: Integer -> Literal
 
-mkMachInt  x   = ASSERT2( inIntRange x,  integer x ) MachInt x
-mkMachWord x   = ASSERT2( inWordRange x, integer x ) MachWord x
-mkMachInt64  x = MachInt64 x   -- Assertions?
-mkMachWord64 x = MachWord64 x  -- Ditto?
+mkMachInt  x   = -- ASSERT2( inIntRange x,  integer x ) 
+                -- Not true: you can write out of range Int# literals
+                -- For example, one can write (intToWord# 0xffff0000) to
+                -- get a particular Word bit-pattern, and there's no other
+                -- convenient way to write such literals, which is why we allow it.
+                MachInt x
+mkMachWord x   = -- ASSERT2( inWordRange x, integer x ) 
+                MachWord x
+mkMachInt64  x = MachInt64 x
+mkMachWord64 x = MachWord64 x
 
 inIntRange, inWordRange :: Integer -> Bool
 inIntRange  x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
@@ -156,17 +164,26 @@ inWordRange x = x >= 0                && x <= tARGET_MAX_WORD
 
 inCharRange :: Int -> Bool
 inCharRange c =  c >= 0 && c <= tARGET_MAX_CHAR
+
+isZeroLit :: Literal -> Bool
+isZeroLit (MachInt    0) = True
+isZeroLit (MachInt64  0) = True
+isZeroLit (MachWord   0) = True
+isZeroLit (MachWord64 0) = True
+isZeroLit (MachFloat  0) = True
+isZeroLit (MachDouble 0) = True
+isZeroLit other                 = False
 \end{code}
 
        Coercions
        ~~~~~~~~~
 \begin{code}
 word2IntLit, int2WordLit,
-  intToInt8Lit, intToInt16Lit, intToInt32Lit,
-  wordToWord8Lit, wordToWord16Lit, wordToWord32Lit,
+  narrow8IntLit, narrow16IntLit, narrow32IntLit,
+  narrow8WordLit, narrow16WordLit, narrow32WordLit,
   char2IntLit, int2CharLit,
   float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
-  addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
+  float2DoubleLit, double2FloatLit
   :: Literal -> Literal
 
 word2IntLit (MachWord w) 
@@ -177,12 +194,12 @@ int2WordLit (MachInt i)
   | i < 0     = MachWord (1 + tARGET_MAX_WORD + i)     -- (-1)  --->  tARGET_MAX_WORD
   | otherwise = MachWord i
 
-intToInt8Lit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
-intToInt16Lit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
-intToInt32Lit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
-wordToWord8Lit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
-wordToWord16Lit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
-wordToWord32Lit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
+narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
+narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
+narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
+narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
+narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
+narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
 
 char2IntLit (MachChar c) = MachInt  (toInteger c)
 int2CharLit (MachInt  i) = MachChar (fromInteger i)
@@ -190,14 +207,14 @@ int2CharLit (MachInt  i) = MachChar (fromInteger i)
 float2IntLit (MachFloat f) = MachInt   (truncate    f)
 int2FloatLit (MachInt   i) = MachFloat (fromInteger i)
 
-double2IntLit (MachFloat f) = MachInt    (truncate    f)
+double2IntLit (MachDouble f) = MachInt    (truncate    f)
 int2DoubleLit (MachInt   i) = MachDouble (fromInteger i)
 
-addr2IntLit (MachAddr a) = MachInt  a
-int2AddrLit (MachInt  i) = MachAddr i
-
 float2DoubleLit (MachFloat  f) = MachDouble f
 double2FloatLit (MachDouble d) = MachFloat  d
+
+nullAddrLit :: Literal
+nullAddrLit = MachAddr 0
 \end{code}
 
        Predicates
@@ -268,7 +285,7 @@ cmpLit (MachWord64    a)   (MachWord64         b)   = a `compare` b
 cmpLit (MachFloat     a)   (MachFloat     b)   = a `compare` b
 cmpLit (MachDouble    a)   (MachDouble    b)   = a `compare` b
 cmpLit (MachLabel     a)   (MachLabel      b)   = a `compare` b
-cmpLit (MachLitLit    a b) (MachLitLit    c d)  = (a `compare` c) `thenCmp` (b `compare` d)
+cmpLit (MachLitLit    a b) (MachLitLit    c d)  = (a `compare` c) `thenCmp` (b `tcCmpType` d)
 cmpLit lit1               lit2                 | litTag lit1 <# litTag lit2 = LT
                                                | otherwise                    = GT