module GHC.Types.Literal
(
Literal(..)
, LitNumType(..)
, mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked
, mkLitWord, mkLitWordWrap, mkLitWordWrapC
, mkLitInt64, mkLitInt64Wrap
, mkLitWord64, mkLitWord64Wrap
, mkLitFloat, mkLitDouble
, mkLitChar, mkLitString
, mkLitInteger, mkLitNatural
, mkLitNumber, mkLitNumberWrap
, literalType
, absentLiteralOf
, pprLiteral
, litNumIsSigned
, litNumCheckRange
, litIsDupable, litIsTrivial, litIsLifted
, inCharRange
, isZeroLit
, litFitsInChar
, litValue, isLitValue, isLitValue_maybe, mapLitValue
, word2IntLit, int2WordLit
, narrowLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, char2IntLit, int2CharLit
, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
, nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Basic
import GHC.Utils.Binary
import GHC.Settings.Constants
import GHC.Platform
import GHC.Types.Unique.FM
import GHC.Utils.Misc
import Data.ByteString (ByteString)
import Data.Int
import Data.Word
import Data.Char
import Data.Maybe ( isJust )
import Data.Data ( Data )
import Data.Proxy
import Numeric ( fromRat )
data Literal
= LitChar Char
| LitNumber !LitNumType !Integer
| LitString !ByteString
| LitNullAddr
| LitRubbish
| LitFloat Rational
| LitDouble Rational
| LitLabel FastString (Maybe Int) FunctionOrData
deriving Data
data LitNumType
= LitNumInteger
| LitNumNatural
| LitNumInt
| LitNumInt64
| LitNumWord
| LitNumWord64
deriving (Data,Enum,Eq,Ord)
litNumIsSigned :: LitNumType -> Bool
litNumIsSigned nt = case nt of
LitNumInteger -> True
LitNumNatural -> False
LitNumInt -> True
LitNumInt64 -> True
LitNumWord -> False
LitNumWord64 -> False
instance Binary LitNumType where
put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
get bh = do
h <- getByte bh
return (toEnum (fromIntegral h))
instance Binary Literal where
put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
put_ bh (LitNullAddr) = do putByte bh 2
put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah
put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai
put_ bh (LitLabel aj mb fod)
= do putByte bh 5
put_ bh aj
put_ bh mb
put_ bh fod
put_ bh (LitNumber nt i)
= do putByte bh 6
put_ bh nt
put_ bh i
put_ bh (LitRubbish) = do putByte bh 7
get bh = do
h <- getByte bh
case h of
0 -> do
aa <- get bh
return (LitChar aa)
1 -> do
ab <- get bh
return (LitString ab)
2 -> do
return (LitNullAddr)
3 -> do
ah <- get bh
return (LitFloat ah)
4 -> do
ai <- get bh
return (LitDouble ai)
5 -> do
aj <- get bh
mb <- get bh
fod <- get bh
return (LitLabel aj mb fod)
6 -> do
nt <- get bh
i <- get bh
return (LitNumber nt i)
_ -> do
return (LitRubbish)
instance Outputable Literal where
ppr = pprLiteral id
instance Eq Literal where
a == b = compare a b == EQ
instance Ord Literal where
compare = cmpLit
wrapLitNumber :: Platform -> Literal -> Literal
wrapLitNumber platform v@(LitNumber nt i) = case nt of
LitNumInt -> case platformWordSize platform of
PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32))
PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64))
LitNumWord -> case platformWordSize platform of
PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32))
PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64))
LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64))
LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64))
LitNumInteger -> v
LitNumNatural -> v
wrapLitNumber _ x = x
mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Literal
mkLitNumberWrap platform nt i = wrapLitNumber platform (LitNumber nt i)
litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool
litNumCheckRange platform nt i = case nt of
LitNumInt -> platformInIntRange platform i
LitNumWord -> platformInWordRange platform i
LitNumInt64 -> inInt64Range i
LitNumWord64 -> inWord64Range i
LitNumNatural -> i >= 0
LitNumInteger -> True
mkLitNumber :: Platform -> LitNumType -> Integer -> Literal
mkLitNumber platform nt i =
ASSERT2(litNumCheckRange platform nt i, integer i)
(LitNumber nt i)
mkLitInt :: Platform -> Integer -> Literal
mkLitInt platform x = ASSERT2( platformInIntRange platform x, integer x )
(mkLitIntUnchecked x)
mkLitIntWrap :: Platform -> Integer -> Literal
mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i
mkLitIntUnchecked :: Integer -> Literal
mkLitIntUnchecked i = LitNumber LitNumInt i
mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool)
mkLitIntWrapC platform i = (n, i /= i')
where
n@(LitNumber _ i') = mkLitIntWrap platform i
mkLitWord :: Platform -> Integer -> Literal
mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x )
(mkLitWordUnchecked x)
mkLitWordWrap :: Platform -> Integer -> Literal
mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i
mkLitWordUnchecked :: Integer -> Literal
mkLitWordUnchecked i = LitNumber LitNumWord i
mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool)
mkLitWordWrapC platform i = (n, i /= i')
where
n@(LitNumber _ i') = mkLitWordWrap platform i
mkLitInt64 :: Integer -> Literal
mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)
mkLitInt64Wrap :: Platform -> Integer -> Literal
mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i
mkLitInt64Unchecked :: Integer -> Literal
mkLitInt64Unchecked i = LitNumber LitNumInt64 i
mkLitWord64 :: Integer -> Literal
mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x)
mkLitWord64Wrap :: Platform -> Integer -> Literal
mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i
mkLitWord64Unchecked :: Integer -> Literal
mkLitWord64Unchecked i = LitNumber LitNumWord64 i
mkLitFloat :: Rational -> Literal
mkLitFloat = LitFloat
mkLitDouble :: Rational -> Literal
mkLitDouble = LitDouble
mkLitChar :: Char -> Literal
mkLitChar = LitChar
mkLitString :: String -> Literal
mkLitString s = LitString (bytesFS $ mkFastString s)
mkLitInteger :: Integer -> Literal
mkLitInteger x = LitNumber LitNumInteger x
mkLitNatural :: Integer -> Literal
mkLitNatural x = ASSERT2( inNaturalRange x, integer x )
(LitNumber LitNumNatural x)
inNaturalRange :: Integer -> Bool
inNaturalRange x = x >= 0
inInt64Range, inWord64Range :: Integer -> Bool
inInt64Range x = x >= toInteger (minBound :: Int64) &&
x <= toInteger (maxBound :: Int64)
inWord64Range x = x >= toInteger (minBound :: Word64) &&
x <= toInteger (maxBound :: Word64)
inCharRange :: Char -> Bool
inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
isZeroLit :: Literal -> Bool
isZeroLit (LitNumber _ 0) = True
isZeroLit (LitFloat 0) = True
isZeroLit (LitDouble 0) = True
isZeroLit _ = False
litValue :: Literal -> Integer
litValue l = case isLitValue_maybe l of
Just x -> x
Nothing -> pprPanic "litValue" (ppr l)
isLitValue_maybe :: Literal -> Maybe Integer
isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c
isLitValue_maybe (LitNumber _ i) = Just i
isLitValue_maybe _ = Nothing
mapLitValue :: Platform -> (Integer -> Integer) -> Literal -> Literal
mapLitValue _ f (LitChar c) = mkLitChar (fchar c)
where fchar = chr . fromInteger . f . toInteger . ord
mapLitValue platform f (LitNumber nt i) = wrapLitNumber platform (LitNumber nt (f i))
mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l)
isLitValue :: Literal -> Bool
isLitValue = isJust . isLitValue_maybe
narrow8IntLit, narrow16IntLit, narrow32IntLit,
narrow8WordLit, narrow16WordLit, narrow32WordLit,
char2IntLit, int2CharLit,
float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
float2DoubleLit, double2FloatLit
:: Literal -> Literal
word2IntLit, int2WordLit :: Platform -> Literal -> Literal
word2IntLit platform (LitNumber LitNumWord w)
| w > platformMaxInt platform = mkLitInt platform (w platformMaxWord platform 1)
| otherwise = mkLitInt platform w
word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
int2WordLit platform (LitNumber LitNumInt i)
| i < 0 = mkLitWord platform (1 + platformMaxWord platform + i)
| otherwise = mkLitWord platform i
int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
narrowLit _ (LitNumber nt i) = LitNumber nt (toInteger (fromInteger i :: a))
narrowLit _ l = pprPanic "narrowLit" (ppr l)
narrow8IntLit = narrowLit (Proxy :: Proxy Int8)
narrow16IntLit = narrowLit (Proxy :: Proxy Int16)
narrow32IntLit = narrowLit (Proxy :: Proxy Int32)
narrow8WordLit = narrowLit (Proxy :: Proxy Word8)
narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
narrow32WordLit = narrowLit (Proxy :: Proxy Word32)
char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c))
char2IntLit l = pprPanic "char2IntLit" (ppr l)
int2CharLit (LitNumber _ i) = LitChar (chr (fromInteger i))
int2CharLit l = pprPanic "int2CharLit" (ppr l)
float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f)
float2IntLit l = pprPanic "float2IntLit" (ppr l)
int2FloatLit (LitNumber _ i) = LitFloat (fromInteger i)
int2FloatLit l = pprPanic "int2FloatLit" (ppr l)
double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f)
double2IntLit l = pprPanic "double2IntLit" (ppr l)
int2DoubleLit (LitNumber _ i) = LitDouble (fromInteger i)
int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l)
float2DoubleLit (LitFloat f) = LitDouble f
float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l)
double2FloatLit (LitDouble d) = LitFloat d
double2FloatLit l = pprPanic "double2FloatLit" (ppr l)
nullAddrLit :: Literal
nullAddrLit = LitNullAddr
rubbishLit :: Literal
rubbishLit = LitRubbish
litIsTrivial :: Literal -> Bool
litIsTrivial (LitString _) = False
litIsTrivial (LitNumber nt _) = case nt of
LitNumInteger -> False
LitNumNatural -> False
LitNumInt -> True
LitNumInt64 -> True
LitNumWord -> True
LitNumWord64 -> True
litIsTrivial _ = True
litIsDupable :: Platform -> Literal -> Bool
litIsDupable platform x = case x of
(LitNumber nt i) -> case nt of
LitNumInteger -> platformInIntRange platform i
LitNumNatural -> platformInWordRange platform i
LitNumInt -> True
LitNumInt64 -> True
LitNumWord -> True
LitNumWord64 -> True
(LitString _) -> False
_ -> True
litFitsInChar :: Literal -> Bool
litFitsInChar (LitNumber _ i) = i >= toInteger (ord minBound)
&& i <= toInteger (ord maxBound)
litFitsInChar _ = False
litIsLifted :: Literal -> Bool
litIsLifted (LitNumber nt _) = case nt of
LitNumInteger -> True
LitNumNatural -> True
LitNumInt -> False
LitNumInt64 -> False
LitNumWord -> False
LitNumWord64 -> False
litIsLifted _ = False
literalType :: Literal -> Type
literalType LitNullAddr = addrPrimTy
literalType (LitChar _) = charPrimTy
literalType (LitString _) = addrPrimTy
literalType (LitFloat _) = floatPrimTy
literalType (LitDouble _) = doublePrimTy
literalType (LitLabel _ _ _) = addrPrimTy
literalType (LitNumber lt _) = case lt of
LitNumInteger -> integerTy
LitNumNatural -> naturalTy
LitNumInt -> intPrimTy
LitNumInt64 -> int64PrimTy
LitNumWord -> wordPrimTy
LitNumWord64 -> word64PrimTy
literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a)
where
a = alphaTyVarUnliftedRep
absentLiteralOf :: TyCon -> Maybe Literal
absentLiteralOf tc = lookupUFM absent_lits tc
absent_lits :: UniqFM TyCon Literal
absent_lits = listToUFM_Directly
[ (addrPrimTyConKey, LitNullAddr)
, (charPrimTyConKey, LitChar 'x')
, (intPrimTyConKey, mkLitIntUnchecked 0)
, (int64PrimTyConKey, mkLitInt64Unchecked 0)
, (wordPrimTyConKey, mkLitWordUnchecked 0)
, (word64PrimTyConKey, mkLitWord64Unchecked 0)
, (floatPrimTyConKey, LitFloat 0)
, (doublePrimTyConKey, LitDouble 0)
]
cmpLit :: Literal -> Literal -> Ordering
cmpLit (LitChar a) (LitChar b) = a `compare` b
cmpLit (LitString a) (LitString b) = a `compare` b
cmpLit (LitNullAddr) (LitNullAddr) = EQ
cmpLit (LitFloat a) (LitFloat b) = a `compare` b
cmpLit (LitDouble a) (LitDouble b) = a `compare` b
cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b
cmpLit (LitNumber nt1 a) (LitNumber nt2 b)
| nt1 == nt2 = a `compare` b
| otherwise = nt1 `compare` nt2
cmpLit (LitRubbish) (LitRubbish) = EQ
cmpLit lit1 lit2
| litTag lit1 < litTag lit2 = LT
| otherwise = GT
litTag :: Literal -> Int
litTag (LitChar _) = 1
litTag (LitString _) = 2
litTag (LitNullAddr) = 3
litTag (LitFloat _) = 4
litTag (LitDouble _) = 5
litTag (LitLabel _ _ _) = 6
litTag (LitNumber {}) = 7
litTag (LitRubbish) = 8
pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
pprLiteral _ (LitChar c) = pprPrimChar c
pprLiteral _ (LitString s) = pprHsBytes s
pprLiteral _ (LitNullAddr) = text "__NULL"
pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix
pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix
pprLiteral add_par (LitNumber nt i)
= case nt of
LitNumInteger -> pprIntegerVal add_par i
LitNumNatural -> pprIntegerVal add_par i
LitNumInt -> pprPrimInt i
LitNumInt64 -> pprPrimInt64 i
LitNumWord -> pprPrimWord i
LitNumWord64 -> pprPrimWord64 i
pprLiteral add_par (LitLabel l mb fod) =
add_par (text "__label" <+> b <+> ppr fod)
where b = case mb of
Nothing -> pprHsString l
Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
pprLiteral _ (LitRubbish) = text "__RUBBISH"
pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
pprIntegerVal add_par i | i < 0 = add_par (integer i)
| otherwise = integer i