summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSylvain Henry <hsyl20@gmail.com>2018-06-15 16:23:53 -0400
committerBen Gamari <ben@smart-cactus.org>2018-06-15 16:23:54 -0400
commitfe770c211631e7b4c9b0b1e88ef9b6046c6585ef (patch)
treee6a061a92d8d0d71d40c699982ee471627d816e0 /compiler
parent42f3b53b5bc4674e41f16de08094821fe1aaec00 (diff)
downloadhaskell-fe770c211631e7b4c9b0b1e88ef9b6046c6585ef.tar.gz
Built-in Natural literals in Core
Add support for built-in Natural literals in Core. - Replace MachInt,MachWord, LitInteger, etc. with a single LitNumber constructor with a LitNumType field - Support built-in Natural literals - Add desugar warning for negative literals - Move Maybe(..) from GHC.Base to GHC.Maybe for module dependency reasons This patch introduces only a few rules for Natural literals (compared to Integer's rules). Factorization of the built-in rules for numeric literals will be done in another patch as this one is already big to review. Test Plan: validate test build with integer-simple Reviewers: hvr, bgamari, goldfire, Bodigrim, simonmar Reviewed By: bgamari Subscribers: phadej, simonpj, RyanGlScott, carter, hsyl20, rwbarton, thomie GHC Trac Issues: #14170, #14465 Differential Revision: https://phabricator.haskell.org/D4212
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Literal.hs409
-rw-r--r--compiler/codeGen/StgCmmCon.hs2
-rw-r--r--compiler/codeGen/StgCmmUtils.hs11
-rw-r--r--compiler/coreSyn/CorePrep.hs76
-rw-r--r--compiler/coreSyn/CoreUnfold.hs3
-rw-r--r--compiler/coreSyn/CoreUtils.hs19
-rw-r--r--compiler/coreSyn/MkCore.hs10
-rw-r--r--compiler/deSugar/MatchLit.hs86
-rw-r--r--compiler/ghci/ByteCodeAsm.hs12
-rw-r--r--compiler/ghci/ByteCodeGen.hs42
-rw-r--r--compiler/iface/TcIface.hs8
-rw-r--r--compiler/main/TidyPgm.hs103
-rw-r--r--compiler/prelude/PrelNames.hs39
-rw-r--r--compiler/prelude/PrelRules.hs220
-rw-r--r--compiler/prelude/TysWiredIn.hs6
-rw-r--r--compiler/simplStg/UnariseStg.hs12
-rw-r--r--compiler/stgSyn/CoreToStg.hs7
17 files changed, 664 insertions, 401 deletions
diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs
index 0392a98274..21f4a92290 100644
--- a/compiler/basicTypes/Literal.hs
+++ b/compiler/basicTypes/Literal.hs
@@ -5,12 +5,13 @@
\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
-}
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
module Literal
(
-- * Main data type
Literal(..) -- Exported to ParseIface
+ , LitNumType(..)
-- ** Creating Literals
, mkMachInt, mkMachIntWrap, mkMachIntWrapC
@@ -19,12 +20,15 @@ module Literal
, mkMachWord64, mkMachWord64Wrap
, mkMachFloat, mkMachDouble
, mkMachChar, mkMachString
- , mkLitInteger
+ , mkLitInteger, mkLitNatural
+ , mkLitNumber, mkLitNumberWrap
-- ** Operations on Literals
, literalType
, absentLiteralOf
, pprLiteral
+ , litNumIsSigned
+ , litNumCheckRange
-- ** Predicates on Literals and their contents
, litIsDupable, litIsTrivial, litIsLifted
@@ -35,6 +39,7 @@ module Literal
-- ** Coercions
, word2IntLit, int2WordLit
+ , narrowLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, char2IntLit, int2CharLit
@@ -66,6 +71,7 @@ import Data.Word
import Data.Char
import Data.Maybe ( isJust )
import Data.Data ( Data )
+import Data.Proxy
import Numeric ( fromRat )
{-
@@ -95,6 +101,10 @@ data Literal
-- First the primitive guys
MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
+ | LitNumber !LitNumType !Integer Type
+ -- ^ Any numeric literal that can be
+ -- internally represented with an Integer
+
| MachStr ByteString -- ^ A string-literal: stored and emitted
-- UTF-8 encoded, we'll arrange to decode it
-- at runtime. Also emitted with a @'\0'@
@@ -104,11 +114,6 @@ data Literal
-- that can be represented as a Literal. Create
-- with 'nullAddrLit'
- | MachInt Integer -- ^ @Int#@ - according to target machine
- | MachInt64 Integer -- ^ @Int64#@ - exactly 64 bits
- | MachWord Integer -- ^ @Word#@ - according to target machine
- | MachWord64 Integer -- ^ @Word64#@ - exactly 64 bits
-
| MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat'
| MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
@@ -123,11 +128,28 @@ data Literal
-- the label expects. Only applicable with
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
-
- | LitInteger Integer Type -- ^ Integer literals
- -- See Note [Integer literals]
deriving Data
+-- | Numeric literal type
+data LitNumType
+ = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])
+ | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])
+ | LitNumInt -- ^ @Int#@ - according to target machine
+ | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits
+ | LitNumWord -- ^ @Word#@ - according to target machine
+ | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits
+ deriving (Data,Enum,Eq,Ord)
+
+-- | Indicate if a numeric literal type supports negative numbers
+litNumIsSigned :: LitNumType -> Bool
+litNumIsSigned nt = case nt of
+ LitNumInteger -> True
+ LitNumNatural -> False
+ LitNumInt -> True
+ LitNumInt64 -> True
+ LitNumWord -> False
+ LitNumWord64 -> False
+
{-
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -146,26 +168,33 @@ below), we don't have convenient access to the mkInteger Id. So we
just use an error thunk, and fill in the real Id when we do tcIfaceLit
in TcIface.
+Note [Natural literals]
+~~~~~~~~~~~~~~~~~~~~~~~
+Similar to Integer literals.
-Binary instance
-}
+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 (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 (MachFloat ah) = do putByte bh 3; put_ bh ah
+ put_ bh (MachDouble ai) = do putByte bh 4; put_ bh ai
put_ bh (MachLabel aj mb fod)
- = do putByte bh 9
+ = do putByte bh 5
put_ bh aj
put_ bh mb
put_ bh fod
- put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
+ put_ bh (LitNumber nt i _)
+ = do putByte bh 6
+ put_ bh nt
+ put_ bh i
get bh = do
h <- getByte bh
case h of
@@ -178,32 +207,31 @@ instance Binary Literal where
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
+ 4 -> do
ai <- get bh
return (MachDouble ai)
- 9 -> do
+ 5 -> do
aj <- get bh
mb <- get bh
fod <- get bh
return (MachLabel aj mb fod)
_ -> do
- i <- get bh
- -- See Note [Integer literals]
- return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
+ nt <- get bh
+ i <- get bh
+ let t = case nt of
+ LitNumInt -> intPrimTy
+ LitNumInt64 -> int64PrimTy
+ LitNumWord -> wordPrimTy
+ LitNumWord64 -> word64PrimTy
+ -- See Note [Integer literals]
+ LitNumInteger ->
+ panic "Evaluated the place holder for mkInteger"
+ -- and Note [Natural literals]
+ LitNumNatural ->
+ panic "Evaluated the place holder for mkNatural"
+ return (LitNumber nt i t)
instance Outputable Literal where
ppr lit = pprLiteral (\d -> d) lit
@@ -242,79 +270,116 @@ doesn't yield a warning. Instead we simply squash the value into the *target*
Int/Word range.
-}
+-- | Wrap a literal number according to its type
+wrapLitNumber :: DynFlags -> Literal -> Literal
+wrapLitNumber dflags v@(LitNumber nt i t) = case nt of
+ LitNumInt -> case platformWordSize (targetPlatform dflags) of
+ 4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t
+ 8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
+ w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
+ LitNumWord -> case platformWordSize (targetPlatform dflags) of
+ 4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t
+ 8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
+ w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
+ LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
+ LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
+ LitNumInteger -> v
+ LitNumNatural -> v
+wrapLitNumber _ x = x
+
+-- | Create a numeric 'Literal' of the given type
+mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal
+mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t)
+
+-- | Check that a given number is in the range of a numeric literal
+litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool
+litNumCheckRange dflags nt i = case nt of
+ LitNumInt -> inIntRange dflags i
+ LitNumWord -> inWordRange dflags i
+ LitNumInt64 -> inInt64Range i
+ LitNumWord64 -> inWord64Range i
+ LitNumNatural -> i >= 0
+ LitNumInteger -> True
+
+-- | Create a numeric 'Literal' of the given type
+mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal
+mkLitNumber dflags nt i t =
+ ASSERT2(litNumCheckRange dflags nt i, integer i)
+ (LitNumber nt i t)
+
-- | Creates a 'Literal' of type @Int#@
mkMachInt :: DynFlags -> Integer -> Literal
mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x )
- MachInt x
-
-wrapInt :: DynFlags -> Integer -> Integer
-wrapInt dflags i
- = case platformWordSize (targetPlatform dflags) of
- 4 -> toInteger (fromIntegral i :: Int32)
- 8 -> toInteger (fromIntegral i :: Int64)
- w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w)
+ (mkMachIntUnchecked x)
-- | Creates a 'Literal' of type @Int#@.
-- If the argument is out of the (target-dependent) range, it is wrapped.
-- See Note [Word/Int underflow/overflow]
mkMachIntWrap :: DynFlags -> Integer -> Literal
-mkMachIntWrap dflags i = MachInt (wrapInt dflags i)
+mkMachIntWrap dflags i = wrapLitNumber dflags $ mkMachIntUnchecked i
+
+-- | Creates a 'Literal' of type @Int#@ without checking its range.
+mkMachIntUnchecked :: Integer -> Literal
+mkMachIntUnchecked i = LitNumber LitNumInt i intPrimTy
-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating
-- overflow. That is, if the argument is out of the (target-dependent) range
-- the argument is wrapped and the overflow flag will be set.
-- See Note [Word/Int underflow/overflow]
mkMachIntWrapC :: DynFlags -> Integer -> (Literal, Bool)
-mkMachIntWrapC dflags i = (MachInt i', i /= i')
+mkMachIntWrapC dflags i = (n, i /= i')
where
- i' = wrapInt dflags i
+ n@(LitNumber _ i' _) = mkMachIntWrap dflags i
-- | Creates a 'Literal' of type @Word#@
mkMachWord :: DynFlags -> Integer -> Literal
mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x )
- MachWord x
-
-wrapWord :: DynFlags -> Integer -> Integer
-wrapWord dflags i
- = case platformWordSize (targetPlatform dflags) of
- 4 -> toInteger (fromIntegral i :: Word32)
- 8 -> toInteger (fromIntegral i :: Word64)
- w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w)
+ (mkMachWordUnchecked x)
-- | Creates a 'Literal' of type @Word#@.
-- If the argument is out of the (target-dependent) range, it is wrapped.
-- See Note [Word/Int underflow/overflow]
mkMachWordWrap :: DynFlags -> Integer -> Literal
-mkMachWordWrap dflags i = MachWord (wrapWord dflags i)
+mkMachWordWrap dflags i = wrapLitNumber dflags $ mkMachWordUnchecked i
+
+-- | Creates a 'Literal' of type @Word#@ without checking its range.
+mkMachWordUnchecked :: Integer -> Literal
+mkMachWordUnchecked i = LitNumber LitNumWord i wordPrimTy
-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating
-- carry. That is, if the argument is out of the (target-dependent) range
-- the argument is wrapped and the carry flag will be set.
-- See Note [Word/Int underflow/overflow]
mkMachWordWrapC :: DynFlags -> Integer -> (Literal, Bool)
-mkMachWordWrapC dflags i = (MachWord i', i /= i')
+mkMachWordWrapC dflags i = (n, i /= i')
where
- i' = wrapWord dflags i
+ n@(LitNumber _ i' _) = mkMachWordWrap dflags i
-- | Creates a 'Literal' of type @Int64#@
mkMachInt64 :: Integer -> Literal
-mkMachInt64 x = ASSERT2( inInt64Range x, integer x )
- MachInt64 x
+mkMachInt64 x = ASSERT2( inInt64Range x, integer x ) (mkMachInt64Unchecked x)
-- | Creates a 'Literal' of type @Int64#@.
-- If the argument is out of the range, it is wrapped.
-mkMachInt64Wrap :: Integer -> Literal
-mkMachInt64Wrap i = MachInt64 (toInteger (fromIntegral i :: Int64))
+mkMachInt64Wrap :: DynFlags -> Integer -> Literal
+mkMachInt64Wrap dflags i = wrapLitNumber dflags $ mkMachInt64Unchecked i
+
+-- | Creates a 'Literal' of type @Int64#@ without checking its range.
+mkMachInt64Unchecked :: Integer -> Literal
+mkMachInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy
-- | Creates a 'Literal' of type @Word64#@
mkMachWord64 :: Integer -> Literal
-mkMachWord64 x = ASSERT2( inWord64Range x, integer x )
- MachWord64 x
+mkMachWord64 x = ASSERT2( inWord64Range x, integer x ) (mkMachWord64Unchecked x)
-- | Creates a 'Literal' of type @Word64#@.
-- If the argument is out of the range, it is wrapped.
-mkMachWord64Wrap :: Integer -> Literal
-mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64))
+mkMachWord64Wrap :: DynFlags -> Integer -> Literal
+mkMachWord64Wrap dflags i = wrapLitNumber dflags $ mkMachWord64Unchecked i
+
+-- | Creates a 'Literal' of type @Word64#@ without checking its range.
+mkMachWord64Unchecked :: Integer -> Literal
+mkMachWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy
-- | Creates a 'Literal' of type @Float#@
mkMachFloat :: Rational -> Literal
@@ -335,12 +400,19 @@ mkMachString :: String -> Literal
mkMachString s = MachStr (fastStringToByteString $ mkFastString s)
mkLitInteger :: Integer -> Type -> Literal
-mkLitInteger = LitInteger
+mkLitInteger x ty = LitNumber LitNumInteger x ty
+
+mkLitNatural :: Integer -> Type -> Literal
+mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x )
+ (LitNumber LitNumNatural x ty)
inIntRange, inWordRange :: DynFlags -> Integer -> Bool
inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
+inNaturalRange :: Integer -> Bool
+inNaturalRange x = x >= 0
+
inInt64Range, inWord64Range :: Integer -> Bool
inInt64Range x = x >= toInteger (minBound :: Int64) &&
x <= toInteger (maxBound :: Int64)
@@ -352,49 +424,39 @@ 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
+isZeroLit (LitNumber _ 0 _) = True
+isZeroLit (MachFloat 0) = True
+isZeroLit (MachDouble 0) = True
+isZeroLit _ = False
-- | Returns the 'Integer' contained in the 'Literal', for when that makes
--- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
+-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.
litValue :: Literal -> Integer
litValue l = case isLitValue_maybe l of
Just x -> x
Nothing -> pprPanic "litValue" (ppr l)
-- | Returns the 'Integer' contained in the 'Literal', for when that makes
--- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
+-- sense, i.e. for 'Char' and numbers.
isLitValue_maybe :: Literal -> Maybe Integer
-isLitValue_maybe (MachChar c) = Just $ toInteger $ ord c
-isLitValue_maybe (MachInt i) = Just i
-isLitValue_maybe (MachInt64 i) = Just i
-isLitValue_maybe (MachWord i) = Just i
-isLitValue_maybe (MachWord64 i) = Just i
-isLitValue_maybe (LitInteger i _) = Just i
-isLitValue_maybe _ = Nothing
+isLitValue_maybe (MachChar c) = Just $ toInteger $ ord c
+isLitValue_maybe (LitNumber _ i _) = Just i
+isLitValue_maybe _ = Nothing
-- | Apply a function to the 'Integer' contained in the 'Literal', for when that
--- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For
--- fixed-size integral literals, the result will be wrapped in
--- accordance with the semantics of the target type.
+-- makes sense, e.g. for 'Char' and numbers.
+-- For fixed-size integral literals, the result will be wrapped in accordance
+-- with the semantics of the target type.
-- See Note [Word/Int underflow/overflow]
mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
-mapLitValue _ f (MachChar c) = mkMachChar (fchar c)
+mapLitValue _ f (MachChar c) = mkMachChar (fchar c)
where fchar = chr . fromInteger . f . toInteger . ord
-mapLitValue dflags f (MachInt i) = mkMachIntWrap dflags (f i)
-mapLitValue _ f (MachInt64 i) = mkMachInt64Wrap (f i)
-mapLitValue dflags f (MachWord i) = mkMachWordWrap dflags (f i)
-mapLitValue _ f (MachWord64 i) = mkMachWord64Wrap (f i)
-mapLitValue _ f (LitInteger i t) = mkLitInteger (f i) t
-mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l)
+mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags
+ (LitNumber nt (f i) t)
+mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l)
-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
--- 'Int', 'Word' and 'LitInteger'.
+-- 'Int', 'Word', 'LitInteger' and 'LitNatural'.
isLitValue :: Literal -> Bool
isLitValue = isJust . isLitValue_maybe
@@ -411,43 +473,42 @@ narrow8IntLit, narrow16IntLit, narrow32IntLit,
:: Literal -> Literal
word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
-word2IntLit dflags (MachWord w)
- | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
- | otherwise = MachInt w
+word2IntLit dflags (LitNumber LitNumWord w _)
+ | w > tARGET_MAX_INT dflags = mkMachInt dflags (w - tARGET_MAX_WORD dflags - 1)
+ | otherwise = mkMachInt dflags w
word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
-int2WordLit dflags (MachInt i)
- | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD
- | otherwise = MachWord i
+int2WordLit dflags (LitNumber LitNumInt i _)
+ | i < 0 = mkMachWord dflags (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD
+ | otherwise = mkMachWord dflags i
int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
-narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
-narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l)
-narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
-narrow16IntLit l = pprPanic "narrow16IntLit" (ppr l)
-narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
-narrow32IntLit l = pprPanic "narrow32IntLit" (ppr l)
-narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
-narrow8WordLit l = pprPanic "narrow8WordLit" (ppr l)
-narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
-narrow16WordLit l = pprPanic "narrow16WordLit" (ppr l)
-narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
-narrow32WordLit l = pprPanic "narrow32WordLit" (ppr l)
-
-char2IntLit (MachChar c) = MachInt (toInteger (ord c))
+-- | Narrow a literal number (unchecked result range)
+narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
+narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t
+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 (MachChar c) = mkMachIntUnchecked (toInteger (ord c))
char2IntLit l = pprPanic "char2IntLit" (ppr l)
-int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
-int2CharLit l = pprPanic "int2CharLit" (ppr l)
+int2CharLit (LitNumber _ i _) = MachChar (chr (fromInteger i))
+int2CharLit l = pprPanic "int2CharLit" (ppr l)
-float2IntLit (MachFloat f) = MachInt (truncate f)
+float2IntLit (MachFloat f) = mkMachIntUnchecked (truncate f)
float2IntLit l = pprPanic "float2IntLit" (ppr l)
-int2FloatLit (MachInt i) = MachFloat (fromInteger i)
-int2FloatLit l = pprPanic "int2FloatLit" (ppr l)
+int2FloatLit (LitNumber _ i _) = MachFloat (fromInteger i)
+int2FloatLit l = pprPanic "int2FloatLit" (ppr l)
-double2IntLit (MachDouble f) = MachInt (truncate f)
+double2IntLit (MachDouble f) = mkMachIntUnchecked (truncate f)
double2IntLit l = pprPanic "double2IntLit" (ppr l)
-int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
-int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l)
+int2DoubleLit (LitNumber _ i _) = MachDouble (fromInteger i)
+int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l)
float2DoubleLit (MachFloat f) = MachDouble f
float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l)
@@ -498,24 +559,41 @@ nullAddrLit = MachNullAddr
litIsTrivial :: Literal -> Bool
-- c.f. CoreUtils.exprIsTrivial
litIsTrivial (MachStr _) = False
-litIsTrivial (LitInteger {}) = False
+litIsTrivial (LitNumber nt _ _) = case nt of
+ LitNumInteger -> False
+ LitNumNatural -> False
+ LitNumInt -> True
+ LitNumInt64 -> True
+ LitNumWord -> True
+ LitNumWord64 -> True
litIsTrivial _ = True
-- | True if code space does not go bad if we duplicate this literal
--- Currently we treat it just like 'litIsTrivial'
litIsDupable :: DynFlags -> Literal -> Bool
-- c.f. CoreUtils.exprIsDupable
litIsDupable _ (MachStr _) = False
-litIsDupable dflags (LitInteger i _) = inIntRange dflags i
+litIsDupable dflags (LitNumber nt i _) = case nt of
+ LitNumInteger -> inIntRange dflags i
+ LitNumNatural -> inIntRange dflags i
+ LitNumInt -> True
+ LitNumInt64 -> True
+ LitNumWord -> True
+ LitNumWord64 -> True
litIsDupable _ _ = True
litFitsInChar :: Literal -> Bool
-litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
- && i <= toInteger (ord maxBound)
-litFitsInChar _ = False
+litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)
+ && i <= toInteger (ord maxBound)
+litFitsInChar _ = False
litIsLifted :: Literal -> Bool
-litIsLifted (LitInteger {}) = True
+litIsLifted (LitNumber nt _ _) = case nt of
+ LitNumInteger -> True
+ LitNumNatural -> True
+ LitNumInt -> False
+ LitNumInt64 -> False
+ LitNumWord -> False
+ LitNumWord64 -> False
litIsLifted _ = False
{-
@@ -525,17 +603,13 @@ litIsLifted _ = False
-- | 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 MachNullAddr = addrPrimTy
+literalType (MachChar _) = charPrimTy
+literalType (MachStr _) = addrPrimTy
+literalType (MachFloat _) = floatPrimTy
+literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _ _) = addrPrimTy
-literalType (LitInteger _ t) = t
+literalType (LitNumber _ _ t) = t
absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primitive
@@ -545,12 +619,13 @@ 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)
+ , (intPrimTyConKey, mkMachIntUnchecked 0)
+ , (int64PrimTyConKey, mkMachInt64Unchecked 0)
+ , (wordPrimTyConKey, mkMachWordUnchecked 0)
+ , (word64PrimTyConKey, mkMachWord64Unchecked 0)
, (floatPrimTyConKey, MachFloat 0)
, (doublePrimTyConKey, MachDouble 0)
- , (wordPrimTyConKey, MachWord 0)
- , (word64PrimTyConKey, MachWord64 0) ]
+ ]
{-
Comparison
@@ -558,32 +633,27 @@ absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr)
-}
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 (MachChar a) (MachChar b) = a `compare` b
+cmpLit (MachStr a) (MachStr b) = a `compare` b
+cmpLit (MachNullAddr) (MachNullAddr) = EQ
+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 (LitInteger a _) (LitInteger b _) = a `compare` b
-cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT
- | otherwise = GT
+cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _)
+ | nt1 == nt2 = a `compare` b
+ | otherwise = nt1 `compare` nt2
+cmpLit lit1 lit2
+ | litTag lit1 < litTag lit2 = LT
+ | otherwise = GT
litTag :: Literal -> Int
litTag (MachChar _) = 1
litTag (MachStr _) = 2
litTag (MachNullAddr) = 3
-litTag (MachInt _) = 4
-litTag (MachWord _) = 5
-litTag (MachInt64 _) = 6
-litTag (MachWord64 _) = 7
-litTag (MachFloat _) = 8
-litTag (MachDouble _) = 9
-litTag (MachLabel _ _ _) = 10
-litTag (LitInteger {}) = 11
+litTag (MachFloat _) = 4
+litTag (MachDouble _) = 5
+litTag (MachLabel _ _ _) = 6
+litTag (LitNumber {}) = 7
{-
Printing
@@ -595,13 +665,16 @@ pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
pprLiteral _ (MachChar c) = pprPrimChar c
pprLiteral _ (MachStr s) = pprHsBytes s
pprLiteral _ (MachNullAddr) = text "__NULL"
-pprLiteral _ (MachInt i) = pprPrimInt i
-pprLiteral _ (MachInt64 i) = pprPrimInt64 i
-pprLiteral _ (MachWord w) = pprPrimWord w
-pprLiteral _ (MachWord64 w) = pprPrimWord64 w
pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix
pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix
-pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
+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 (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod)
where b = case mb of
Nothing -> pprHsString l
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 8dadb4ede7..f2287e0fbd 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -198,7 +198,7 @@ because they don't support cross package data references well.
buildDynCon' dflags platform binder _ _cc con [arg]
| maybeIntLikeCon con
, platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
- , NonVoid (StgLitArg (MachInt val)) <- arg
+ , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg
, val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
, val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
= do { let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 94013f5c6d..99fa550b83 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -94,10 +94,10 @@ cgLit other_lit = do dflags <- getDynFlags
mkSimpleLit :: DynFlags -> Literal -> CmmLit
mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
mkSimpleLit dflags MachNullAddr = zeroCLit dflags
-mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
-mkSimpleLit _ (MachInt64 i) = CmmInt i W64
-mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
-mkSimpleLit _ (MachWord64 i) = CmmInt i W64
+mkSimpleLit dflags (LitNumber LitNumInt i _) = CmmInt i (wordWidth dflags)
+mkSimpleLit _ (LitNumber LitNumInt64 i _) = CmmInt i W64
+mkSimpleLit dflags (LitNumber LitNumWord i _) = CmmInt i (wordWidth dflags)
+mkSimpleLit _ (LitNumber LitNumWord64 i _) = CmmInt i W64
mkSimpleLit _ (MachFloat r) = CmmFloat r W32
mkSimpleLit _ (MachDouble r) = CmmFloat r W64
mkSimpleLit _ (MachLabel fs ms fod)
@@ -529,8 +529,7 @@ emitCmmLitSwitch scrut branches deflt = do
-- We find the necessary type information in the literals in the branches
let signed = case head branches of
- (MachInt _, _) -> True
- (MachInt64 _, _) -> True
+ (LitNumber nt _ _, _) -> litNumIsSigned nt
_ -> False
let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 75301791b4..9c2954d4ef 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -8,8 +8,9 @@ Core pass to saturate constructors and PrimOps
{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}
module CorePrep (
- corePrepPgm, corePrepExpr, cvtLitInteger,
- lookupMkIntegerName, lookupIntegerSDataConName
+ corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,
+ lookupMkIntegerName, lookupIntegerSDataConName,
+ lookupMkNaturalName, lookupNaturalSDataConName
) where
#include "HsVersions.h"
@@ -122,11 +123,13 @@ The goal of this pass is to prepare for code generation.
special case where we use the S# constructor for Integers that
are in the range of Int.
-11. Uphold tick consistency while doing this: We move ticks out of
+11. Same for LitNatural.
+
+12. Uphold tick consistency while doing this: We move ticks out of
(non-type) applications where we can, and make sure that we
annotate according to scoping rules when floating.
-12. Collect cost centres (including cost centres in unfoldings) if we're in
+13. Collect cost centres (including cost centres in unfoldings) if we're in
profiling mode. We have to do this here beucase we won't have unfoldings
after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].
@@ -608,9 +611,12 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
-cpeRhsE env (Lit (LitInteger i _))
+cpeRhsE env (Lit (LitNumber LitNumInteger i _))
= cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
(cpe_integerSDataCon env) i)
+cpeRhsE env (Lit (LitNumber LitNumNatural i _))
+ = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)
+ (cpe_naturalSDataCon env) i)
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env expr@(App {}) = cpeApp env expr
@@ -693,6 +699,24 @@ cvtLitInteger dflags mk_integer _ i
bits = 31
mask = 2 ^ bits - 1
+cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
+-- Here we convert a literal Natural to the low-level
+-- representation.
+-- See Note [Natural literals] in Literal
+cvtLitNatural dflags _ (Just sdatacon) i
+ | inWordRange dflags i -- Special case for small naturals
+ = mkConApp sdatacon [Lit (mkMachWord dflags i)]
+
+cvtLitNatural dflags mk_natural _ i
+ = mkApps (Var mk_natural) [words]
+ where words = mkListExpr wordTy (f i)
+ f 0 = []
+ f x = let low = x .&. mask
+ high = x `shiftR` bits
+ in mkConApp wordDataCon [Lit (mkMachWord dflags low)] : f high
+ bits = 32
+ mask = 2 ^ bits - 1
+
-- ---------------------------------------------------------------------------
-- CpeBody: produces a result satisfying CpeBody
-- ---------------------------------------------------------------------------
@@ -1388,8 +1412,8 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
-- the new binding is static. However it can't mention
-- any non-static things or it would *already* be Caffy
rhs_ok = rhsIsStatic platform (\_ -> False)
- (\i -> pprPanic "rhsIsStatic" (integer i))
- -- Integer literals should not show up
+ (\_nt i -> pprPanic "rhsIsStatic" (integer i))
+ -- Integer or Natural literals should not show up
wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec dmd is_unlifted floats rhs
@@ -1498,7 +1522,9 @@ data CorePrepEnv
-- see Note [lazyId magic], Note [Inlining in CorePrep]
-- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
, cpe_mkIntegerId :: Id
+ , cpe_mkNaturalId :: Id
, cpe_integerSDataCon :: Maybe DataCon
+ , cpe_naturalSDataCon :: Maybe DataCon
}
lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
@@ -1506,13 +1532,24 @@ lookupMkIntegerName dflags hsc_env
= guardIntegerUse dflags $ liftM tyThingId $
lookupGlobal hsc_env mkIntegerName
+lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id
+lookupMkNaturalName dflags hsc_env
+ = guardNaturalUse dflags $ liftM tyThingId $
+ lookupGlobal hsc_env mkNaturalName
+
lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
lookupGlobal hsc_env integerSDataConName
IntegerSimple -> return Nothing
--- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
+lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
+lookupNaturalSDataConName dflags hsc_env = case cIntegerLibraryType of
+ IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $
+ lookupGlobal hsc_env naturalSDataConName
+ IntegerSimple -> return Nothing
+
+-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
guardIntegerUse :: DynFlags -> IO a -> IO a
guardIntegerUse dflags act
| thisPackage dflags == primUnitId
@@ -1521,15 +1558,33 @@ guardIntegerUse dflags act
= return $ panic "Can't use Integer in integer-*"
| otherwise = act
+-- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'
+--
+-- Just like we can't use Integer literals in `integer-*`, we can't use Natural
+-- literals in `base`. If we do, we get interface loading error for GHC.Natural.
+guardNaturalUse :: DynFlags -> IO a -> IO a
+guardNaturalUse dflags act
+ | thisPackage dflags == primUnitId
+ = return $ panic "Can't use Natural in ghc-prim"
+ | thisPackage dflags == integerUnitId
+ = return $ panic "Can't use Natural in integer-*"
+ | thisPackage dflags == baseUnitId
+ = return $ panic "Can't use Natural in base"
+ | otherwise = act
+
mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv dflags hsc_env
= do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+ mkNaturalId <- lookupMkNaturalName dflags hsc_env
integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
+ naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
return $ CPE {
cpe_dynFlags = dflags,
cpe_env = emptyVarEnv,
cpe_mkIntegerId = mkIntegerId,
- cpe_integerSDataCon = integerSDataCon
+ cpe_mkNaturalId = mkNaturalId,
+ cpe_integerSDataCon = integerSDataCon,
+ cpe_naturalSDataCon = naturalSDataCon
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
@@ -1554,6 +1609,9 @@ lookupCorePrepEnv cpe id
getMkIntegerId :: CorePrepEnv -> Id
getMkIntegerId = cpe_mkIntegerId
+getMkNaturalId :: CorePrepEnv -> Id
+getMkNaturalId = cpe_mkNaturalId
+
------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index 3d26d3c721..7bd512d98f 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -701,7 +701,8 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
-- | Finds a nominal size of a string literal.
litSize :: Literal -> Int
-- Used by CoreUnfold.sizeExpr
-litSize (LitInteger {}) = 100 -- Note [Size of literal integers]
+litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers]
+litSize (LitNumber LitNumNatural _ _) = 100
litSize (MachStr str) = 10 + 10 * ((BS.length str + 3) `div` 4)
-- If size could be 0 then @f "x"@ might be too small
-- [Sept03: make literal strings a bit bigger to avoid fruitless
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 88e1f7167e..8f4f84b550 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -2409,12 +2409,13 @@ and 'execute' it rather than allocating it statically.
-- | This function is called only on *top-level* right-hand sides.
-- Returns @True@ if the RHS can be allocated statically in the output,
-- with no thunks involved at all.
-rhsIsStatic :: Platform
- -> (Name -> Bool) -- Which names are dynamic
- -> (Integer -> CoreExpr) -- Desugaring for integer literals (disgusting)
- -- C.f. Note [Disgusting computation of CafRefs]
- -- in TidyPgm
- -> CoreExpr -> Bool
+rhsIsStatic
+ :: Platform
+ -> (Name -> Bool) -- Which names are dynamic
+ -> (LitNumType -> Integer -> Maybe CoreExpr)
+ -- Desugaring for some literals (disgusting)
+ -- C.f. Note [Disgusting computation of CafRefs] in TidyPgm
+ -> CoreExpr -> Bool
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
-- update flag on it and (iii) in DsExpr to decide how to expand
@@ -2469,7 +2470,7 @@ rhsIsStatic :: Platform
--
-- c) don't look through unfolding of f in (f x).
-rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
+rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
@@ -2479,7 +2480,9 @@ rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
&& is_static in_arg e
is_static in_arg (Cast e _) = is_static in_arg e
is_static _ (Coercion {}) = True -- Behaves just like a literal
- is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i)
+ is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of
+ Just e -> is_static in_arg e
+ Nothing -> True
is_static _ (Lit (MachLabel {})) = False
is_static _ (Lit _) = True
-- A MachLabel (foreign import "&foo") in an argument
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index aad6d14a90..ef9da21e9a 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -260,13 +260,9 @@ mkIntegerExpr i = do t <- lookupTyCon integerTyConName
return (Lit (mkLitInteger i (mkTyConTy t)))
-- | Create a 'CoreExpr' which will evaluate to the given @Natural@
---
--- TODO: should we add LitNatural to Core?
-mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Natural
-mkNaturalExpr i = do iExpr <- mkIntegerExpr i
- fiExpr <- lookupId naturalFromIntegerName
- return (mkCoreApps (Var fiExpr) [iExpr])
-
+mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr
+mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
+ return (Lit (mkLitNatural i (mkTyConTy t)))
-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index d715439015..ca7ef0af2f 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -77,32 +77,32 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc.
-}
dsLit :: HsLit GhcRn -> DsM CoreExpr
-dsLit (HsStringPrim _ s) = return (Lit (MachStr s))
-dsLit (HsCharPrim _ c) = return (Lit (MachChar c))
-dsLit (HsIntPrim _ i) = return (Lit (MachInt i))
-dsLit (HsWordPrim _ w) = return (Lit (MachWord w))
-dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i))
-dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
-dsLit (HsFloatPrim _ f) = return (Lit (MachFloat (fl_value f)))
-dsLit (HsDoublePrim _ d) = return (Lit (MachDouble (fl_value d)))
-dsLit (HsChar _ c) = return (mkCharExpr c)
-dsLit (HsString _ str) = mkStringExprFS str
-dsLit (HsInteger _ i _) = mkIntegerExpr i
-dsLit (HsInt _ i) = do dflags <- getDynFlags
- return (mkIntExpr dflags (il_value i))
-
-dsLit (HsRat _ (FL _ _ val) ty) = do
- num <- mkIntegerExpr (numerator val)
- denom <- mkIntegerExpr (denominator val)
- return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
- where
- (ratio_data_con, integer_ty)
- = case tcSplitTyConApp ty of
- (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
- (head (tyConDataCons tycon), i_ty)
- x -> pprPanic "dsLit" (ppr x)
-
-dsLit (XLit x) = pprPanic "dsLit" (ppr x)
+dsLit l = do
+ dflags <- getDynFlags
+ case l of
+ HsStringPrim _ s -> return (Lit (MachStr s))
+ HsCharPrim _ c -> return (Lit (MachChar c))
+ HsIntPrim _ i -> return (Lit (mkMachIntWrap dflags i))
+ HsWordPrim _ w -> return (Lit (mkMachWordWrap dflags w))
+ HsInt64Prim _ i -> return (Lit (mkMachInt64Wrap dflags i))
+ HsWord64Prim _ w -> return (Lit (mkMachWord64Wrap dflags w))
+ HsFloatPrim _ f -> return (Lit (MachFloat (fl_value f)))
+ HsDoublePrim _ d -> return (Lit (MachDouble (fl_value d)))
+ HsChar _ c -> return (mkCharExpr c)
+ HsString _ str -> mkStringExprFS str
+ HsInteger _ i _ -> mkIntegerExpr i
+ HsInt _ i -> return (mkIntExpr dflags (il_value i))
+ XLit x -> pprPanic "dsLit" (ppr x)
+ HsRat _ (FL _ _ val) ty -> do
+ num <- mkIntegerExpr (numerator val)
+ denom <- mkIntegerExpr (denominator val)
+ return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
+ where
+ (ratio_data_con, integer_ty)
+ = case tcSplitTyConApp ty of
+ (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+ (head (tyConDataCons tycon), i_ty)
+ x -> pprPanic "dsLit" (ppr x)
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
dsOverLit lit = do { dflags <- getDynFlags
@@ -161,20 +161,30 @@ warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM ()
warnAboutOverflowedLiterals dflags lit
| wopt Opt_WarnOverflowedLiterals dflags
, Just (i, tc) <- getIntegralLit lit
- = if tc == intTyConName then check i tc (Proxy :: Proxy Int)
- else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8)
- else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16)
- else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32)
- else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
- else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
- else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
- else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
- else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
- else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
+ = if tc == intTyConName then check i tc (Proxy :: Proxy Int)
+ else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8)
+ else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16)
+ else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32)
+ else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
+ else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
+ else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
+ else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
+ else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
+ else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
+ else if tc == naturalTyConName then checkPositive i tc
else return ()
| otherwise = return ()
where
+ checkPositive :: Integer -> Name -> DsM ()
+ checkPositive i tc
+ = when (i < 0) $ do
+ warnDs (Reason Opt_WarnOverflowedLiterals)
+ (vcat [ text "Literal" <+> integer i
+ <+> text "is negative but" <+> ppr tc
+ <+> ptext (sLit "only supports positive numbers")
+ ])
+
check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
check i tc _proxy
= when (i < minB || i > maxB) $ do
@@ -389,8 +399,8 @@ hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
-- HsLit does not.
hsLitKey dflags (HsIntPrim _ i) = mkMachIntWrap dflags i
hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w
-hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i
-hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w
+hsLitKey dflags (HsInt64Prim _ i) = mkMachInt64Wrap dflags i
+hsLitKey dflags (HsWord64Prim _ w) = mkMachWord64Wrap dflags w
hsLitKey _ (HsCharPrim _ c) = mkMachChar c
hsLitKey _ (HsFloatPrim _ f) = mkMachFloat (fl_value f)
hsLitKey _ (HsDoublePrim _ d) = mkMachDouble (fl_value d)
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index 920bc4ac2b..f7cea3b567 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -444,17 +444,19 @@ assembleI dflags i = case i of
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
literal (MachLabel fs _ _) = litlabel fs
- literal (MachWord w) = int (fromIntegral w)
- literal (MachInt j) = int (fromIntegral j)
literal MachNullAddr = int 0
literal (MachFloat r) = float (fromRational r)
literal (MachDouble r) = double (fromRational r)
literal (MachChar c) = int (ord c)
- literal (MachInt64 ii) = int64 (fromIntegral ii)
- literal (MachWord64 ii) = int64 (fromIntegral ii)
literal (MachStr bs) = lit [BCONPtrStr bs]
-- MachStr requires a zero-terminator when emitted
- literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger"
+ literal (LitNumber nt i _) = case nt of
+ LitNumInt -> int (fromIntegral i)
+ LitNumWord -> int (fromIntegral i)
+ LitNumInt64 -> int64 (fromIntegral i)
+ LitNumWord64 -> int64 (fromIntegral i)
+ LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
+ LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
litlabel fs = lit [BCONPtrLbl fs]
addr (RemotePtr a) = words [fromIntegral a]
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 74168ac442..022fe89306 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -996,8 +996,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise
= DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
my_discr (LitAlt l, _, _)
- = case l of MachInt i -> DiscrI (fromInteger i)
- MachWord w -> DiscrW (fromInteger w)
+ = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i)
+ LitNumber LitNumWord w _ -> DiscrW (fromInteger w)
MachFloat r -> DiscrF (fromRational r)
MachDouble r -> DiscrD (fromRational r)
MachChar i -> DiscrI (ord i)
@@ -1233,7 +1233,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
push_r =
if returns_void
then nilOL
- else unitOL (PUSH_UBX (mkDummyLiteral r_rep) (trunc16W r_sizeW))
+ else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
-- generate the marshalling code we're going to call
@@ -1297,16 +1297,16 @@ primRepToFFIType dflags r
-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
-mkDummyLiteral :: PrimRep -> Literal
-mkDummyLiteral pr
+mkDummyLiteral :: DynFlags -> PrimRep -> Literal
+mkDummyLiteral dflags pr
= case pr of
- IntRep -> MachInt 0
- WordRep -> MachWord 0
+ IntRep -> mkMachInt dflags 0
+ WordRep -> mkMachWord dflags 0
+ Int64Rep -> mkMachInt64 0
+ Word64Rep -> mkMachWord64 0
AddrRep -> MachNullAddr
DoubleRep -> MachDouble 0
FloatRep -> MachFloat 0
- Int64Rep -> MachInt64 0
- Word64Rep -> MachWord64 0
_ -> pprPanic "mkDummyLiteral" (ppr pr)
@@ -1505,11 +1505,11 @@ pushAtom d p (AnnVar var)
| otherwise -- var must be a global variable
= do topStrings <- getTopStrings
+ dflags <- getDynFlags
case lookupVarEnv topStrings var of
- Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $
- ptrToWordPtr $ fromRemotePtr ptr
+ Just ptr -> pushAtom d p $ AnnLit $ mkMachWord dflags $
+ fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
- dflags <- getDynFlags
let sz = idSizeCon dflags var
MASSERT( sz == wordSize dflags )
return (unitOL (PUSH_G (getName var)), sz)
@@ -1524,19 +1524,21 @@ pushAtom _ _ (AnnLit lit) = do
case lit of
MachLabel _ _ _ -> code N
- MachWord _ -> code N
- MachInt _ -> code N
- MachWord64 _ -> code L
- MachInt64 _ -> code L
MachFloat _ -> code F
MachDouble _ -> code D
MachChar _ -> code N
MachNullAddr -> code N
MachStr _ -> code N
- -- No LitInteger's should be left by the time this is called.
- -- CorePrep should have converted them all to a real core
- -- representation.
- LitInteger {} -> panic "pushAtom: LitInteger"
+ LitNumber nt _ _ -> case nt of
+ LitNumInt -> code N
+ LitNumWord -> code N
+ LitNumInt64 -> code L
+ LitNumWord64 -> code L
+ -- No LitInteger's or LitNatural's should be left by the time this is
+ -- called. CorePrep should have converted them all to a real core
+ -- representation.
+ LitNumInteger -> panic "pushAtom: LitInteger"
+ LitNumNatural -> panic "pushAtom: LitNatural"
pushAtom _ _ expr
= pprPanic "ByteCodeGen.pushAtom"
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 9d04bf2fb3..bffda71f0a 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -1367,9 +1367,15 @@ tcIfaceLit :: Literal -> IfL Literal
-- Integer literals deserialise to (LitInteger i <error thunk>)
-- so tcIfaceLit just fills in the type.
-- See Note [Integer literals] in Literal
-tcIfaceLit (LitInteger i _)
+tcIfaceLit (LitNumber LitNumInteger i _)
= do t <- tcIfaceTyConByName integerTyConName
return (mkLitInteger i (mkTyConTy t))
+-- Natural literals deserialise to (LitNatural i <error thunk>)
+-- so tcIfaceLit just fills in the type.
+-- See Note [Natural literals] in Literal
+tcIfaceLit (LitNumber LitNumNatural i _)
+ = do t <- tcIfaceTyConByName naturalTyConName
+ return (mkLitNatural i (mkTyConTy t))
tcIfaceLit lit = return lit
-------------------------
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 1728bc0a69..f98e65e471 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -1093,9 +1093,14 @@ tidyTopBinds :: HscEnv
tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
= do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+ mkNaturalId <- lookupMkNaturalName dflags hsc_env
integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
- let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon
- result = tidy cvt_integer init_env binds
+ naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
+ let cvt_literal nt i = case nt of
+ LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)
+ LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)
+ _ -> Nothing
+ result = tidy cvt_literal init_env binds
seqBinds (snd result) `seq` return result
-- This seqBinds avoids a spike in space usage (see #13564)
where
@@ -1104,34 +1109,35 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
init_env = (init_occ_env, emptyVarEnv)
tidy _ env [] = (env, [])
- tidy cvt_integer env (b:bs)
- = let (env1, b') = tidyTopBind dflags this_mod
- cvt_integer unfold_env env b
- (env2, bs') = tidy cvt_integer env1 bs
+ tidy cvt_literal env (b:bs)
+ = let (env1, b') = tidyTopBind dflags this_mod cvt_literal unfold_env
+ env b
+ (env2, bs') = tidy cvt_literal env1 bs
in (env2, b':bs')
------------------------
tidyTopBind :: DynFlags
-> Module
- -> (Integer -> CoreExpr)
+ -> (LitNumType -> Integer -> Maybe CoreExpr)
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
-tidyTopBind dflags this_mod cvt_integer unfold_env
+tidyTopBind dflags this_mod cvt_literal unfold_env
(occ_env,subst1) (NonRec bndr rhs)
= (tidy_env2, NonRec bndr' rhs')
where
Just (name',show_unfold) = lookupVarEnv unfold_env bndr
- caf_info = hasCafRefs dflags this_mod (subst1, cvt_integer)
+ caf_info = hasCafRefs dflags this_mod
+ (subst1, cvt_literal)
(idArity bndr) rhs
(bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'
(bndr, rhs)
subst2 = extendVarEnv subst1 bndr bndr'
tidy_env2 = (occ_env, subst2)
-tidyTopBind dflags this_mod cvt_integer unfold_env
+tidyTopBind dflags this_mod cvt_literal unfold_env
(occ_env, subst1) (Rec prs)
= (tidy_env2, Rec prs')
where
@@ -1150,7 +1156,7 @@ tidyTopBind dflags this_mod cvt_integer unfold_env
-- the group may refer indirectly to a CAF (because then, they all do).
caf_info
| or [ mayHaveCafRefs (hasCafRefs dflags this_mod
- (subst1, cvt_integer)
+ (subst1, cvt_literal)
(idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
@@ -1296,25 +1302,28 @@ We compute hasCafRefs here, because IdInfo is supposed to be finalised
after TidyPgm. But CorePrep does some transformations that affect CAF-hood.
So we have to *predict* the result here, which is revolting.
-In particular CorePrep expands Integer literals. So in the prediction code
-here we resort to applying the same expansion (cvt_integer). Ugh!
+In particular CorePrep expands Integer and Natural literals. So in the
+prediction code here we resort to applying the same expansion (cvt_literal).
+Ugh!
-}
-type CafRefEnv = (VarEnv Id, Integer -> CoreExpr)
+type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)
-- The env finds the Caf-ness of the Id
- -- The Integer -> CoreExpr is the desugaring function for Integer literals
+ -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for
+ -- Integer and Natural literals
-- See Note [Disgusting computation of CafRefs]
hasCafRefs :: DynFlags -> Module
-> CafRefEnv -> Arity -> CoreExpr
-> CafInfo
-hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr
+hasCafRefs dflags this_mod (subst, cvt_literal) arity expr
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
- mentions_cafs = cafRefsE p expr
+ mentions_cafs = cafRefsE expr
is_dynamic_name = isDllName dflags this_mod
- is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr)
+ is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name
+ cvt_literal expr)
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
@@ -1322,34 +1331,36 @@ hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr
-- CorePrep later on, and we don't want to duplicate that
-- knowledge in rhsIsStatic below.
-cafRefsE :: CafRefEnv -> Expr a -> Bool
-cafRefsE p (Var id) = cafRefsV p id
-cafRefsE p (Lit lit) = cafRefsL p lit
-cafRefsE p (App f a) = cafRefsE p f || cafRefsE p a
-cafRefsE p (Lam _ e) = cafRefsE p e
-cafRefsE p (Let b e) = cafRefsEs p (rhssOfBind b) || cafRefsE p e
-cafRefsE p (Case e _ _ alts) = cafRefsE p e || cafRefsEs p (rhssOfAlts alts)
-cafRefsE p (Tick _n e) = cafRefsE p e
-cafRefsE p (Cast e _co) = cafRefsE p e
-cafRefsE _ (Type _) = False
-cafRefsE _ (Coercion _) = False
-
-cafRefsEs :: CafRefEnv -> [Expr a] -> Bool
-cafRefsEs _ [] = False
-cafRefsEs p (e:es) = cafRefsE p e || cafRefsEs p es
-
-cafRefsL :: CafRefEnv -> Literal -> Bool
--- Don't forget that mk_integer id might have Caf refs!
--- We first need to convert the Integer into its final form, to
--- see whether mkInteger is used.
-cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i)
-cafRefsL _ _ = False
-
-cafRefsV :: CafRefEnv -> Id -> Bool
-cafRefsV (subst, _) id
- | not (isLocalId id) = mayHaveCafRefs (idCafInfo id)
- | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
- | otherwise = False
+ cafRefsE :: Expr a -> Bool
+ cafRefsE (Var id) = cafRefsV id
+ cafRefsE (Lit lit) = cafRefsL lit
+ cafRefsE (App f a) = cafRefsE f || cafRefsE a
+ cafRefsE (Lam _ e) = cafRefsE e
+ cafRefsE (Let b e) = cafRefsEs (rhssOfBind b) || cafRefsE e
+ cafRefsE (Case e _ _ alts) = cafRefsE e || cafRefsEs (rhssOfAlts alts)
+ cafRefsE (Tick _n e) = cafRefsE e
+ cafRefsE (Cast e _co) = cafRefsE e
+ cafRefsE (Type _) = False
+ cafRefsE (Coercion _) = False
+
+ cafRefsEs :: [Expr a] -> Bool
+ cafRefsEs [] = False
+ cafRefsEs (e:es) = cafRefsE e || cafRefsEs es
+
+ cafRefsL :: Literal -> Bool
+ -- Don't forget that mk_integer id might have Caf refs!
+ -- We first need to convert the Integer into its final form, to
+ -- see whether mkInteger is used. Same for LitNatural.
+ cafRefsL (LitNumber nt i _) = case cvt_literal nt i of
+ Just e -> cafRefsE e
+ Nothing -> False
+ cafRefsL _ = False
+
+ cafRefsV :: Id -> Bool
+ cafRefsV id
+ | not (isLocalId id) = mayHaveCafRefs (idCafInfo id)
+ | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
+ | otherwise = False
{-
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 5ed67d591f..d971a8be90 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -358,7 +358,9 @@ basicKnownKeyNames
-- Natural
naturalTyConName,
- naturalFromIntegerName,
+ naturalFromIntegerName, naturalToIntegerName,
+ plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName,
+ wordToNaturalName,
-- Float/Double
rationalToFloatName,
@@ -435,7 +437,7 @@ basicKnownKeyNames
, eqTyConName
] ++ case cIntegerLibraryType of
- IntegerGMP -> [integerSDataConName]
+ IntegerGMP -> [integerSDataConName,naturalSDataConName]
IntegerSimple -> []
genericTyConNames :: [Name]
@@ -473,8 +475,8 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
- gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST,
- gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
+ gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
+ gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
@@ -497,6 +499,7 @@ gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi")
gHC_SHOW = mkBaseModule (fsLit "GHC.Show")
gHC_READ = mkBaseModule (fsLit "GHC.Read")
gHC_NUM = mkBaseModule (fsLit "GHC.Num")
+gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe")
gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
gHC_NATURAL = mkBaseModule (fsLit "GHC.Natural")
gHC_LIST = mkBaseModule (fsLit "GHC.List")
@@ -1121,7 +1124,7 @@ integerTyConName, mkIntegerName, integerSDataConName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name
integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey
-integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit n) integerSDataConKey
+integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit n) integerSDataConKey
where n = case cIntegerLibraryType of
IntegerGMP -> "S#"
IntegerSimple -> panic "integerSDataConName evaluated for integer-simple"
@@ -1169,12 +1172,25 @@ shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shi
bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey
-- GHC.Natural types
-naturalTyConName :: Name
+naturalTyConName, naturalSDataConName :: Name
naturalTyConName = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey
+naturalSDataConName = dcQual gHC_NATURAL (fsLit n) naturalSDataConKey
+ where n = case cIntegerLibraryType of
+ IntegerGMP -> "NatS#"
+ IntegerSimple -> panic "naturalSDataConName evaluated for integer-simple"
naturalFromIntegerName :: Name
naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey
+naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName,
+ mkNaturalName, wordToNaturalName :: Name
+naturalToIntegerName = varQual gHC_NATURAL (fsLit "naturalToInteger") naturalToIntegerIdKey
+plusNaturalName = varQual gHC_NATURAL (fsLit "plusNatural") plusNaturalIdKey
+minusNaturalName = varQual gHC_NATURAL (fsLit "minusNatural") minusNaturalIdKey
+timesNaturalName = varQual gHC_NATURAL (fsLit "timesNatural") timesNaturalIdKey
+mkNaturalName = varQual gHC_NATURAL (fsLit "mkNatural") mkNaturalIdKey
+wordToNaturalName = varQual gHC_NATURAL (fsLit "wordToNatural#") wordToNaturalIdKey
+
-- GHC.Real types and classes
rationalTyConName, ratioTyConName, ratioDataConName, realClassName,
integralClassName, realFracClassName, fractionalClassName,
@@ -2388,8 +2404,17 @@ makeStaticKey :: Unique
makeStaticKey = mkPreludeMiscIdUnique 561
-- Natural
-naturalFromIntegerIdKey :: Unique
+naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey,
+ minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey,
+ naturalSDataConKey, wordToNaturalIdKey :: Unique
naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562
+naturalToIntegerIdKey = mkPreludeMiscIdUnique 563
+plusNaturalIdKey = mkPreludeMiscIdUnique 564
+minusNaturalIdKey = mkPreludeMiscIdUnique 565
+timesNaturalIdKey = mkPreludeMiscIdUnique 566
+mkNaturalIdKey = mkPreludeMiscIdUnique 567
+naturalSDataConKey = mkPreludeMiscIdUnique 568
+wordToNaturalIdKey = mkPreludeMiscIdUnique 569
{-
************************************************************************
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 84e4173a28..369ba4c264 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -371,12 +371,11 @@ cmpOp dflags cmp = go
-- These compares are at different types
go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2)
- go (MachInt i1) (MachInt i2) = done (i1 `cmp` i2)
- go (MachInt64 i1) (MachInt64 i2) = done (i1 `cmp` i2)
- go (MachWord i1) (MachWord i2) = done (i1 `cmp` i2)
- go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2)
go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
+ go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)
+ | nt1 /= nt2 = Nothing
+ | otherwise = done (i1 `cmp` i2)
go _ _ = Nothing
--------------------------
@@ -386,12 +385,13 @@ negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f))
negOp _ (MachDouble 0.0) = Nothing
negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d))
-negOp dflags (MachInt i) = intResult dflags (-i)
+negOp dflags (LitNumber nt i t)
+ | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t))
negOp _ _ = Nothing
complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement
-complementOp dflags (MachWord i) = wordResult dflags (complement i)
-complementOp dflags (MachInt i) = intResult dflags (complement i)
+complementOp dflags (LitNumber nt i t) =
+ Just (Lit (mkLitNumberWrap dflags nt (complement i) t))
complementOp _ _ = Nothing
--------------------------
@@ -403,7 +403,7 @@ intOp2 = intOp2' . const
intOp2' :: (Integral a, Integral b)
=> (DynFlags -> a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-intOp2' op dflags (MachInt i1) (MachInt i2) =
+intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) =
let o = op dflags
in intResult dflags (fromInteger i1 `o` fromInteger i2)
intOp2' _ _ _ _ = Nothing -- Could find LitLit
@@ -411,7 +411,7 @@ intOp2' _ _ _ _ = Nothing -- Could find LitLit
intOpC2 :: (Integral a, Integral b)
=> (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-intOpC2 op dflags (MachInt i1) (MachInt i2) = do
+intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do
intCResult dflags (fromInteger i1 `op` fromInteger i2)
intOpC2 _ _ _ _ = Nothing -- Could find LitLit
@@ -438,14 +438,14 @@ retLitNoC l = do dflags <- getDynFlags
wordOp2 :: (Integral a, Integral b)
=> (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-wordOp2 op dflags (MachWord w1) (MachWord w2)
+wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _)
= wordResult dflags (fromInteger w1 `op` fromInteger w2)
wordOp2 _ _ _ _ = Nothing -- Could find LitLit
wordOpC2 :: (Integral a, Integral b)
=> (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-wordOpC2 op dflags (MachWord w1) (MachWord w2) =
+wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =
wordCResult dflags (fromInteger w1 `op` fromInteger w2)
wordOpC2 _ _ _ _ = Nothing -- Could find LitLit
@@ -454,7 +454,7 @@ shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
-- See Note [Guarding against silly shifts]
shiftRule shift_op
= do { dflags <- getDynFlags
- ; [e1, Lit (MachInt shift_len)] <- getArgs
+ ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs
; case e1 of
_ | shift_len == 0
-> return e1
@@ -463,13 +463,10 @@ shiftRule shift_op
("Bad shift length" ++ show shift_len))
-- Do the shift at type Integer, but shift length is Int
- Lit (MachInt x)
+ Lit (LitNumber nt x t)
-> let op = shift_op dflags
- in liftMaybe $ intResult dflags (x `op` fromInteger shift_len)
-
- Lit (MachWord x)
- -> let op = shift_op dflags
- in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
+ y = x `op` fromInteger shift_len
+ in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t))
_ -> mzero }
@@ -560,20 +557,26 @@ mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dfla
mkRuleFn _ _ _ _ = Nothing
isMinBound :: DynFlags -> Literal -> Bool
-isMinBound _ (MachChar c) = c == minBound
-isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags
-isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64)
-isMinBound _ (MachWord i) = i == 0
-isMinBound _ (MachWord64 i) = i == 0
-isMinBound _ _ = False
+isMinBound _ (MachChar c) = c == minBound
+isMinBound dflags (LitNumber nt i _) = case nt of
+ LitNumInt -> i == tARGET_MIN_INT dflags
+ LitNumInt64 -> i == toInteger (minBound :: Int64)
+ LitNumWord -> i == 0
+ LitNumWord64 -> i == 0
+ LitNumNatural -> i == 0
+ LitNumInteger -> False
+isMinBound _ _ = False
isMaxBound :: DynFlags -> Literal -> Bool
-isMaxBound _ (MachChar c) = c == maxBound
-isMaxBound dflags (MachInt i) = i == tARGET_MAX_INT dflags
-isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64)
-isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags
-isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64)
-isMaxBound _ _ = False
+isMaxBound _ (MachChar c) = c == maxBound
+isMaxBound dflags (LitNumber nt i _) = case nt of
+ LitNumInt -> i == tARGET_MAX_INT dflags
+ LitNumInt64 -> i == toInteger (maxBound :: Int64)
+ LitNumWord -> i == tARGET_MAX_WORD dflags
+ LitNumWord64 -> i == toInteger (maxBound :: Word64)
+ LitNumNatural -> False
+ LitNumInteger -> False
+isMaxBound _ _ = False
-- | Create an Int literal expression while ensuring the given Integer is in the
-- target Int range
@@ -961,7 +964,7 @@ tagToEnumRule :: RuleM CoreExpr
-- If data T a = A | B | C
-- then tag2Enum# (T ty) 2# --> B ty
tagToEnumRule = do
- [Type ty, Lit (MachInt i)] <- getArgs
+ [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs
case splitTyConApp_maybe ty of
Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
let tag = fromInteger i
@@ -1135,7 +1138,7 @@ builtinRules
[ nonZeroLit 1 >> binaryLit (intOp2 div)
, leftZero zeroi
, do
- [arg, Lit (MachInt d)] <- getArgs
+ [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
Just n <- return $ exactLog2 d
dflags <- getDynFlags
return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
@@ -1144,7 +1147,7 @@ builtinRules
[ nonZeroLit 1 >> binaryLit (intOp2 mod)
, leftZero zeroi
, do
- [arg, Lit (MachInt d)] <- getArgs
+ [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
Just _ <- return $ exactLog2 d
dflags <- getDynFlags
return $ Var (mkPrimOpId AndIOp)
@@ -1152,6 +1155,7 @@ builtinRules
]
]
++ builtinIntegerRules
+ ++ builtinNaturalRules
{-# NOINLINE builtinRules #-}
-- there is no benefit to inlining these yet, despite this, GHC produces
-- unfoldings for this regardless since the floated list entries look small.
@@ -1268,6 +1272,31 @@ builtinIntegerRules =
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_rationalTo mkLit }
+builtinNaturalRules :: [CoreRule]
+builtinNaturalRules =
+ [rule_binop "plusNatural" plusNaturalName (+)
+ ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing)
+ ,rule_binop "timesNatural" timesNaturalName (*)
+ ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName
+ ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName
+ ,rule_WordToNatural "wordToNatural" wordToNaturalName
+ ]
+ where rule_binop str name op
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+ ru_try = match_Natural_binop op }
+ rule_partial_binop str name op
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+ ru_try = match_Natural_partial_binop op }
+ rule_NaturalToInteger str name
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+ ru_try = match_NaturalToInteger }
+ rule_NaturalFromInteger str name
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+ ru_try = match_NaturalFromInteger }
+ rule_WordToNatural str name
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+ ru_try = match_WordToNatural }
+
---------------------------------------------------
-- The rule is this:
-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
@@ -1359,34 +1388,65 @@ match_IntToInteger = match_IntToInteger_unop id
match_WordToInteger :: RuleFun
match_WordToInteger _ id_unf id [xl]
- | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
- Just (Lit (LitInteger x integerTy))
+ Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_WordToInteger: Id has the wrong type"
match_WordToInteger _ _ _ _ = Nothing
match_Int64ToInteger :: RuleFun
match_Int64ToInteger _ id_unf id [xl]
- | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
- Just (Lit (LitInteger x integerTy))
+ Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_Int64ToInteger: Id has the wrong type"
match_Int64ToInteger _ _ _ _ = Nothing
match_Word64ToInteger :: RuleFun
match_Word64ToInteger _ id_unf id [xl]
- | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
- Just (Lit (LitInteger x integerTy))
+ Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_Word64ToInteger: Id has the wrong type"
match_Word64ToInteger _ _ _ _ = Nothing
+match_NaturalToInteger :: RuleFun
+match_NaturalToInteger _ id_unf id [xl]
+ | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl
+ = case splitFunTy_maybe (idType id) of
+ Just (_, naturalTy) ->
+ Just (Lit (LitNumber LitNumInteger x naturalTy))
+ _ ->
+ panic "match_NaturalToInteger: Id has the wrong type"
+match_NaturalToInteger _ _ _ _ = Nothing
+
+match_NaturalFromInteger :: RuleFun
+match_NaturalFromInteger _ id_unf id [xl]
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , x >= 0
+ = case splitFunTy_maybe (idType id) of
+ Just (_, naturalTy) ->
+ Just (Lit (LitNumber LitNumNatural x naturalTy))
+ _ ->
+ panic "match_NaturalFromInteger: Id has the wrong type"
+match_NaturalFromInteger _ _ _ _ = Nothing
+
+match_WordToNatural :: RuleFun
+match_WordToNatural _ id_unf id [xl]
+ | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
+ = case splitFunTy_maybe (idType id) of
+ Just (_, naturalTy) ->
+ Just (Lit (LitNumber LitNumNatural x naturalTy))
+ _ ->
+ panic "match_WordToNatural: Id has the wrong type"
+match_WordToNatural _ _ _ _ = Nothing
+
-------------------------------------------------
{- Note [Rewriting bitInteger]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1397,7 +1457,7 @@ constant-folding (see Trac #8832). The bitInteger rule above provides constant f
specifically for this function.
There is, however, a bit of trickiness here when it comes to ranges. While the
-AST encodes all integers (even MachInts) as Integers, `bit` expects the bit
+AST encodes all integers as Integers, `bit` expects the bit
index to be given as an Int. Hence we coerce to an Int in the rule definition.
This will behave a bit funny for constants larger than the word size, but the user
should expect some funniness given that they will have at very least ignored a
@@ -1407,7 +1467,7 @@ warning in this case.
match_bitInteger :: RuleFun
-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer
match_bitInteger dflags id_unf fn [arg]
- | Just (MachInt x) <- exprIsLiteral_maybe id_unf arg
+ | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg
, x >= 0
, x <= (wordSizeInBits dflags - 1)
-- Make sure x is small enough to yield a decently small iteger
@@ -1417,7 +1477,7 @@ match_bitInteger dflags id_unf fn [arg]
, let x_int = fromIntegral x :: Int
= case splitFunTy_maybe (idType fn) of
Just (_, integerTy)
- -> Just (Lit (LitInteger (bit x_int) integerTy))
+ -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))
_ -> panic "match_IntToInteger_unop: Id has the wrong type"
match_bitInteger _ _ _ _ = Nothing
@@ -1428,71 +1488,86 @@ match_Integer_convert :: Num a
=> (DynFlags -> a -> Expr CoreBndr)
-> RuleFun
match_Integer_convert convert dflags id_unf _ [xl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
= Just (convert dflags (fromInteger x))
match_Integer_convert _ _ _ _ _ = Nothing
match_Integer_unop :: (Integer -> Integer) -> RuleFun
match_Integer_unop unop _ id_unf _ [xl]
- | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
- = Just (Lit (LitInteger (unop x) i))
+ | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+ = Just (Lit (LitNumber LitNumInteger (unop x) i))
match_Integer_unop _ _ _ _ _ = Nothing
match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
match_IntToInteger_unop unop _ id_unf fn [xl]
- | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType fn) of
Just (_, integerTy) ->
- Just (Lit (LitInteger (unop x) integerTy))
+ Just (Lit (LitNumber LitNumInteger (unop x) integerTy))
_ ->
panic "match_IntToInteger_unop: Id has the wrong type"
match_IntToInteger_unop _ _ _ _ _ = Nothing
match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_binop binop _ id_unf _ [xl,yl]
- | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
- = Just (Lit (LitInteger (x `binop` y) i))
+ | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
+ = Just (Lit (mkLitInteger (x `binop` y) i))
match_Integer_binop _ _ _ _ _ = Nothing
+match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
+match_Natural_binop binop _ id_unf _ [xl,yl]
+ | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
+ = Just (Lit (mkLitNatural (x `binop` y) i))
+match_Natural_binop _ _ _ _ _ = Nothing
+
+match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
+match_Natural_partial_binop binop _ id_unf _ [xl,yl]
+ | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
+ , Just z <- x `binop` y
+ = Just (Lit (mkLitNatural z i))
+match_Natural_partial_binop _ _ _ _ _ = Nothing
+
-- This helper is used for the quotRem and divMod functions
match_Integer_divop_both
:: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
match_Integer_divop_both divop _ id_unf _ [xl,yl]
- | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
, (r,s) <- x `divop` y
- = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]
+ = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]
match_Integer_divop_both _ _ _ _ _ = Nothing
-- This helper is used for the quot and rem functions
match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_divop_one divop _ id_unf _ [xl,yl]
- | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
- = Just (Lit (LitInteger (x `divop` y) i))
+ = Just (Lit (mkLitInteger (x `divop` y) i))
match_Integer_divop_one _ _ _ _ _ = Nothing
match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
match_Integer_Int_binop binop _ id_unf _ [xl,yl]
- | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
- , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
- = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
+ | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
+ = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))
match_Integer_Int_binop _ _ _ _ _ = Nothing
match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
match_Integer_binop_Prim _ _ _ _ _ = Nothing
match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just $ case x `binop` y of
LT -> ltVal
EQ -> eqVal
@@ -1503,8 +1578,8 @@ match_Integer_Int_encodeFloat :: RealFloat a
=> (a -> Expr CoreBndr)
-> RuleFun
match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
= Just (mkLit $ encodeFloat x (fromInteger y))
match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
@@ -1522,14 +1597,14 @@ match_rationalTo :: RealFloat a
=> (a -> Expr CoreBndr)
-> RuleFun
match_rationalTo mkLit _ id_unf _ [xl, yl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
= Just (mkLit (fromRational (x % y)))
match_rationalTo _ _ _ _ _ = Nothing
match_decodeDouble :: RuleFun
-match_decodeDouble _ id_unf fn [xl]
+match_decodeDouble dflags id_unf fn [xl]
| Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType fn) of
Just (_, res)
@@ -1537,8 +1612,8 @@ match_decodeDouble _ id_unf fn [xl]
-> case decodeFloat (fromRational x :: Double) of
(y, z) ->
Just $ mkCoreUbxTup [integerTy, intHashTy]
- [Lit (LitInteger y integerTy),
- Lit (MachInt (toInteger z))]
+ [Lit (mkLitInteger y integerTy),
+ Lit (mkMachInt dflags (toInteger z))]
_ ->
pprPanic "match_decodeDouble: Id has the wrong type"
(ppr fn <+> dcolon <+> ppr (idType fn))
@@ -1670,7 +1745,8 @@ tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum]
tx_con_dtt :: Type -> AltCon -> AltCon
tx_con_dtt _ DEFAULT = DEFAULT
-tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i))
+tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))
+ = DataAlt (get_con ty (fromInteger i))
tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
get_con :: Type -> ConTagZ -> DataCon
@@ -1711,7 +1787,7 @@ We don't want to get this!
DEFAULT -> e1
DEFAULT -> e2
-Instead, we deal with turning one branch into DEAFULT in SimplUtils
+Instead, we deal with turning one branch into DEFAULT in SimplUtils
(add_default in mkCase3).
Note [caseRules for dataToTag]
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 1156d810b9..b96581e482 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -271,11 +271,11 @@ nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") ni
consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
maybeTyConName, nothingDataConName, justDataConName :: Name
-maybeTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "Maybe")
+maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe")
maybeTyConKey maybeTyCon
-nothingDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Nothing")
+nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")
nothingDataConKey nothingDataCon
-justDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Just")
+justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")
justDataConKey justDataCon
wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index bcf699b369..5c271c2ea0 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -203,7 +203,7 @@ import CoreSyn
import DataCon
import FastString (FastString, mkFastString)
import Id
-import Literal (Literal (..), literalType)
+import Literal
import MkCore (aBSENT_SUM_FIELD_ERROR_ID)
import MkId (voidPrimId, voidArgId)
import MonadUtils (mapAccumLM)
@@ -211,7 +211,7 @@ import Outputable
import RepType
import StgSyn
import Type
-import TysPrim (intPrimTy)
+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)
import TysWiredIn
import UniqSupply
import Util
@@ -478,7 +478,7 @@ unariseSumAlt rho _ (DEFAULT, _, e)
unariseSumAlt rho args (DataAlt sumCon, bs, e)
= do let rho' = mapSumIdBinders bs args rho
e' <- unariseExpr rho' e
- return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )
+ return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )
unariseSumAlt _ scrt alt
= pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
@@ -564,7 +564,7 @@ mkUbxSum dc ty_args args0
tag = dataConTag dc
layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
- tag_arg = StgLitArg (MachInt (fromIntegral tag))
+ tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)
arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
@@ -579,8 +579,8 @@ mkUbxSum dc ty_args args0
slotRubbishArg :: SlotTy -> StgArg
slotRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore
- slotRubbishArg WordSlot = StgLitArg (MachWord 0)
- slotRubbishArg Word64Slot = StgLitArg (MachWord64 0)
+ slotRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
+ slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
slotRubbishArg FloatSlot = StgLitArg (MachFloat 0)
slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0)
in
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index e2ed3953ae..fdd8d5bef3 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -390,9 +390,10 @@ coreToStgExpr
-- on these components, but it in turn is not scrutinised as the basis for any
-- decisions. Hence no black holes.
--- No LitInteger's should be left by the time this is called. CorePrep
--- should have converted them all to a real core representation.
-coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
+-- No LitInteger's or LitNatural's should be left by the time this is called.
+-- CorePrep should have converted them all to a real core representation.
+coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
+coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo)
coreToStgExpr (Var v) = coreToStgApp Nothing v [] []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
View Lorry Controller Status