/ghc-7.0.4/compiler/basicTypes/Literal.lhs
Haskell | 440 lines | 319 code | 61 blank | 60 comment | 6 complexity | 5fd7a1b4ff7e58af0e9dd059813e0d15 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause
- %
- % (c) The University of Glasgow 2006
- % (c) The GRASP/AQUA Project, Glasgow University, 1998
- %
- \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
- \begin{code}
- {-# OPTIONS -fno-warn-incomplete-patterns #-}
- -- The above warning supression flag is a temporary kludge.
- -- While working on this module you are encouraged to remove it and fix
- -- any warnings in the module. See
- -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
- -- for details
- {-# LANGUAGE DeriveDataTypeable #-}
- module Literal
- (
- -- * Main data type
- Literal(..) -- Exported to ParseIface
-
- -- ** Creating Literals
- , mkMachInt, mkMachWord
- , mkMachInt64, mkMachWord64
- , mkMachFloat, mkMachDouble
- , mkMachChar, mkMachString
-
- -- ** Operations on Literals
- , literalType
- , hashLiteral
- , absentLiteralOf
- -- ** Predicates on Literals and their contents
- , litIsDupable, litIsTrivial
- , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
- , isZeroLit
- , litFitsInChar
- -- ** Coercions
- , word2IntLit, int2WordLit
- , narrow8IntLit, narrow16IntLit, narrow32IntLit
- , narrow8WordLit, narrow16WordLit, narrow32WordLit
- , char2IntLit, int2CharLit
- , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
- , nullAddrLit, float2DoubleLit, double2FloatLit
- ) where
- import TysPrim
- import PrelNames
- import Type
- import TyCon
- import Outputable
- import FastTypes
- import FastString
- import BasicTypes
- import Binary
- import Constants
- import UniqFM
- import Data.Int
- import Data.Ratio
- import Data.Word
- import Data.Char
- import Data.Data( Data, Typeable )
- \end{code}
- %************************************************************************
- %* *
- \subsection{Literals}
- %* *
- %************************************************************************
- \begin{code}
- -- | So-called 'Literal's are one of:
- --
- -- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),
- -- which is presumed to be surrounded by appropriate constructors
- -- (@Int#@, etc.), so that the overall thing makes sense.
- --
- -- * The literal derived from the label mentioned in a \"foreign label\"
- -- declaration ('MachLabel')
- data Literal
- = ------------------
- -- First the primitive guys
- MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
- | MachStr FastString -- ^ A string-literal: stored and emitted
- -- UTF-8 encoded, we'll arrange to decode it
- -- at runtime. Also emitted with a @'\0'@
- -- terminator. Create with 'mkMachString'
- | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value
- -- that can be represented as a Literal. Create
- -- with 'nullAddrLit'
- | MachInt Integer -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt'
- | MachInt64 Integer -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64'
- | MachWord Integer -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord'
- | MachWord64 Integer -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64'
- | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat'
- | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
- | MachLabel FastString
- (Maybe Int)
- FunctionOrData
- -- ^ A label literal. Parameters:
- --
- -- 1) The name of the symbol mentioned in the declaration
- --
- -- 2) The size (in bytes) of the arguments
- -- the label expects. Only applicable with
- -- @stdcall@ labels. @Just x@ => @\<x\>@ will
- -- be appended to label name when emitting assembly.
- deriving (Data, Typeable)
- \end{code}
- Binary instance
- \begin{code}
- instance Binary Literal where
- put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
- put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
- put_ bh (MachNullAddr) = do putByte bh 2
- put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
- put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
- put_ bh (MachWord af) = do putByte bh 5; put_ bh af
- put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
- put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
- put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
- put_ bh (MachLabel aj mb fod)
- = do putByte bh 9
- put_ bh aj
- put_ bh mb
- put_ bh fod
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do
- aa <- get bh
- return (MachChar aa)
- 1 -> do
- ab <- get bh
- return (MachStr ab)
- 2 -> do
- return (MachNullAddr)
- 3 -> do
- ad <- get bh
- return (MachInt ad)
- 4 -> do
- ae <- get bh
- return (MachInt64 ae)
- 5 -> do
- af <- get bh
- return (MachWord af)
- 6 -> do
- ag <- get bh
- return (MachWord64 ag)
- 7 -> do
- ah <- get bh
- return (MachFloat ah)
- 8 -> do
- ai <- get bh
- return (MachDouble ai)
- 9 -> do
- aj <- get bh
- mb <- get bh
- fod <- get bh
- return (MachLabel aj mb fod)
- \end{code}
- \begin{code}
- instance Outputable Literal where
- ppr lit = pprLit lit
- instance Show Literal where
- showsPrec p lit = showsPrecSDoc p (ppr lit)
- instance Eq Literal where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
- instance Ord Literal where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare a b = cmpLit a b
- \end{code}
- Construction
- ~~~~~~~~~~~~
- \begin{code}
- -- | Creates a 'Literal' of type @Int#@
- mkMachInt :: Integer -> Literal
- 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
- -- | Creates a 'Literal' of type @Word#@
- mkMachWord :: Integer -> Literal
- mkMachWord x = -- ASSERT2( inWordRange x, integer x )
- MachWord x
- -- | Creates a 'Literal' of type @Int64#@
- mkMachInt64 :: Integer -> Literal
- mkMachInt64 x = MachInt64 x
- -- | Creates a 'Literal' of type @Word64#@
- mkMachWord64 :: Integer -> Literal
- mkMachWord64 x = MachWord64 x
- -- | Creates a 'Literal' of type @Float#@
- mkMachFloat :: Rational -> Literal
- mkMachFloat = MachFloat
- -- | Creates a 'Literal' of type @Double#@
- mkMachDouble :: Rational -> Literal
- mkMachDouble = MachDouble
- -- | Creates a 'Literal' of type @Char#@
- mkMachChar :: Char -> Literal
- mkMachChar = MachChar
- -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
- -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
- mkMachString :: String -> Literal
- mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
- inIntRange, inWordRange :: Integer -> Bool
- inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
- inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
- inCharRange :: Char -> Bool
- inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
- -- | Tests whether the literal represents a zero of whatever type it is
- 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 _ = False
- \end{code}
- Coercions
- ~~~~~~~~~
- \begin{code}
- 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)
- | otherwise = MachInt w
- 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 (ord c))
- int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
- float2IntLit (MachFloat f) = MachInt (truncate f)
- int2FloatLit (MachInt i) = MachFloat (fromInteger i)
- double2IntLit (MachDouble f) = MachInt (truncate f)
- int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
- float2DoubleLit (MachFloat f) = MachDouble f
- double2FloatLit (MachDouble d) = MachFloat d
- nullAddrLit :: Literal
- nullAddrLit = MachNullAddr
- \end{code}
- Predicates
- ~~~~~~~~~~
- \begin{code}
- -- | True if there is absolutely no penalty to duplicating the literal.
- -- False principally of strings
- litIsTrivial :: Literal -> Bool
- -- c.f. CoreUtils.exprIsTrivial
- litIsTrivial (MachStr _) = False
- litIsTrivial _ = True
- -- | True if code space does not go bad if we duplicate this literal
- -- Currently we treat it just like 'litIsTrivial'
- litIsDupable :: Literal -> Bool
- -- c.f. CoreUtils.exprIsDupable
- litIsDupable (MachStr _) = False
- litIsDupable _ = True
- litFitsInChar :: Literal -> Bool
- litFitsInChar (MachInt i)
- = fromInteger i <= ord minBound
- && fromInteger i >= ord maxBound
- litFitsInChar _ = False
- \end{code}
- Types
- ~~~~~
- \begin{code}
- -- | Find the Haskell 'Type' the literal occupies
- literalType :: Literal -> Type
- literalType MachNullAddr = addrPrimTy
- literalType (MachChar _) = charPrimTy
- literalType (MachStr _) = addrPrimTy
- literalType (MachInt _) = intPrimTy
- literalType (MachWord _) = wordPrimTy
- literalType (MachInt64 _) = int64PrimTy
- literalType (MachWord64 _) = word64PrimTy
- literalType (MachFloat _) = floatPrimTy
- literalType (MachDouble _) = doublePrimTy
- literalType (MachLabel _ _ _) = addrPrimTy
- absentLiteralOf :: TyCon -> Maybe Literal
- -- Return a literal of the appropriate primtive
- -- TyCon, to use as a placeholder when it doesn't matter
- absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
- absent_lits :: UniqFM Literal
- absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr)
- , (charPrimTyConKey, MachChar 'x')
- , (intPrimTyConKey, MachInt 0)
- , (int64PrimTyConKey, MachInt64 0)
- , (floatPrimTyConKey, MachFloat 0)
- , (doublePrimTyConKey, MachDouble 0)
- , (wordPrimTyConKey, MachWord 0)
- , (word64PrimTyConKey, MachWord64 0) ]
- \end{code}
- Comparison
- ~~~~~~~~~~
- \begin{code}
- cmpLit :: Literal -> Literal -> Ordering
- cmpLit (MachChar a) (MachChar b) = a `compare` b
- cmpLit (MachStr a) (MachStr b) = a `compare` b
- cmpLit (MachNullAddr) (MachNullAddr) = EQ
- cmpLit (MachInt a) (MachInt b) = a `compare` b
- cmpLit (MachWord a) (MachWord b) = a `compare` b
- cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
- 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 lit1 lit2 | litTag lit1 <# litTag lit2 = LT
- | otherwise = GT
- litTag :: Literal -> FastInt
- litTag (MachChar _) = _ILIT(1)
- litTag (MachStr _) = _ILIT(2)
- litTag (MachNullAddr) = _ILIT(3)
- litTag (MachInt _) = _ILIT(4)
- litTag (MachWord _) = _ILIT(5)
- litTag (MachInt64 _) = _ILIT(6)
- litTag (MachWord64 _) = _ILIT(7)
- litTag (MachFloat _) = _ILIT(8)
- litTag (MachDouble _) = _ILIT(9)
- litTag (MachLabel _ _ _) = _ILIT(10)
- \end{code}
- Printing
- ~~~~~~~~
- * MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
- exceptions: MachFloat gets an initial keyword prefix.
- \begin{code}
- pprLit :: Literal -> SDoc
- pprLit (MachChar ch) = pprHsChar ch
- pprLit (MachStr s) = pprHsString s
- pprLit (MachInt i) = pprIntVal i
- pprLit (MachInt64 i) = ptext (sLit "__int64") <+> integer i
- pprLit (MachWord w) = ptext (sLit "__word") <+> integer w
- pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w
- pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f
- pprLit (MachDouble d) = rational d
- pprLit (MachNullAddr) = ptext (sLit "__NULL")
- pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod
- where b = case mb of
- Nothing -> pprHsString l
- Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
- pprIntVal :: Integer -> SDoc
- -- ^ Print negative integers with parens to be sure it's unambiguous
- pprIntVal i | i < 0 = parens (integer i)
- | otherwise = integer i
- \end{code}
- %************************************************************************
- %* *
- \subsection{Hashing}
- %* *
- %************************************************************************
- Hash values should be zero or a positive integer. No negatives please.
- (They mess up the UniqFM for some reason.)
- \begin{code}
- hashLiteral :: Literal -> Int
- hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints
- hashLiteral (MachStr s) = hashFS s
- hashLiteral (MachNullAddr) = 0
- hashLiteral (MachInt i) = hashInteger i
- hashLiteral (MachInt64 i) = hashInteger i
- hashLiteral (MachWord i) = hashInteger i
- hashLiteral (MachWord64 i) = hashInteger i
- hashLiteral (MachFloat r) = hashRational r
- hashLiteral (MachDouble r) = hashRational r
- hashLiteral (MachLabel s _ _) = hashFS s
- hashRational :: Rational -> Int
- hashRational r = hashInteger (numerator r)
- hashInteger :: Integer -> Int
- hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
- -- The 1+ is to avoid zero, which is a Bad Number
- -- since we use * to combine hash values
- hashFS :: FastString -> Int
- hashFS s = iBox (uniqueOfFS s)
- \end{code}