[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 3d1f220..2167ba0 100644 (file)
--- a/ghc/compiler/basicTypes/Literal.lhs
+++ b/ghc/compiler/basicTypes/Literal.lhs
@@ -13,10 +13,14 @@ module Literal
        , hashLiteral
 
        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
+       , isZeroLit,
 
-       , word2IntLit, int2WordLit, char2IntLit, int2CharLit
+       , word2IntLit, int2WordLit
+       , narrow8IntLit, narrow16IntLit, narrow32IntLit
+       , narrow8WordLit, narrow16WordLit, narrow32WordLit
+       , char2IntLit, int2CharLit
        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
-       , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
+       , nullAddrLit, float2DoubleLit, double2FloatLit
        ) where
 
 #include "HsVersions.h"
@@ -25,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 )
 
@@ -35,6 +40,8 @@ import Util           ( thenCmp )
 
 import Ratio           ( numerator )
 import FastString      ( uniqueOfFS, lengthFS )
+import Int             ( Int8,  Int16,  Int32 )
+import Word            ( Word8, Word16, Word32 )
 import Char            ( ord, chr )
 \end{code}
 
@@ -94,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
@@ -140,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
@@ -151,14 +164,27 @@ 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, char2IntLit, int2CharLit,
- float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
- addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit :: Literal -> Literal
+word2IntLit, int2WordLit,
+  narrow8IntLit, narrow16IntLit, narrow32IntLit,
+  narrow8WordLit, narrow16WordLit, narrow32WordLit,
+  char2IntLit, int2CharLit,
+  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
+  float2DoubleLit, double2FloatLit
+  :: Literal -> Literal
 
 word2IntLit (MachWord w) 
   | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
@@ -168,20 +194,27 @@ int2WordLit (MachInt i)
   | i < 0     = MachWord (1 + tARGET_MAX_WORD + i)     -- (-1)  --->  tARGET_MAX_WORD
   | otherwise = MachWord i
 
+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)
 
 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
@@ -252,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