diff options
80 files changed, 1946 insertions, 1121 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 [] [] diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index 1fc388040c..60edf78dea 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -536,6 +536,74 @@ instance Bits Integer where bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" isSigned _ = True +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0 +instance Bits Natural where + (.&.) = andNatural + (.|.) = orNatural + xor = xorNatural + complement _ = errorWithoutStackTrace + "Bits.complement: Natural complement undefined" + shift x i + | i >= 0 = shiftLNatural x i + | otherwise = shiftRNatural x (negate i) + testBit x i = testBitNatural x i + zeroBits = wordToNaturalBase 0## + clearBit x i = x `xor` (bit i .&. x) + + bit (I# i#) = bitNatural i# + popCount x = popCountNatural x + + rotate x i = shift x i -- since an Natural never wraps around + + bitSizeMaybe _ = Nothing + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Natural)" + isSigned _ = False +#else +-- | @since 4.8.0.0 +instance Bits Natural where + Natural n .&. Natural m = Natural (n .&. m) + {-# INLINE (.&.) #-} + Natural n .|. Natural m = Natural (n .|. m) + {-# INLINE (.|.) #-} + xor (Natural n) (Natural m) = Natural (xor n m) + {-# INLINE xor #-} + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" + {-# INLINE complement #-} + shift (Natural n) = Natural . shift n + {-# INLINE shift #-} + rotate (Natural n) = Natural . rotate n + {-# INLINE rotate #-} + bit = Natural . bit + {-# INLINE bit #-} + setBit (Natural n) = Natural . setBit n + {-# INLINE setBit #-} + clearBit (Natural n) = Natural . clearBit n + {-# INLINE clearBit #-} + complementBit (Natural n) = Natural . complementBit n + {-# INLINE complementBit #-} + testBit (Natural n) = testBit n + {-# INLINE testBit #-} + bitSizeMaybe _ = Nothing + {-# INLINE bitSizeMaybe #-} + bitSize = errorWithoutStackTrace "Natural: bitSize" + {-# INLINE bitSize #-} + isSigned _ = False + {-# INLINE isSigned #-} + shiftL (Natural n) = Natural . shiftL n + {-# INLINE shiftL #-} + shiftR (Natural n) = Natural . shiftR n + {-# INLINE shiftR #-} + rotateL (Natural n) = Natural . rotateL n + {-# INLINE rotateL #-} + rotateR (Natural n) = Natural . rotateR n + {-# INLINE rotateR #-} + popCount (Natural n) = popCount n + {-# INLINE popCount #-} + zeroBits = Natural 0 + +#endif + ----------------------------------------------------------------------------- -- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs index 8154433044..194df08003 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -126,7 +126,6 @@ import Data.Version( Version(..) ) import GHC.Base hiding (Any, IntRep, FloatRep) import GHC.List import GHC.Num -import GHC.Natural import GHC.Read import GHC.Show import Text.Read( reads ) diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs index 8dbda6f7cf..af16355bc1 100644 --- a/libraries/base/GHC/Arr.hs +++ b/libraries/base/GHC/Arr.hs @@ -240,6 +240,15 @@ instance Ix Integer where inRange (m,n) i = m <= i && i <= n ---------------------------------------------------------------------- +-- | @since 4.8.0.0 +instance Ix Natural where + range (m,n) = [m..n] + inRange (m,n) i = m <= i && i <= n + unsafeIndex (m,_) i = fromIntegral (i-m) + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Natural" + +---------------------------------------------------------------------- -- | @since 2.01 instance Ix Bool where -- as derived {-# INLINE range #-} diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index b8f984c440..4953a7d58c 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -117,7 +117,8 @@ module GHC.Base module GHC.Types, module GHC.Prim, -- Re-export GHC.Prim and [boot] GHC.Err, -- to avoid lots of people having to - module GHC.Err -- import it explicitly + module GHC.Err, -- import it explicitly + module GHC.Maybe ) where @@ -127,10 +128,12 @@ import GHC.CString import GHC.Magic import GHC.Prim import GHC.Err +import GHC.Maybe import {-# SOURCE #-} GHC.IO (failIO,mplusIO) -import GHC.Tuple () -- Note [Depend on GHC.Tuple] -import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Tuple () -- Note [Depend on GHC.Tuple] +import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Natural () -- Note [Depend on GHC.Natural] -- for 'class Semigroup' import {-# SOURCE #-} GHC.Real (Integral) @@ -182,6 +185,10 @@ Similarly, tuple syntax (or ()) creates an implicit dependency on GHC.Tuple, so we use the same rule as for Integer --- see Note [Depend on GHC.Integer] --- to explain this to the build system. We make GHC.Base depend on GHC.Tuple, and everything else depends on GHC.Base or Prelude. + +Note [Depend on GHC.Natural] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similar to GHC.Integer. -} #if 0 @@ -202,21 +209,6 @@ build = errorWithoutStackTrace "urk" foldr = errorWithoutStackTrace "urk" #endif --- | The 'Maybe' type encapsulates an optional value. A value of type --- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), --- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to --- deal with errors or exceptional cases without resorting to drastic --- measures such as 'error'. --- --- The 'Maybe' type is also a monad. It is a simple kind of error --- monad, where all errors are represented by 'Nothing'. A richer --- error monad can be built using the 'Data.Either.Either' type. --- -data Maybe a = Nothing | Just a - deriving ( Eq -- ^ @since 2.01 - , Ord -- ^ @since 2.01 - ) - infixr 6 <> -- | The class of semigroups (types with an associative binary operation). diff --git a/libraries/base/GHC/Base.hs-boot b/libraries/base/GHC/Base.hs-boot index ca85b49147..64e6365525 100644 --- a/libraries/base/GHC/Base.hs-boot +++ b/libraries/base/GHC/Base.hs-boot @@ -1,10 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -module GHC.Base where +module GHC.Base (Maybe, Semigroup, Monoid) where +import GHC.Maybe (Maybe) import GHC.Types () class Semigroup a class Monoid a - -data Maybe a = Nothing | Just a diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs index feb45854d2..234ccb3ba2 100644 --- a/libraries/base/GHC/Enum.hs +++ b/libraries/base/GHC/Enum.hs @@ -877,6 +877,79 @@ dn_list x0 delta lim = go (x0 :: Integer) go x | x < lim = [] | otherwise = x : go (x+delta) +------------------------------------------------------------------------ +-- Natural +------------------------------------------------------------------------ + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Enum Natural where + succ n = n `plusNatural` wordToNaturalBase 1## + pred n = n `minusNatural` wordToNaturalBase 1## + + toEnum = intToNatural + + fromEnum (NatS# w) + | i >= 0 = i + | otherwise = errorWithoutStackTrace "fromEnum: out of Int range" + where + i = I# (word2Int# w) + fromEnum n = fromEnum (naturalToInteger n) + + enumFrom x = enumDeltaNatural x (wordToNaturalBase 1##) + enumFromThen x y + | x <= y = enumDeltaNatural x (y-x) + | otherwise = enumNegDeltaToNatural x (x-y) (wordToNaturalBase 0##) + + enumFromTo x lim = enumDeltaToNatural x (wordToNaturalBase 1##) lim + enumFromThenTo x y lim + | x <= y = enumDeltaToNatural x (y-x) lim + | otherwise = enumNegDeltaToNatural x (x-y) lim + +-- Helpers for 'Enum Natural'; TODO: optimise & make fusion work + +enumDeltaNatural :: Natural -> Natural -> [Natural] +enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d + +enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumDeltaToNatural x0 delta lim = go x0 + where + go x | x > lim = [] + | otherwise = x : go (x+delta) + +enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumNegDeltaToNatural x0 ndelta lim = go x0 + where + go x | x < lim = [] + | x >= ndelta = x : go (x-ndelta) + | otherwise = [x] + +#else + +-- | @since 4.8.0.0 +instance Enum Natural where + pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" + pred (Natural n) = Natural (pred n) + {-# INLINE pred #-} + succ (Natural n) = Natural (succ n) + {-# INLINE succ #-} + fromEnum (Natural n) = fromEnum n + {-# INLINE fromEnum #-} + toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" + | otherwise = Natural (toEnum n) + {-# INLINE toEnum #-} + + enumFrom = coerce (enumFrom :: Integer -> [Integer]) + enumFromThen x y + | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y + | otherwise = enumFromThenTo x y (wordToNaturalBase 0##) + + enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) + enumFromThenTo + = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) + +#endif + -- Instances from GHC.Types -- | @since 4.10.0.0 diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index a48fb10a86..1f1ad903ae 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -27,8 +27,8 @@ import GHC.CString () import GHC.Types (Char, RuntimeRep) import GHC.Stack.Types import GHC.Prim -import GHC.Integer () -- Make sure Integer is compiled first - -- because GHC depends on it in a wired-in way +import GHC.Integer () -- Make sure Integer and Natural are compiled first +import GHC.Natural () -- because GHC depends on it in a wired-in way -- so the build system doesn't see the dependency import {-# SOURCE #-} GHC.Exception ( errorCallWithCallStackException diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs index f966b3fd5e..3b32e230e8 100644 --- a/libraries/base/GHC/Exception.hs +++ b/libraries/base/GHC/Exception.hs @@ -23,21 +23,17 @@ ----------------------------------------------------------------------------- module GHC.Exception - ( Exception(..) -- Class + ( module GHC.Exception.Type , throw - , SomeException(..), ErrorCall(..,ErrorCall), ArithException(..) - , divZeroException, overflowException, ratioZeroDenomException - , underflowException - , errorCallException, errorCallWithCallStackException + , ErrorCall(..,ErrorCall) + , errorCallException + , errorCallWithCallStackException -- re-export CallStack and SrcLoc from GHC.Types , CallStack, fromCallSiteList, getCallStack, prettyCallStack , prettyCallStackLines, showCCSStack , SrcLoc(..), prettySrcLoc ) where -import Data.Maybe -import Data.Typeable (Typeable, cast) - -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show import GHC.Stack.Types @@ -45,124 +41,7 @@ import GHC.OldList import GHC.Prim import GHC.IO.Unsafe import {-# SOURCE #-} GHC.Stack.CCS - -{- | -The @SomeException@ type is the root of the exception type hierarchy. -When an exception of type @e@ is thrown, behind the scenes it is -encapsulated in a @SomeException@. --} -data SomeException = forall e . Exception e => SomeException e - --- | @since 3.0 -instance Show SomeException where - showsPrec p (SomeException e) = showsPrec p e - -{- | -Any type that you wish to throw or catch as an exception must be an -instance of the @Exception@ class. The simplest case is a new exception -type directly below the root: - -> data MyException = ThisException | ThatException -> deriving Show -> -> instance Exception MyException - -The default method definitions in the @Exception@ class do what we need -in this case. You can now throw and catch @ThisException@ and -@ThatException@ as exceptions: - -@ -*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) -Caught ThisException -@ - -In more complicated examples, you may wish to define a whole hierarchy -of exceptions: - -> --------------------------------------------------------------------- -> -- Make the root exception type for all the exceptions in a compiler -> -> data SomeCompilerException = forall e . Exception e => SomeCompilerException e -> -> instance Show SomeCompilerException where -> show (SomeCompilerException e) = show e -> -> instance Exception SomeCompilerException -> -> compilerExceptionToException :: Exception e => e -> SomeException -> compilerExceptionToException = toException . SomeCompilerException -> -> compilerExceptionFromException :: Exception e => SomeException -> Maybe e -> compilerExceptionFromException x = do -> SomeCompilerException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make a subhierarchy for exceptions in the frontend of the compiler -> -> data SomeFrontendException = forall e . Exception e => SomeFrontendException e -> -> instance Show SomeFrontendException where -> show (SomeFrontendException e) = show e -> -> instance Exception SomeFrontendException where -> toException = compilerExceptionToException -> fromException = compilerExceptionFromException -> -> frontendExceptionToException :: Exception e => e -> SomeException -> frontendExceptionToException = toException . SomeFrontendException -> -> frontendExceptionFromException :: Exception e => SomeException -> Maybe e -> frontendExceptionFromException x = do -> SomeFrontendException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make an exception type for a particular frontend compiler exception -> -> data MismatchedParentheses = MismatchedParentheses -> deriving Show -> -> instance Exception MismatchedParentheses where -> toException = frontendExceptionToException -> fromException = frontendExceptionFromException - -We can now catch a @MismatchedParentheses@ exception as -@MismatchedParentheses@, @SomeFrontendException@ or -@SomeCompilerException@, but not other types, e.g. @IOException@: - -@ -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException)) -*** Exception: MismatchedParentheses -@ - --} -class (Typeable e, Show e) => Exception e where - toException :: e -> SomeException - fromException :: SomeException -> Maybe e - - toException = SomeException - fromException (SomeException e) = cast e - - -- | Render this exception value in a human-friendly manner. - -- - -- Default implementation: @'show'@. - -- - -- @since 4.8.0.0 - displayException :: e -> String - displayException = show - --- | @since 3.0 -instance Exception SomeException where - toException se = se - fromException = Just - displayException (SomeException e) = displayException e +import GHC.Exception.Type -- | Throw an exception. Exceptions may be thrown from purely -- functional code, but may only be caught within the 'IO' monad. @@ -236,33 +115,3 @@ prettyCallStackLines cs = case getCallStack cs of : map ((" " ++) . prettyCallSite) stk where prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc - --- |Arithmetic exceptions. -data ArithException - = Overflow - | Underflow - | LossOfPrecision - | DivideByZero - | Denormal - | RatioZeroDenominator -- ^ @since 4.6.0.0 - deriving ( Eq -- ^ @since 3.0 - , Ord -- ^ @since 3.0 - ) - -divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException -divZeroException = toException DivideByZero -overflowException = toException Overflow -ratioZeroDenomException = toException RatioZeroDenominator -underflowException = toException Underflow - --- | @since 4.0.0.0 -instance Exception ArithException - --- | @since 4.0.0.0 -instance Show ArithException where - showsPrec _ Overflow = showString "arithmetic overflow" - showsPrec _ Underflow = showString "arithmetic underflow" - showsPrec _ LossOfPrecision = showString "loss of precision" - showsPrec _ DivideByZero = showString "divide by zero" - showsPrec _ Denormal = showString "denormal" - showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot index d539dd4962..4507b20790 100644 --- a/libraries/base/GHC/Exception.hs-boot +++ b/libraries/base/GHC/Exception.hs-boot @@ -24,17 +24,15 @@ well-behaved, non-bottom values. The clients use 'raise#' to get a visibly-bottom value. -} -module GHC.Exception ( SomeException, errorCallException, - errorCallWithCallStackException, - divZeroException, overflowException, ratioZeroDenomException, - underflowException - ) where +module GHC.Exception + ( module GHC.Exception.Type + , errorCallException + , errorCallWithCallStackException + ) where + +import {-# SOURCE #-} GHC.Exception.Type import GHC.Types ( Char ) import GHC.Stack.Types ( CallStack ) -data SomeException -divZeroException, overflowException, ratioZeroDenomException :: SomeException -underflowException :: SomeException - errorCallException :: [Char] -> SomeException errorCallWithCallStackException :: [Char] -> CallStack -> SomeException diff --git a/libraries/base/GHC/Exception/Type.hs b/libraries/base/GHC/Exception/Type.hs new file mode 100644 index 0000000000..6c3eb49ff9 --- /dev/null +++ b/libraries/base/GHC/Exception/Type.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , RecordWildCards + , PatternSynonyms + #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Exception.Type +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exceptions and exception-handling functions. +-- +----------------------------------------------------------------------------- + +module GHC.Exception.Type + ( Exception(..) -- Class + , SomeException(..), ArithException(..) + , divZeroException, overflowException, ratioZeroDenomException + , underflowException + ) where + +import Data.Maybe +import Data.Typeable (Typeable, cast) + -- loop: Data.Typeable -> GHC.Err -> GHC.Exception +import GHC.Base +import GHC.Show + +{- | +The @SomeException@ type is the root of the exception type hierarchy. +When an exception of type @e@ is thrown, behind the scenes it is +encapsulated in a @SomeException@. +-} +data SomeException = forall e . Exception e => SomeException e + +-- | @since 3.0 +instance Show SomeException where + showsPrec p (SomeException e) = showsPrec p e + +{- | +Any type that you wish to throw or catch as an exception must be an +instance of the @Exception@ class. The simplest case is a new exception +type directly below the root: + +> data MyException = ThisException | ThatException +> deriving Show +> +> instance Exception MyException + +The default method definitions in the @Exception@ class do what we need +in this case. You can now throw and catch @ThisException@ and +@ThatException@ as exceptions: + +@ +*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) +Caught ThisException +@ + +In more complicated examples, you may wish to define a whole hierarchy +of exceptions: + +> --------------------------------------------------------------------- +> -- Make the root exception type for all the exceptions in a compiler +> +> data SomeCompilerException = forall e . Exception e => SomeCompilerException e +> +> instance Show SomeCompilerException where +> show (SomeCompilerException e) = show e +> +> instance Exception SomeCompilerException +> +> compilerExceptionToException :: Exception e => e -> SomeException +> compilerExceptionToException = toException . SomeCompilerException +> +> compilerExceptionFromException :: Exception e => SomeException -> Maybe e +> compilerExceptionFromException x = do +> SomeCompilerException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make a subhierarchy for exceptions in the frontend of the compiler +> +> data SomeFrontendException = forall e . Exception e => SomeFrontendException e +> +> instance Show SomeFrontendException where +> show (SomeFrontendException e) = show e +> +> instance Exception SomeFrontendException where +> toException = compilerExceptionToException +> fromException = compilerExceptionFromException +> +> frontendExceptionToException :: Exception e => e -> SomeException +> frontendExceptionToException = toException . SomeFrontendException +> +> frontendExceptionFromException :: Exception e => SomeException -> Maybe e +> frontendExceptionFromException x = do +> SomeFrontendException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make an exception type for a particular frontend compiler exception +> +> data MismatchedParentheses = MismatchedParentheses +> deriving Show +> +> instance Exception MismatchedParentheses where +> toException = frontendExceptionToException +> fromException = frontendExceptionFromException + +We can now catch a @MismatchedParentheses@ exception as +@MismatchedParentheses@, @SomeFrontendException@ or +@SomeCompilerException@, but not other types, e.g. @IOException@: + +@ +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException)) +*** Exception: MismatchedParentheses +@ + +-} +class (Typeable e, Show e) => Exception e where + toException :: e -> SomeException + fromException :: SomeException -> Maybe e + + toException = SomeException + fromException (SomeException e) = cast e + + -- | Render this exception value in a human-friendly manner. + -- + -- Default implementation: @'show'@. + -- + -- @since 4.8.0.0 + displayException :: e -> String + displayException = show + +-- | @since 3.0 +instance Exception SomeException where + toException se = se + fromException = Just + displayException (SomeException e) = displayException e + +-- |Arithmetic exceptions. +data ArithException + = Overflow + | Underflow + | LossOfPrecision + | DivideByZero + | Denormal + | RatioZeroDenominator -- ^ @since 4.6.0.0 + deriving ( Eq -- ^ @since 3.0 + , Ord -- ^ @since 3.0 + ) + +divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException +divZeroException = toException DivideByZero +overflowException = toException Overflow +ratioZeroDenomException = toException RatioZeroDenominator +underflowException = toException Underflow + +-- | @since 4.0.0.0 +instance Exception ArithException + +-- | @since 4.0.0.0 +instance Show ArithException where + showsPrec _ Overflow = showString "arithmetic overflow" + showsPrec _ Underflow = showString "arithmetic underflow" + showsPrec _ LossOfPrecision = showString "loss of precision" + showsPrec _ DivideByZero = showString "divide by zero" + showsPrec _ Denormal = showString "denormal" + showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/libraries/base/GHC/Exception/Type.hs-boot b/libraries/base/GHC/Exception/Type.hs-boot new file mode 100644 index 0000000000..1b4f0c0d81 --- /dev/null +++ b/libraries/base/GHC/Exception/Type.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Exception.Type + ( SomeException + , divZeroException + , overflowException + , ratioZeroDenomException + , underflowException + ) where + +import GHC.Types () + +data SomeException +divZeroException, overflowException, + ratioZeroDenomException, underflowException :: SomeException diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index ad2a872c39..9bc161105d 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -1082,6 +1082,36 @@ instance Ix Int64 where unsafeIndex (m,_) i = fromIntegral i - fromIntegral m inRange (m,n) i = m <= i && i <= n +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Int8" + fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt +"fromIntegral/Natural->Int16" + fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt +"fromIntegral/Natural->Int32" + fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt + #-} + +{-# RULES +"fromIntegral/Int8->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) +"fromIntegral/Int16->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) +"fromIntegral/Int32->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 & Int==Int64 +{-# RULES +"fromIntegral/Natural->Int64" + fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt +"fromIntegral/Int64->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) + #-} +#endif + {- Note [Order of tests] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/libraries/base/GHC/Maybe.hs b/libraries/base/GHC/Maybe.hs new file mode 100644 index 0000000000..9fcf8b717d --- /dev/null +++ b/libraries/base/GHC/Maybe.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Maybe type +module GHC.Maybe + ( Maybe (..) + ) +where + +import GHC.Integer () -- for build order +import GHC.Classes + +default () + +------------------------------------------------------------------------------- +-- Maybe type +------------------------------------------------------------------------------- + +-- | The 'Maybe' type encapsulates an optional value. A value of type +-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), +-- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to +-- deal with errors or exceptional cases without resorting to drastic +-- measures such as 'error'. +-- +-- The 'Maybe' type is also a monad. It is a simple kind of error +-- monad, where all errors are represented by 'Nothing'. A richer +-- error monad can be built using the 'Data.Either.Either' type. +-- +data Maybe a = Nothing | Just a + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs index 32cf2d2579..db8d8b883b 100644 --- a/libraries/base/GHC/Natural.hs +++ b/libraries/base/GHC/Natural.hs @@ -1,12 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | @@ -34,38 +30,76 @@ module GHC.Natural -- (i.e. which constructors are available) depends on the -- 'Integer' backend used! Natural(..) + , mkNatural , isValidNatural + -- * Arithmetic + , plusNatural + , minusNatural + , minusNaturalMaybe + , timesNatural + , negateNatural + , signumNatural + , quotRemNatural + , quotNatural + , remNatural +#if defined(MIN_VERSION_integer_gmp) + , gcdNatural + , lcmNatural +#endif + -- * Bits + , andNatural + , orNatural + , xorNatural + , bitNatural + , testBitNatural +#if defined(MIN_VERSION_integer_gmp) + , popCountNatural +#endif + , shiftLNatural + , shiftRNatural -- * Conversions + , naturalToInteger + , naturalToWord + , naturalToInt , naturalFromInteger , wordToNatural + , intToNatural , naturalToWordMaybe - -- * Checked subtraction - , minusNaturalMaybe + , wordToNatural# + , wordToNaturalBase -- * Modular arithmetic , powModNatural ) where #include "MachDeps.h" -import GHC.Arr -import GHC.Base -import {-# SOURCE #-} GHC.Exception (underflowException) +import GHC.Classes +import GHC.Maybe +import GHC.Types +import GHC.Prim +import {-# SOURCE #-} GHC.Exception.Type (underflowException, divZeroException) #if defined(MIN_VERSION_integer_gmp) import GHC.Integer.GMP.Internals -import Data.Word -import Data.Int +#else +import GHC.Integer #endif -import GHC.Num -import GHC.Real -import GHC.Read -import GHC.Show -import GHC.Enum -import GHC.List - -import Data.Bits default () +-- Most high-level operations need to be marked `NOINLINE` as +-- otherwise GHC doesn't recognize them and fails to apply constant +-- folding to `Natural`-typed expression. +-- +-- To this end, the CPP hack below allows to write the pseudo-pragma +-- +-- {-# CONSTANT_FOLDED plusNatural #-} +-- +-- which is simply expanded into a +-- +-- {-# NOINLINE plusNatural #-} +-- +#define CONSTANT_FOLDED NOINLINE + ------------------------------------------------------------------------------- -- Arithmetic underflow ------------------------------------------------------------------------------- @@ -77,6 +111,10 @@ default () underflowError :: a underflowError = raise# underflowException +{-# NOINLINE divZeroError #-} +divZeroError :: a +divZeroError = raise# divZeroException + ------------------------------------------------------------------------------- -- Natural type ------------------------------------------------------------------------------- @@ -117,107 +155,32 @@ data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ isValidNatural :: Natural -> Bool isValidNatural (NatS# _) = True isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn) - && I# (sizeofBigNat# bn) > 0 - -{-# RULES -"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural -"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer -"fromIntegral/Natural->Word" fromIntegral = naturalToWord -"fromIntegral/Natural->Word8" - fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord -"fromIntegral/Natural->Word16" - fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord -"fromIntegral/Natural->Word32" - fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord -"fromIntegral/Natural->Int8" - fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt -"fromIntegral/Natural->Int16" - fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt -"fromIntegral/Natural->Int32" - fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt - #-} - -{-# RULES -"fromIntegral/Word->Natural" fromIntegral = wordToNatural -"fromIntegral/Word8->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) -"fromIntegral/Word16->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) -"fromIntegral/Word32->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) -"fromIntegral/Int->Natural" fromIntegral = intToNatural -"fromIntegral/Int8->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) -"fromIntegral/Int16->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) -"fromIntegral/Int32->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) - #-} - -#if WORD_SIZE_IN_BITS == 64 --- these RULES are valid for Word==Word64 & Int==Int64 -{-# RULES -"fromIntegral/Natural->Word64" - fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord -"fromIntegral/Natural->Int64" - fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt -"fromIntegral/Word64->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) -"fromIntegral/Int64->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) - #-} -#endif - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec p (NatS# w#) = showsPrec p (W# w#) - showsPrec p (NatJ# bn) = showsPrec p (Jp# bn) - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (fromInteger n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Num Natural where - fromInteger = naturalFromInteger + && isTrue# (sizeofBigNat# bn ># 0#) - (+) = plusNatural - (*) = timesNatural - (-) = minusNatural +signumNatural :: Natural -> Natural +signumNatural (NatS# 0##) = NatS# 0## +signumNatural _ = NatS# 1## +{-# CONSTANT_FOLDED signumNatural #-} - abs = id - - signum (NatS# 0##) = NatS# 0## - signum _ = NatS# 1## - - negate (NatS# 0##) = NatS# 0## - negate _ = underflowError +negateNatural :: Natural -> Natural +negateNatural (NatS# 0##) = NatS# 0## +negateNatural _ = underflowError +{-# CONSTANT_FOLDED negateNatural #-} -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural -naturalFromInteger (S# i#) | I# i# >= 0 = NatS# (int2Word# i#) -naturalFromInteger (Jp# bn) = bigNatToNatural bn -naturalFromInteger _ = underflowError -{-# INLINE naturalFromInteger #-} - --- | @since 4.8.0.0 -instance Real Natural where - toRational (NatS# w) = toRational (W# w) - toRational (NatJ# bn) = toRational (Jp# bn) - -#if OPTIMISE_INTEGER_GCD_LCM -{-# RULES -"gcd/Natural->Natural->Natural" gcd = gcdNatural -"lcm/Natural->Natural->Natural" lcm = lcmNatural - #-} +naturalFromInteger (S# i#) + | isTrue# (i# >=# 0#) = NatS# (int2Word# i#) +naturalFromInteger (Jp# bn) = bigNatToNatural bn +naturalFromInteger _ = underflowError +{-# CONSTANT_FOLDED naturalFromInteger #-} -- | Compute greatest common divisor. gcdNatural :: Natural -> Natural -> Natural gcdNatural (NatS# 0##) y = y gcdNatural x (NatS# 0##) = x -gcdNatural (NatS# 1##) _ = (NatS# 1##) -gcdNatural _ (NatS# 1##) = (NatS# 1##) +gcdNatural (NatS# 1##) _ = NatS# 1## +gcdNatural _ (NatS# 1##) = NatS# 1## gcdNatural (NatJ# x) (NatJ# y) = bigNatToNatural (gcdBigNat x y) gcdNatural (NatJ# x) (NatS# y) = NatS# (gcdBigNatWord x y) gcdNatural (NatS# x) (NatJ# y) = NatS# (gcdBigNatWord y x) @@ -225,162 +188,107 @@ gcdNatural (NatS# x) (NatS# y) = NatS# (gcdWord x y) -- | compute least common multiplier. lcmNatural :: Natural -> Natural -> Natural -lcmNatural (NatS# 0##) _ = (NatS# 0##) -lcmNatural _ (NatS# 0##) = (NatS# 0##) +lcmNatural (NatS# 0##) _ = NatS# 0## +lcmNatural _ (NatS# 0##) = NatS# 0## lcmNatural (NatS# 1##) y = y lcmNatural x (NatS# 1##) = x -lcmNatural x y = (x `quot` (gcdNatural x y)) * y - -#endif - --- | @since 4.8.0.0 -instance Enum Natural where - succ n = n `plusNatural` NatS# 1## - pred n = n `minusNatural` NatS# 1## - - toEnum = intToNatural - - fromEnum (NatS# w) | i >= 0 = i - where - i = fromIntegral (W# w) - fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range" - - enumFrom x = enumDeltaNatural x (NatS# 1##) - enumFromThen x y - | x <= y = enumDeltaNatural x (y-x) - | otherwise = enumNegDeltaToNatural x (x-y) (NatS# 0##) - - enumFromTo x lim = enumDeltaToNatural x (NatS# 1##) lim - enumFromThenTo x y lim - | x <= y = enumDeltaToNatural x (y-x) lim - | otherwise = enumNegDeltaToNatural x (x-y) lim - ----------------------------------------------------------------------------- --- Helpers for 'Enum Natural'; TODO: optimise & make fusion work - -enumDeltaNatural :: Natural -> Natural -> [Natural] -enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d - -enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumDeltaToNatural x0 delta lim = go x0 - where - go x | x > lim = [] - | otherwise = x : go (x+delta) - -enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumNegDeltaToNatural x0 ndelta lim = go x0 - where - go x | x < lim = [] - | x >= ndelta = x : go (x-ndelta) - | otherwise = [x] +lcmNatural x y = (x `quotNatural` (gcdNatural x y)) `timesNatural` y ---------------------------------------------------------------------------- --- | @since 4.8.0.0 -instance Integral Natural where - toInteger (NatS# w) = wordToInteger w - toInteger (NatJ# bn) = Jp# bn - - divMod = quotRem - div = quot - mod = rem - - quotRem _ (NatS# 0##) = divZeroError - quotRem n (NatS# 1##) = (n,NatS# 0##) - quotRem n@(NatS# _) (NatJ# _) = (NatS# 0##, n) - quotRem (NatS# n) (NatS# d) = case quotRem (W# n) (W# d) of - (q,r) -> (wordToNatural q, wordToNatural r) - quotRem (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of - (# q,r #) -> (bigNatToNatural q, NatS# r) - quotRem (NatJ# n) (NatJ# d) = case quotRemBigNat n d of - (# q,r #) -> (bigNatToNatural q, bigNatToNatural r) - - quot _ (NatS# 0##) = divZeroError - quot n (NatS# 1##) = n - quot (NatS# _) (NatJ# _) = NatS# 0## - quot (NatS# n) (NatS# d) = wordToNatural (quot (W# n) (W# d)) - quot (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) - quot (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) - - rem _ (NatS# 0##) = divZeroError - rem _ (NatS# 1##) = NatS# 0## - rem n@(NatS# _) (NatJ# _) = n - rem (NatS# n) (NatS# d) = wordToNatural (rem (W# n) (W# d)) - rem (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) - rem (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) - --- | @since 4.8.0.0 -instance Ix Natural where - range (m,n) = [m..n] - inRange (m,n) i = m <= i && i <= n - unsafeIndex (m,_) i = fromIntegral (i-m) - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Natural" - - --- | @since 4.8.0.0 -instance Bits Natural where - NatS# n .&. NatS# m = wordToNatural (W# n .&. W# m) - NatS# n .&. NatJ# m = wordToNatural (W# n .&. W# (bigNatToWord m)) - NatJ# n .&. NatS# m = wordToNatural (W# (bigNatToWord n) .&. W# m) - NatJ# n .&. NatJ# m = bigNatToNatural (andBigNat n m) - - NatS# n .|. NatS# m = wordToNatural (W# n .|. W# m) - NatS# n .|. NatJ# m = NatJ# (orBigNat (wordToBigNat n) m) - NatJ# n .|. NatS# m = NatJ# (orBigNat n (wordToBigNat m)) - NatJ# n .|. NatJ# m = NatJ# (orBigNat n m) - - NatS# n `xor` NatS# m = wordToNatural (W# n `xor` W# m) - NatS# n `xor` NatJ# m = NatJ# (xorBigNat (wordToBigNat n) m) - NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m)) - NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m) - - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - - bitSizeMaybe _ = Nothing - bitSize = errorWithoutStackTrace "Natural: bitSize" - isSigned _ = False - - bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i) - | otherwise = NatJ# (bitBigNat i#) - - testBit (NatS# w) i = testBit (W# w) i - testBit (NatJ# bn) (I# i#) = testBitBigNat bn i# - - clearBit n@(NatS# w#) i - | i < finiteBitSize (0::Word) = let !(W# w2#) = clearBit (W# w#) i in NatS# w2# - | otherwise = n - clearBit (NatJ# bn) (I# i#) = bigNatToNatural (clearBitBigNat bn i#) - - setBit (NatS# w#) i@(I# i#) - | i < finiteBitSize (0::Word) = let !(W# w2#) = setBit (W# w#) i in NatS# w2# - | otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#) - setBit (NatJ# bn) (I# i#) = bigNatToNatural (setBitBigNat bn i#) - - complementBit (NatS# w#) i@(I# i#) - | i < finiteBitSize (0::Word) = let !(W# w2#) = complementBit (W# w#) i in NatS# w2# - | otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#) - complementBit (NatJ# bn) (I# i#) = bigNatToNatural (complementBitBigNat bn i#) - - shiftL n 0 = n - shiftL (NatS# 0##) _ = NatS# 0## - shiftL (NatS# 1##) i = bit i - shiftL (NatS# w) (I# i#) - = bigNatToNatural $ shiftLBigNat (wordToBigNat w) i# - shiftL (NatJ# bn) (I# i#) - = bigNatToNatural $ shiftLBigNat bn i# - - shiftR n 0 = n - shiftR (NatS# w) i = wordToNatural $ shiftR (W# w) i - shiftR (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) - - rotateL = shiftL - rotateR = shiftR - - popCount (NatS# w) = popCount (W# w) - popCount (NatJ# bn) = I# (popCountBigNat bn) - - zeroBits = NatS# 0## +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural _ (NatS# 0##) = divZeroError +quotRemNatural n (NatS# 1##) = (n,NatS# 0##) +quotRemNatural n@(NatS# _) (NatJ# _) = (NatS# 0##, n) +quotRemNatural (NatS# n) (NatS# d) = case quotRemWord# n d of + (# q, r #) -> (NatS# q, NatS# r) +quotRemNatural (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of + (# q, r #) -> (bigNatToNatural q, NatS# r) +quotRemNatural (NatJ# n) (NatJ# d) = case quotRemBigNat n d of + (# q, r #) -> (bigNatToNatural q, bigNatToNatural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural _ (NatS# 0##) = divZeroError +quotNatural n (NatS# 1##) = n +quotNatural (NatS# _) (NatJ# _) = NatS# 0## +quotNatural (NatS# n) (NatS# d) = NatS# (quotWord# n d) +quotNatural (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) +quotNatural (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural _ (NatS# 0##) = divZeroError +remNatural _ (NatS# 1##) = NatS# 0## +remNatural n@(NatS# _) (NatJ# _) = n +remNatural (NatS# n) (NatS# d) = NatS# (remWord# n d) +remNatural (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) +remNatural (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) +{-# CONSTANT_FOLDED remNatural #-} + +-- | @since 4.X.0.0 +naturalToInteger :: Natural -> Integer +naturalToInteger (NatS# w) = wordToInteger w +naturalToInteger (NatJ# bn) = Jp# bn +{-# CONSTANT_FOLDED naturalToInteger #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (NatS# n) (NatS# m) = NatS# (n `and#` m) +andNatural (NatS# n) (NatJ# m) = NatS# (n `and#` bigNatToWord m) +andNatural (NatJ# n) (NatS# m) = NatS# (bigNatToWord n `and#` m) +andNatural (NatJ# n) (NatJ# m) = bigNatToNatural (andBigNat n m) +{-# CONSTANT_FOLDED andNatural #-} + +orNatural :: Natural -> Natural -> Natural +orNatural (NatS# n) (NatS# m) = NatS# (n `or#` m) +orNatural (NatS# n) (NatJ# m) = NatJ# (orBigNat (wordToBigNat n) m) +orNatural (NatJ# n) (NatS# m) = NatJ# (orBigNat n (wordToBigNat m)) +orNatural (NatJ# n) (NatJ# m) = NatJ# (orBigNat n m) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (NatS# n) (NatS# m) = NatS# (n `xor#` m) +xorNatural (NatS# n) (NatJ# m) = NatJ# (xorBigNat (wordToBigNat n) m) +xorNatural (NatJ# n) (NatS# m) = NatJ# (xorBigNat n (wordToBigNat m)) +xorNatural (NatJ# n) (NatJ# m) = bigNatToNatural (xorBigNat n m) +{-# CONSTANT_FOLDED xorNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = NatS# (1## `uncheckedShiftL#` i#) + | True = NatJ# (bitBigNat i#) +{-# CONSTANT_FOLDED bitNatural #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (NatS# w) (I# i#) + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = + isTrue# ((w `and#` (1## `uncheckedShiftL#` i#)) `neWord#` 0##) + | True = False +testBitNatural (NatJ# bn) (I# i#) = testBitBigNat bn i# +{-# CONSTANT_FOLDED testBitNatural #-} + +popCountNatural :: Natural -> Int +popCountNatural (NatS# w) = I# (word2Int# (popCnt# w)) +popCountNatural (NatJ# bn) = I# (popCountBigNat bn) +{-# CONSTANT_FOLDED popCountNatural #-} + +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural n (I# 0#) = n +shiftLNatural (NatS# 0##) _ = NatS# 0## +shiftLNatural (NatS# 1##) (I# i#) = bitNatural i# +shiftLNatural (NatS# w) (I# i#) + = bigNatToNatural (shiftLBigNat (wordToBigNat w) i#) +shiftLNatural (NatJ# bn) (I# i#) + = bigNatToNatural (shiftLBigNat bn i#) +{-# CONSTANT_FOLDED shiftLNatural #-} + +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural n (I# 0#) = n +shiftRNatural (NatS# w) (I# i#) + | isTrue# (i# >=# WORD_SIZE_IN_BITS#) = NatS# 0## + | True = NatS# (w `uncheckedShiftRL#` i#) +shiftRNatural (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) +{-# CONSTANT_FOLDED shiftRNatural #-} ---------------------------------------------------------------------------- @@ -395,6 +303,7 @@ plusNatural (NatS# x) (NatS# y) plusNatural (NatS# x) (NatJ# y) = NatJ# (plusBigNatWord y x) plusNatural (NatJ# x) (NatS# y) = NatJ# (plusBigNatWord x y) plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat x y) +{-# CONSTANT_FOLDED plusNatural #-} -- | 'Natural' multiplication timesNatural :: Natural -> Natural -> Natural @@ -405,10 +314,11 @@ timesNatural (NatS# 1##) y = y timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of (# 0##, 0## #) -> NatS# 0## (# 0##, xy #) -> NatS# xy - (# h , l #) -> NatJ# $ wordToBigNat2 h l -timesNatural (NatS# x) (NatJ# y) = NatJ# $ timesBigNatWord y x -timesNatural (NatJ# x) (NatS# y) = NatJ# $ timesBigNatWord x y -timesNatural (NatJ# x) (NatJ# y) = NatJ# $ timesBigNat x y + (# h , l #) -> NatJ# (wordToBigNat2 h l) +timesNatural (NatS# x) (NatJ# y) = NatJ# (timesBigNatWord y x) +timesNatural (NatJ# x) (NatS# y) = NatJ# (timesBigNatWord x y) +timesNatural (NatJ# x) (NatJ# y) = NatJ# (timesBigNat x y) +{-# CONSTANT_FOLDED timesNatural #-} -- | 'Natural' subtraction. May @'throw' 'Underflow'@. minusNatural :: Natural -> Natural -> Natural @@ -418,9 +328,10 @@ minusNatural (NatS# x) (NatS# y) = case subWordC# x y of _ -> underflowError minusNatural (NatS# _) (NatJ# _) = underflowError minusNatural (NatJ# x) (NatS# y) - = bigNatToNatural $ minusBigNatWord x y + = bigNatToNatural (minusBigNatWord x y) minusNatural (NatJ# x) (NatJ# y) - = bigNatToNatural $ minusBigNat x y + = bigNatToNatural (minusBigNat x y) +{-# CONSTANT_FOLDED minusNatural #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- @@ -430,13 +341,12 @@ minusNaturalMaybe x (NatS# 0##) = Just x minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of (# l, 0# #) -> Just (NatS# l) _ -> Nothing - where minusNaturalMaybe (NatS# _) (NatJ# _) = Nothing minusNaturalMaybe (NatJ# x) (NatS# y) - = Just $ bigNatToNatural $ minusBigNatWord x y + = Just (bigNatToNatural (minusBigNatWord x y)) minusNaturalMaybe (NatJ# x) (NatJ# y) | isTrue# (isNullBigNat# res) = Nothing - | otherwise = Just (bigNatToNatural res) + | True = Just (bigNatToNatural res) where res = minusBigNat x y @@ -446,18 +356,12 @@ bigNatToNatural :: BigNat -> Natural bigNatToNatural bn | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn) | isTrue# (isNullBigNat# bn) = underflowError - | otherwise = NatJ# bn + | True = NatJ# bn naturalToBigNat :: Natural -> BigNat naturalToBigNat (NatS# w#) = wordToBigNat w# naturalToBigNat (NatJ# bn) = bn --- | Convert 'Int' to 'Natural'. --- Throws 'Underflow' when passed a negative 'Int'. -intToNatural :: Int -> Natural -intToNatural i | i<0 = underflowError -intToNatural (I# i#) = NatS# (int2Word# i#) - naturalToWord :: Natural -> Word naturalToWord (NatS# w#) = W# w# naturalToWord (NatJ# bn) = W# (bigNatToWord bn) @@ -466,6 +370,23 @@ naturalToInt :: Natural -> Int naturalToInt (NatS# w#) = I# (word2Int# w#) naturalToInt (NatJ# bn) = I# (bigNatToInt bn) +---------------------------------------------------------------------------- + +-- | Convert a Word# into a Natural +-- +-- Built-in rule ensures that applications of this function to literal Word# are +-- lifted into Natural literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w# = NatS# w# +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a Word# into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w# = NatS# w# + #else /* !defined(MIN_VERSION_integer_gmp) */ ---------------------------------------------------------------------------- -- Use wrapped 'Integer' as fallback; taken from Edward Kmett's nats package @@ -477,156 +398,141 @@ naturalToInt (NatJ# bn) = I# (bigNatToInt bn) -- -- @since 4.8.0.0 newtype Natural = Natural Integer -- ^ __Invariant__: non-negative 'Integer' - deriving (Eq,Ord,Ix) + deriving (Eq,Ord) + -- | Test whether all internal invariants are satisfied by 'Natural' value -- -- This operation is mostly useful for test-suites and/or code which --- constructs 'Integer' values directly. +-- constructs 'Natural' values directly. -- -- @since 4.8.0.0 isValidNatural :: Natural -> Bool -isValidNatural (Natural i) = i >= 0 - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (Natural n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec d (Natural i) = showsPrec d i - --- | @since 4.8.0.0 -instance Num Natural where - Natural n + Natural m = Natural (n + m) - {-# INLINE (+) #-} - Natural n * Natural m = Natural (n * m) - {-# INLINE (*) #-} - Natural n - Natural m | result < 0 = underflowError - | otherwise = Natural result - where result = n - m - {-# INLINE (-) #-} - abs (Natural n) = Natural n - {-# INLINE abs #-} - signum (Natural n) = Natural (signum n) - {-# INLINE signum #-} - fromInteger = naturalFromInteger - {-# INLINE fromInteger #-} +isValidNatural (Natural i) = i >= wordToInteger 0## + +-- | Convert a Word# into a Natural +-- +-- Built-in rule ensures that applications of this function to literal Word# are +-- lifted into Natural literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w## = Natural (wordToInteger w##) +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a Word# into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w## = Natural (wordToInteger w##) -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural naturalFromInteger n - | n >= 0 = Natural n - | otherwise = underflowError + | n >= wordToInteger 0## = Natural n + | True = underflowError {-# INLINE naturalFromInteger #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- -- @since 4.8.0.0 minusNaturalMaybe :: Natural -> Natural -> Maybe Natural -minusNaturalMaybe x y - | x >= y = Just (x - y) - | otherwise = Nothing - --- | @since 4.8.0.0 -instance Bits Natural where - Natural n .&. Natural m = Natural (n .&. m) - {-# INLINE (.&.) #-} - Natural n .|. Natural m = Natural (n .|. m) - {-# INLINE (.|.) #-} - xor (Natural n) (Natural m) = Natural (xor n m) - {-# INLINE xor #-} - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - {-# INLINE complement #-} - shift (Natural n) = Natural . shift n - {-# INLINE shift #-} - rotate (Natural n) = Natural . rotate n - {-# INLINE rotate #-} - bit = Natural . bit - {-# INLINE bit #-} - setBit (Natural n) = Natural . setBit n - {-# INLINE setBit #-} - clearBit (Natural n) = Natural . clearBit n - {-# INLINE clearBit #-} - complementBit (Natural n) = Natural . complementBit n - {-# INLINE complementBit #-} - testBit (Natural n) = testBit n - {-# INLINE testBit #-} - bitSizeMaybe _ = Nothing - {-# INLINE bitSizeMaybe #-} - bitSize = errorWithoutStackTrace "Natural: bitSize" - {-# INLINE bitSize #-} - isSigned _ = False - {-# INLINE isSigned #-} - shiftL (Natural n) = Natural . shiftL n - {-# INLINE shiftL #-} - shiftR (Natural n) = Natural . shiftR n - {-# INLINE shiftR #-} - rotateL (Natural n) = Natural . rotateL n - {-# INLINE rotateL #-} - rotateR (Natural n) = Natural . rotateR n - {-# INLINE rotateR #-} - popCount (Natural n) = popCount n - {-# INLINE popCount #-} - zeroBits = Natural 0 - --- | @since 4.8.0.0 -instance Real Natural where - toRational (Natural a) = toRational a - {-# INLINE toRational #-} - --- | @since 4.8.0.0 -instance Enum Natural where - pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" - pred (Natural n) = Natural (pred n) - {-# INLINE pred #-} - succ (Natural n) = Natural (succ n) - {-# INLINE succ #-} - fromEnum (Natural n) = fromEnum n - {-# INLINE fromEnum #-} - toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" - | otherwise = Natural (toEnum n) - {-# INLINE toEnum #-} - - enumFrom = coerce (enumFrom :: Integer -> [Integer]) - enumFromThen x y - | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y - | otherwise = enumFromThenTo x y 0 - - enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) - enumFromThenTo - = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) - --- | @since 4.8.0.0 -instance Integral Natural where - quot (Natural a) (Natural b) = Natural (quot a b) - {-# INLINE quot #-} - rem (Natural a) (Natural b) = Natural (rem a b) - {-# INLINE rem #-} - div (Natural a) (Natural b) = Natural (div a b) - {-# INLINE div #-} - mod (Natural a) (Natural b) = Natural (mod a b) - {-# INLINE mod #-} - divMod (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = divMod a b - {-# INLINE divMod #-} - quotRem (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = quotRem a b - {-# INLINE quotRem #-} - toInteger (Natural a) = a - {-# INLINE toInteger #-} +minusNaturalMaybe (Natural x) (Natural y) + | x >= y = Just (Natural (x `minusInteger` y)) + | True = Nothing + +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural (Natural n) (I# i) = Natural (n `shiftLInteger` i) +{-# CONSTANT_FOLDED shiftLNatural #-} + +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural (Natural n) (I# i) = Natural (n `shiftRInteger` i) +{-# CONSTANT_FOLDED shiftRNatural #-} + +plusNatural :: Natural -> Natural -> Natural +plusNatural (Natural x) (Natural y) = Natural (x `plusInteger` y) +{-# CONSTANT_FOLDED plusNatural #-} + +minusNatural :: Natural -> Natural -> Natural +minusNatural (Natural x) (Natural y) = Natural (x `minusInteger` y) +{-# CONSTANT_FOLDED minusNatural #-} + +timesNatural :: Natural -> Natural -> Natural +timesNatural (Natural x) (Natural y) = Natural (x `timesInteger` y) +{-# CONSTANT_FOLDED timesNatural #-} + +orNatural :: Natural -> Natural -> Natural +orNatural (Natural x) (Natural y) = Natural (x `orInteger` y) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (Natural x) (Natural y) = Natural (x `xorInteger` y) +{-# CONSTANT_FOLDED xorNatural #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (Natural x) (Natural y) = Natural (x `andInteger` y) +{-# CONSTANT_FOLDED andNatural #-} + +naturalToInt :: Natural -> Int +naturalToInt (Natural i) = I# (integerToInt i) + +naturalToWord :: Natural -> Word +naturalToWord (Natural i) = W# (integerToWord i) + +naturalToInteger :: Natural -> Integer +naturalToInteger (Natural i) = i +{-# CONSTANT_FOLDED naturalToInteger #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (Natural n) (I# i) = testBitInteger n i +{-# CONSTANT_FOLDED testBitNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = wordToNaturalBase (1## `uncheckedShiftL#` i#) + | True = Natural (1 `shiftLInteger` i#) +{-# CONSTANT_FOLDED bitNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = n + | True = Natural (x `quotInteger` y) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural (Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = wordToNaturalBase 0## + | True = Natural (x `remInteger` y) +{-# CONSTANT_FOLDED remNatural #-} + +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = (n,wordToNaturalBase 0##) + | True = case quotRemInteger x y of + (# k, r #) -> (Natural k, Natural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +signumNatural :: Natural -> Natural +signumNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = wordToNaturalBase 1## +{-# CONSTANT_FOLDED signumNatural #-} + +negateNatural :: Natural -> Natural +negateNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = underflowError +{-# CONSTANT_FOLDED negateNatural #-} + #endif -- | Construct 'Natural' from 'Word' value. -- -- @since 4.8.0.0 wordToNatural :: Word -> Natural -#if defined(MIN_VERSION_integer_gmp) -wordToNatural (W# w#) = NatS# w# -#else -wordToNatural w = Natural (fromIntegral w) -#endif +wordToNatural (W# w#) = wordToNatural# w# -- | Try downcasting 'Natural' to 'Word' value. -- Returns 'Nothing' if value doesn't fit in 'Word'. @@ -638,10 +544,10 @@ naturalToWordMaybe (NatS# w#) = Just (W# w#) naturalToWordMaybe (NatJ# _) = Nothing #else naturalToWordMaybe (Natural i) - | i <= maxw = Just (fromIntegral i) - | otherwise = Nothing + | i < maxw = Just (W# (integerToWord i)) + | True = Nothing where - maxw = toInteger (maxBound :: Word) + maxw = 1 `shiftLInteger` WORD_SIZE_IN_BITS# #endif -- | \"@'powModNatural' /b/ /e/ /m/@\" computes base @/b/@ raised to @@ -662,18 +568,38 @@ powModNatural b e (NatJ# m) = bigNatToNatural (powModBigNat (naturalToBigNat b) (naturalToBigNat e) m) #else -- Portable reference fallback implementation -powModNatural _ _ 0 = divZeroError -powModNatural _ _ 1 = 0 -powModNatural _ 0 _ = 1 -powModNatural 0 _ _ = 0 -powModNatural 1 _ _ = 1 -powModNatural b0 e0 m = go b0 e0 1 +powModNatural (Natural b0) (Natural e0) (Natural m) + | m == wordToInteger 0## = divZeroError + | m == wordToInteger 1## = wordToNaturalBase 0## + | e0 == wordToInteger 0## = wordToNaturalBase 1## + | b0 == wordToInteger 0## = wordToNaturalBase 0## + | b0 == wordToInteger 1## = wordToNaturalBase 1## + | True = go b0 e0 (wordToInteger 1##) where go !b e !r - | odd e = go b' e' (r*b `mod` m) - | e == 0 = r - | otherwise = go b' e' r + | e `testBitInteger` 0# = go b' e' ((r `timesInteger` b) `modInteger` m) + | e == wordToInteger 0## = naturalFromInteger r + | True = go b' e' r where - b' = b*b `mod` m - e' = e `unsafeShiftR` 1 -- slightly faster than "e `div` 2" + b' = (b `timesInteger` b) `modInteger` m + e' = e `shiftRInteger` 1# -- slightly faster than "e `div` 2" #endif + + +-- | Construct 'Natural' value from list of 'Word's. +-- +-- This function is used by GHC for constructing 'Natural' literals. +mkNatural :: [Word] -- ^ value expressed in 32 bit chunks, least + -- significant first + -> Natural +mkNatural [] = wordToNaturalBase 0## +mkNatural (W# i : is') = wordToNaturalBase (i `and#` 0xffffffff##) `orNatural` + shiftLNatural (mkNatural is') 31 +{-# CONSTANT_FOLDED mkNatural #-} + +-- | Convert 'Int' to 'Natural'. +-- Throws 'Underflow' when passed a negative 'Int'. +intToNatural :: Int -> Natural +intToNatural (I# i#) + | isTrue# (i# <# 0#) = underflowError + | True = wordToNaturalBase (int2Word# i#) diff --git a/libraries/base/GHC/Num.hs b/libraries/base/GHC/Num.hs index fd98c19f20..795e74a4af 100644 --- a/libraries/base/GHC/Num.hs +++ b/libraries/base/GHC/Num.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -16,10 +16,17 @@ -- ----------------------------------------------------------------------------- -module GHC.Num (module GHC.Num, module GHC.Integer) where + +module GHC.Num (module GHC.Num, module GHC.Integer, module GHC.Natural) where + +#include "MachDeps.h" import GHC.Base import GHC.Integer +import GHC.Natural +#if !defined(MIN_VERSION_integer_gmp) +import {-# SOURCE #-} GHC.Exception.Type (underflowException) +#endif infixl 7 * infixl 6 +, - @@ -100,3 +107,35 @@ instance Num Integer where abs = absInteger signum = signumInteger + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Num Natural where + (+) = plusNatural + (-) = minusNatural + (*) = timesNatural + negate = negateNatural + fromInteger = naturalFromInteger + + abs = id + signum = signumNatural + +#else +-- | @since 4.8.0.0 +instance Num Natural where + Natural n + Natural m = Natural (n + m) + {-# INLINE (+) #-} + Natural n * Natural m = Natural (n * m) + {-# INLINE (*) #-} + Natural n - Natural m + | m > n = raise# underflowException + | otherwise = Natural (n - m) + {-# INLINE (-) #-} + abs (Natural n) = Natural n + {-# INLINE abs #-} + signum (Natural n) = Natural (signum n) + {-# INLINE signum #-} + fromInteger = naturalFromInteger + {-# INLINE fromInteger #-} + +#endif diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs index f7870a2df1..ef9d8df2e5 100644 --- a/libraries/base/GHC/Read.hs +++ b/libraries/base/GHC/Read.hs @@ -72,6 +72,7 @@ import GHC.Show import GHC.Base import GHC.Arr import GHC.Word +import GHC.List (filter) -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with @@ -616,6 +617,19 @@ instance Read Integer where readListPrec = readListPrecDefault readList = readListDefault + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (fromInteger n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#else +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (Natural n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#endif + -- | @since 2.01 instance Read Float where readPrec = readNumber convertFrac diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs index 7f2ecd0dc5..f88666af40 100644 --- a/libraries/base/GHC/Real.hs +++ b/libraries/base/GHC/Real.hs @@ -20,12 +20,16 @@ module GHC.Real where +#include "MachDeps.h" + import GHC.Base import GHC.Num import GHC.List import GHC.Enum import GHC.Show -import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException, ratioZeroDenomException ) +import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException + , underflowException + , ratioZeroDenomException ) #if defined(OPTIMISE_INTEGER_GCD_LCM) # if defined(MIN_VERSION_integer_gmp) @@ -61,6 +65,11 @@ ratioZeroDenominatorError = raise# ratioZeroDenomException overflowError :: a overflowError = raise# overflowException +{-# NOINLINE underflowError #-} +underflowError :: a +underflowError = raise# underflowException + + -------------------------------------------------------------- -- The Ratio and Rational types -------------------------------------------------------------- @@ -376,6 +385,18 @@ instance Integral Word where instance Real Integer where toRational x = x :% 1 +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Real Natural where + toRational (NatS# w) = toRational (W# w) + toRational (NatJ# bn) = toRational (Jp# bn) +#else +-- | @since 4.8.0.0 +instance Real Natural where + toRational (Natural a) = toRational a + {-# INLINE toRational #-} +#endif + -- Note [Integer division constant folding] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -418,6 +439,39 @@ instance Integral Integer where n `quotRem` d = case n `quotRemInteger` d of (# q, r #) -> (q, r) +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Integral Natural where + toInteger = naturalToInteger + + divMod = quotRemNatural + div = quotNatural + mod = remNatural + + quotRem = quotRemNatural + quot = quotNatural + rem = remNatural +#else +-- | @since 4.8.0.0 +instance Integral Natural where + quot (Natural a) (Natural b) = Natural (quot a b) + {-# INLINE quot #-} + rem (Natural a) (Natural b) = Natural (rem a b) + {-# INLINE rem #-} + div (Natural a) (Natural b) = Natural (div a b) + {-# INLINE div #-} + mod (Natural a) (Natural b) = Natural (mod a b) + {-# INLINE mod #-} + divMod (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = divMod a b + {-# INLINE divMod #-} + quotRem (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = quotRem a b + {-# INLINE quotRem #-} + toInteger (Natural a) = a + {-# INLINE toInteger #-} +#endif + -------------------------------------------------------------- -- Instances for @Ratio@ -------------------------------------------------------------- @@ -506,6 +560,17 @@ fromIntegral = fromInteger . toInteger "fromIntegral/Word->Word" fromIntegral = id :: Word -> Word #-} +{-# RULES +"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural +"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer +"fromIntegral/Natural->Word" fromIntegral = naturalToWord + #-} + +{-# RULES +"fromIntegral/Word->Natural" fromIntegral = wordToNatural +"fromIntegral/Int->Natural" fromIntegral = intToNatural + #-} + -- | general coercion to fractional types realToFrac :: (Real a, Fractional b) => a -> b {-# NOINLINE [1] realToFrac #-} @@ -698,6 +763,8 @@ lcm x y = abs ((x `quot` (gcd x y)) * y) "gcd/Int->Int->Int" gcd = gcdInt' "gcd/Integer->Integer->Integer" gcd = gcdInteger "lcm/Integer->Integer->Integer" lcm = lcmInteger +"gcd/Natural->Natural->Natural" gcd = gcdNatural +"lcm/Natural->Natural->Natural" lcm = lcmNatural #-} gcdInt' :: Int -> Int -> Int diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs index 798dff9891..a41bf81cb3 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -479,6 +479,13 @@ instance Show Integer where | otherwise = integerToString n r showList = showList__ (showsPrec 0) +-- | @since 4.8.0.0 +instance Show Natural where +#if defined(MIN_VERSION_integer_gmp) + showsPrec p (NatS# w#) = showsPrec p (W# w#) +#endif + showsPrec p i = showsPrec p (naturalToInteger i) + -- Divide and conquer implementation of string conversion integerToString :: Integer -> String -> String integerToString n0 cs0 diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs index d40342c9de..4c8a106ae5 100644 --- a/libraries/base/GHC/Stack/Types.hs +++ b/libraries/base/GHC/Stack/Types.hs @@ -53,6 +53,7 @@ import GHC.Types (Char, Int) -- Make implicit dependency known to build system import GHC.Tuple () import GHC.Integer () +import GHC.Natural () ---------------------------------------------------------------------- -- Explicit call-stacks built via ImplicitParams diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs index 1df9d14693..18cc4dbcc4 100644 --- a/libraries/base/GHC/Word.hs +++ b/libraries/base/GHC/Word.hs @@ -972,3 +972,33 @@ byteSwap64 (W64# w#) = W64# (byteSwap64# w#) byteSwap64 :: Word64 -> Word64 byteSwap64 (W64# w#) = W64# (byteSwap# w#) #endif + +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Word8" + fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord +"fromIntegral/Natural->Word16" + fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord +"fromIntegral/Natural->Word32" + fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord + #-} + +{-# RULES +"fromIntegral/Word8->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) +"fromIntegral/Word16->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) +"fromIntegral/Word32->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 +{-# RULES +"fromIntegral/Natural->Word64" + fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord +"fromIntegral/Word64->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) + #-} +#endif diff --git a/libraries/base/Unsafe/Coerce.hs b/libraries/base/Unsafe/Coerce.hs index df1c109e0e..d9a7977e43 100644 --- a/libraries/base/Unsafe/Coerce.hs +++ b/libraries/base/Unsafe/Coerce.hs @@ -32,6 +32,7 @@ module Unsafe.Coerce (unsafeCoerce) where import GHC.Integer () -- for build ordering +import GHC.Natural () -- for build ordering import GHC.Prim (unsafeCoerce#) local_id :: a -> a diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 1d439be322..dbeec3388d 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -219,6 +219,7 @@ Library GHC.Environment GHC.Err GHC.Exception + GHC.Exception.Type GHC.ExecutionStack GHC.ExecutionStack.Internal GHC.Exts @@ -258,6 +259,7 @@ Library GHC.IORef GHC.Int GHC.List + GHC.Maybe GHC.MVar GHC.Natural GHC.Num diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 95ece50bcc..eb517a9247 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -731,8 +731,8 @@ trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" nothingName, justName :: Name -nothingName = mkNameG DataName "base" "GHC.Base" "Nothing" -justName = mkNameG DataName "base" "GHC.Base" "Just" +nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing" +justName = mkNameG DataName "base" "GHC.Maybe" "Just" leftName, rightName :: Name leftName = mkNameG DataName "base" "Data.Either" "Left" diff --git a/testsuite/tests/ado/T13242a.stderr b/testsuite/tests/ado/T13242a.stderr index e03f471e8b..a8e6495ed2 100644 --- a/testsuite/tests/ado/T13242a.stderr +++ b/testsuite/tests/ado/T13242a.stderr @@ -28,8 +28,8 @@ T13242a.hs:13:11: error: instance Eq Ordering -- Defined in ‘GHC.Classes’ instance Eq Integer -- Defined in ‘integer-gmp-1.0.2.0:GHC.Integer.Type’ - instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Base’ - ...plus 22 others + instance Eq () -- Defined in ‘GHC.Classes’ + ...plus 21 others ...plus six instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In a stmt of a 'do' block: return (x == x) diff --git a/testsuite/tests/generics/GenDerivOutput.stderr b/testsuite/tests/generics/GenDerivOutput.stderr index d531e914f4..9c008e0038 100644 --- a/testsuite/tests/generics/GenDerivOutput.stderr +++ b/testsuite/tests/generics/GenDerivOutput.stderr @@ -116,7 +116,7 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "element") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -124,7 +124,7 @@ Derived type family instances: (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "rest") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -146,7 +146,7 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "element") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -154,7 +154,7 @@ Derived type family instances: GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "rest") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -180,14 +180,14 @@ Derived type family instances: 'GHC.Types.False) (GHC.Generics.S1 ('GHC.Generics.MetaSel - 'GHC.Base.Nothing + 'GHC.Maybe.Nothing 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - 'GHC.Base.Nothing + 'GHC.Maybe.Nothing 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -211,14 +211,14 @@ Derived type family instances: 'GHC.Types.False) (GHC.Generics.S1 ('GHC.Generics.MetaSel - 'GHC.Base.Nothing + 'GHC.Maybe.Nothing 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - 'GHC.Base.Nothing + 'GHC.Maybe.Nothing 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) diff --git a/testsuite/tests/generics/GenDerivOutput1_0.stderr b/testsuite/tests/generics/GenDerivOutput1_0.stderr index bf9cf1590c..6090499abf 100644 --- a/testsuite/tests/generics/GenDerivOutput1_0.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_0.stderr @@ -43,7 +43,7 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "element") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -51,7 +51,7 @@ Derived type family instances: GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "rest") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness diff --git a/testsuite/tests/generics/GenDerivOutput1_1.stderr b/testsuite/tests/generics/GenDerivOutput1_1.stderr index 5f4e7e241d..139d7ed255 100644 --- a/testsuite/tests/generics/GenDerivOutput1_1.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_1.stderr @@ -178,14 +178,14 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just "d11d") + ('GHC.Maybe.Just "d11d") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "d12d") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -206,14 +206,14 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just "d11d") + ('GHC.Maybe.Just "d11d") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "d12d") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -235,14 +235,14 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just "d11c") + ('GHC.Maybe.Just "d11c") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "d12c") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -264,14 +264,14 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just "d11b") + ('GHC.Maybe.Just "d11b") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "d12b") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -292,14 +292,14 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just "d11a") + ('GHC.Maybe.Just "d11a") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "d12a") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -321,14 +321,14 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just "d11a") + ('GHC.Maybe.Just "d11a") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "d12a") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -349,14 +349,14 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just "d11b") + ('GHC.Maybe.Just "d11b") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "d12b") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -378,14 +378,14 @@ Derived type family instances: 'GHC.Types.True) (GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just "d11c") + ('GHC.Maybe.Just "d11c") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 ('GHC.Generics.MetaSel - ('GHC.Base.Just + ('GHC.Maybe.Just "d12c") 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness diff --git a/testsuite/tests/generics/T10604/T10604_deriving.stderr b/testsuite/tests/generics/T10604/T10604_deriving.stderr index 20417e37a5..cb9ea36454 100644 --- a/testsuite/tests/generics/T10604/T10604_deriving.stderr +++ b/testsuite/tests/generics/T10604/T10604_deriving.stderr @@ -232,7 +232,7 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -251,7 +251,7 @@ Derived type family instances: (GHC.Generics.S1 (* -> *) ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -273,7 +273,7 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing + ('GHC.Maybe.Nothing GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -301,7 +301,7 @@ Derived type family instances: (GHC.Generics.S1 (k -> *) ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -333,7 +333,8 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing + GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -342,7 +343,8 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing + GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -359,7 +361,8 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing + GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -368,7 +371,8 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing + GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -395,7 +399,8 @@ Derived type family instances: (GHC.Generics.S1 k ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing + GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -404,7 +409,8 @@ Derived type family instances: (GHC.Generics.S1 k ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing + GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -421,7 +427,8 @@ Derived type family instances: (GHC.Generics.S1 k ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing + GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -430,7 +437,8 @@ Derived type family instances: (GHC.Generics.S1 k ('GHC.Generics.MetaSel - ('GHC.Base.Nothing GHC.Types.Symbol) + ('GHC.Maybe.Nothing + GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) @@ -454,7 +462,7 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing + ('GHC.Maybe.Nothing GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -469,7 +477,7 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing + ('GHC.Maybe.Nothing GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -494,7 +502,7 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing + ('GHC.Maybe.Nothing GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness @@ -509,7 +517,7 @@ Derived type family instances: (GHC.Generics.S1 * ('GHC.Generics.MetaSel - ('GHC.Base.Nothing + ('GHC.Maybe.Nothing GHC.Types.Symbol) 'GHC.Generics.NoSourceUnpackedness 'GHC.Generics.NoSourceStrictness diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index a9429d92a7..4622cb53e9 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -9,7 +9,7 @@ instance Show Integer -- Defined in ‘GHC.Show’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ ...plus 22 others - ...plus 17 instances involving out-of-scope types + ...plus 18 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In a stmt of an interactive GHCi command: print it @@ -23,6 +23,6 @@ instance Show Integer -- Defined in ‘GHC.Show’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ ...plus 22 others - ...plus 17 instances involving out-of-scope types + ...plus 18 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr index 70432f5558..5815080f6a 100644 --- a/testsuite/tests/ghci.debugger/scripts/print019.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr @@ -9,6 +9,6 @@ instance Show TyCon -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ ...plus 29 others - ...plus 18 instances involving out-of-scope types + ...plus 19 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/scripts/Defer02.stderr b/testsuite/tests/ghci/scripts/Defer02.stderr index 18c9cbb749..e76727efa5 100644 --- a/testsuite/tests/ghci/scripts/Defer02.stderr +++ b/testsuite/tests/ghci/scripts/Defer02.stderr @@ -79,6 +79,7 @@ Defer01.hs:43:10: warning: [-Wdeferred-type-errors (in -Wdefault)] instance Num Double -- Defined in ‘GHC.Float’ instance Num Float -- Defined in ‘GHC.Float’ ...plus two others + ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) • In the first argument of ‘myOp’, namely ‘23’ In the expression: myOp 23 diff --git a/testsuite/tests/ghci/scripts/T10963.stderr b/testsuite/tests/ghci/scripts/T10963.stderr index 3f90dd812f..de0b094ac4 100644 --- a/testsuite/tests/ghci/scripts/T10963.stderr +++ b/testsuite/tests/ghci/scripts/T10963.stderr @@ -8,5 +8,5 @@ instance Num Double -- Defined in ‘GHC.Float’ instance Num Float -- Defined in ‘GHC.Float’ ...plus two others - ...plus six instances involving out-of-scope types + ...plus 7 instances involving out-of-scope types (use -fprint-potential-instances to see them all) diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index c7421b58af..75d6c27506 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -29,13 +29,13 @@ instance Bounded () -- Defined in ‘GHC.Enum’ type instance D () () = Bool -- Defined at T4175.hs:22:10 type instance D Int () = String -- Defined at T4175.hs:19:10 data instance B () = MkB -- Defined at T4175.hs:13:15 -data Maybe a = Nothing | Just a -- Defined in ‘GHC.Base’ +data Maybe a = Nothing | Just a -- Defined in ‘GHC.Maybe’ instance Applicative Maybe -- Defined in ‘GHC.Base’ -instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Base’ +instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Maybe’ instance Functor Maybe -- Defined in ‘GHC.Base’ instance Monad Maybe -- Defined in ‘GHC.Base’ instance Semigroup a => Monoid (Maybe a) -- Defined in ‘GHC.Base’ -instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’ +instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Maybe’ instance Semigroup a => Semigroup (Maybe a) -- Defined in ‘GHC.Base’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ diff --git a/testsuite/tests/indexed-types/should_fail/T12522a.stderr b/testsuite/tests/indexed-types/should_fail/T12522a.stderr index 44e60d2194..d3e3b66d72 100644 --- a/testsuite/tests/indexed-types/should_fail/T12522a.stderr +++ b/testsuite/tests/indexed-types/should_fail/T12522a.stderr @@ -11,7 +11,7 @@ T12522a.hs:22:26: error: instance Show Integer -- Defined in ‘GHC.Show’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ ...plus 22 others - ...plus 11 instances involving out-of-scope types + ...plus 12 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the first argument of ‘(++)’, namely ‘show n’ In the second argument of ‘($)’, namely ‘show n ++ s’ diff --git a/testsuite/tests/numeric/should_compile/Makefile b/testsuite/tests/numeric/should_compile/Makefile index 34dbe5a51f..522e703b50 100644 --- a/testsuite/tests/numeric/should_compile/Makefile +++ b/testsuite/tests/numeric/should_compile/Makefile @@ -5,3 +5,11 @@ include $(TOP)/mk/test.mk T7116: $(RM) -f T7116.o T7116.hi '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -c -ddump-simpl -dsuppress-uniques T7116.hs + +T14170: + $(RM) -f T14170.o T14170.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -c -ddump-simpl -dsuppress-uniques T14170.hs + +T14465: + $(RM) -f T14465.o T14465.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -c -ddump-simpl -dsuppress-uniques T14465.hs diff --git a/testsuite/tests/numeric/should_compile/T14170.hs b/testsuite/tests/numeric/should_compile/T14170.hs new file mode 100644 index 0000000000..b7e854d805 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T14170.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +module NatVal where + +import Data.Proxy +import GHC.TypeLits + +-- test that Nat type literals are statically converted into Integer literals + +foo :: Integer +foo = natVal $ Proxy @0 diff --git a/testsuite/tests/numeric/should_compile/T14170.stdout b/testsuite/tests/numeric/should_compile/T14170.stdout new file mode 100644 index 0000000000..46a86214a5 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T14170.stdout @@ -0,0 +1,59 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 16, types: 6, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +NatVal.$trModule4 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +NatVal.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +NatVal.$trModule3 :: GHC.Types.TrName +[GblId, + Caf=NoCafRefs, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +NatVal.$trModule3 = GHC.Types.TrNameS NatVal.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +NatVal.$trModule2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +NatVal.$trModule2 = "NatVal"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +NatVal.$trModule1 :: GHC.Types.TrName +[GblId, + Caf=NoCafRefs, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +NatVal.$trModule1 = GHC.Types.TrNameS NatVal.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +NatVal.$trModule :: GHC.Types.Module +[GblId, + Caf=NoCafRefs, + Str=m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +NatVal.$trModule + = GHC.Types.Module NatVal.$trModule3 NatVal.$trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +foo :: Integer +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] +foo = 0 + + + diff --git a/testsuite/tests/numeric/should_compile/T14465.hs b/testsuite/tests/numeric/should_compile/T14465.hs new file mode 100644 index 0000000000..314aa89c56 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T14465.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +module M where + +import Numeric.Natural +import GHC.Natural + +-- test Natural literals +one :: Natural +one = fromInteger 1 + +plusOne :: Natural -> Natural +plusOne n = n + 1 + +-- a built-in rule should convert this unfolding into a Natural literal in Core +ten :: Natural +ten = wordToNatural 10 + +-- test basic constant folding for Natural +twoTimesTwo :: Natural +twoTimesTwo = 2 * 2 + +-- test the overflow warning +minusOne :: Natural +minusOne = -1 diff --git a/testsuite/tests/numeric/should_compile/T14465.stderr b/testsuite/tests/numeric/should_compile/T14465.stderr new file mode 100644 index 0000000000..c21e4a0269 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T14465.stderr @@ -0,0 +1,3 @@ + +T14465.hs:26:13: warning: [-Woverflowed-literals (in -Wdefault)] + Literal -1 is negative but Natural only supports positive numbers diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout new file mode 100644 index 0000000000..32cf35639c --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T14465.stdout @@ -0,0 +1,104 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 34, types: 14, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +ten :: Natural +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] +ten = 10 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +M.$trModule4 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +M.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +M.$trModule3 :: GHC.Types.TrName +[GblId, + Caf=NoCafRefs, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +M.$trModule3 = GHC.Types.TrNameS M.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +M.$trModule2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +M.$trModule2 = "M"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +M.$trModule1 :: GHC.Types.TrName +[GblId, + Caf=NoCafRefs, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +M.$trModule1 = GHC.Types.TrNameS M.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +M.$trModule :: GHC.Types.Module +[GblId, + Caf=NoCafRefs, + Str=m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +M.$trModule = GHC.Types.Module M.$trModule3 M.$trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +M.minusOne1 :: Natural +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] +M.minusOne1 = 1 + +-- RHS size: {terms: 6, types: 1, coercions: 0, joins: 0/0} +minusOne :: Natural +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 20}] +minusOne + = case GHC.Natural.$wnegateNatural M.minusOne1 of ww { __DEFAULT -> + GHC.Natural.NatS# ww + } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +twoTimesTwo :: Natural +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] +twoTimesTwo = 4 + +-- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0} +plusOne :: Natural -> Natural +[GblId, + Arity=1, + Caf=NoCafRefs, + Str=<S,U>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (n [Occ=Once] :: Natural) -> plusNatural n M.minusOne1}] +plusOne = \ (n :: Natural) -> plusNatural n M.minusOne1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +one :: Natural +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] +one = M.minusOne1 + + + diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T index e7bc4c64c4..5011627407 100644 --- a/testsuite/tests/numeric/should_compile/all.T +++ b/testsuite/tests/numeric/should_compile/all.T @@ -1,4 +1,6 @@ test('T7116', normal, run_command, ['$MAKE -s --no-print-directory T7116']) +test('T14170', normal, run_command, ['$MAKE -s --no-print-directory T14170']) +test('T14465', normal, run_command, ['$MAKE -s --no-print-directory T14465']) test('T7895', normal, compile, ['']) test('T7881', normal, compile, ['']) # For T8542, the hpc way adds extra annotations that prevent diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr index 5ece21fca5..c0d371f7bd 100644 --- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr +++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr @@ -8,7 +8,7 @@ overloadedlistsfail01.hs:5:8: error: instance Show Integer -- Defined in ‘GHC.Show’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ ...plus 22 others - ...plus 12 instances involving out-of-scope types + ...plus 13 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: print [1] In an equation for ‘main’: main = print [1] @@ -35,6 +35,7 @@ overloadedlistsfail01.hs:5:15: error: instance Num Double -- Defined in ‘GHC.Float’ instance Num Float -- Defined in ‘GHC.Float’ ...plus two others + ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: 1 In the first argument of ‘print’, namely ‘[1]’ diff --git a/testsuite/tests/partial-sigs/should_fail/T10999.stderr b/testsuite/tests/partial-sigs/should_fail/T10999.stderr index 88652a7831..5da96928c4 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10999.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10999.stderr @@ -25,7 +25,7 @@ T10999.hs:8:28: error: instance Ord Ordering -- Defined in ‘GHC.Classes’ instance Ord Integer -- Defined in ‘integer-gmp-1.0.1.0:GHC.Integer.Type’ - ...plus 23 others + ...plus 22 others ...plus three instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the second argument of ‘($)’, namely ‘f ()’ diff --git a/testsuite/tests/plugins/plugins09.stdout b/testsuite/tests/plugins/plugins09.stdout index efb740b9ab..5e212f3e2f 100644 --- a/testsuite/tests/plugins/plugins09.stdout +++ b/testsuite/tests/plugins/plugins09.stdout @@ -5,4 +5,5 @@ interfacePlugin: GHC.Base interfacePlugin: GHC.Types typeCheckPlugin (rn) typeCheckPlugin (tc) -interfacePlugin: GHC.Integer.Type
\ No newline at end of file +interfacePlugin: GHC.Integer.Type +interfacePlugin: GHC.Natural diff --git a/testsuite/tests/plugins/plugins11.stdout b/testsuite/tests/plugins/plugins11.stdout index 1e630427c1..ff31aa3c8c 100644 --- a/testsuite/tests/plugins/plugins11.stdout +++ b/testsuite/tests/plugins/plugins11.stdout @@ -5,4 +5,5 @@ interfacePlugin: GHC.Base interfacePlugin: GHC.Types typeCheckPlugin (rn) typeCheckPlugin (tc) -interfacePlugin: GHC.Integer.Type
\ No newline at end of file +interfacePlugin: GHC.Integer.Type +interfacePlugin: GHC.Natural diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 65dd9a1aa0..9d4869df3f 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -167,7 +167,7 @@ Roman.foo1 :: Maybe Int Str=m2, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] -Roman.foo1 = GHC.Base.Just @ Int Roman.foo2 +Roman.foo1 = GHC.Maybe.Just @ Int Roman.foo2 -- RHS size: {terms: 11, types: 4, coercions: 0, joins: 0/0} foo :: Int -> Int @@ -180,7 +180,7 @@ foo :: Int -> Int Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (n [Occ=Once!] :: Int) -> case n of n1 [Occ=Once] { GHC.Types.I# _ [Occ=Dead] -> - Roman.foo_go (GHC.Base.Just @ Int n1) Roman.foo1 + Roman.foo_go (GHC.Maybe.Just @ Int n1) Roman.foo1 }}] foo = \ (n :: Int) -> @@ -192,8 +192,8 @@ foo ------ Local rules for imported ids -------- "SC:$wgo0" [2] forall (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#). - Roman.$wgo (GHC.Base.Just @ Int (GHC.Types.I# sc1)) - (GHC.Base.Just @ Int (GHC.Types.I# sc)) + Roman.$wgo (GHC.Maybe.Just @ Int (GHC.Types.I# sc1)) + (GHC.Maybe.Just @ Int (GHC.Types.I# sc)) = Roman.foo_$s$wgo sc sc1 diff --git a/testsuite/tests/th/ClosedFam1TH.stderr b/testsuite/tests/th/ClosedFam1TH.stderr index 8855da204f..8db375413a 100644 --- a/testsuite/tests/th/ClosedFam1TH.stderr +++ b/testsuite/tests/th/ClosedFam1TH.stderr @@ -1,6 +1,6 @@ -ClosedFam1TH.hs:7:3: Warning: +ClosedFam1TH.hs:7:3: warning: type family Foo_0 a_1 (b_2 :: k_3) where Foo_0 GHC.Types.Int GHC.Types.Bool = GHC.Types.Int - Foo_0 a_4 GHC.Base.Maybe = GHC.Types.Bool + Foo_0 a_4 GHC.Maybe.Maybe = GHC.Types.Bool Foo_0 b_5 (x_6 :: GHC.Types.Bool) = GHC.Types.Char diff --git a/testsuite/tests/th/T14060.stdout b/testsuite/tests/th/T14060.stdout index c7668cfa3b..01857c3015 100644 --- a/testsuite/tests/th/T14060.stdout +++ b/testsuite/tests/th/T14060.stdout @@ -3,8 +3,8 @@ newtype Main.Foo1 ('(:) 'GHC.Types.True ('(:) 'GHC.Types.False ('[] :: [GHC.Types.Bool]))))) newtype Main.Foo2 (a_0 :: *) - = Main.Foo2 (Data.Proxy.Proxy (Main.Wurble (GHC.Base.Maybe a_0) - ('GHC.Base.Nothing :: GHC.Base.Maybe a_0))) + = Main.Foo2 (Data.Proxy.Proxy (Main.Wurble (GHC.Maybe.Maybe a_0) + ('GHC.Maybe.Nothing :: GHC.Maybe.Maybe a_0))) newtype Main.Foo3 = Main.Foo3 (Data.Proxy.Proxy (Main.Foo3Fam2 GHC.Types.Int :: *)) newtype Main.Foo4 diff --git a/testsuite/tests/th/T4135.stderr b/testsuite/tests/th/T4135.stderr index c666082754..3a4c6084d4 100644 --- a/testsuite/tests/th/T4135.stderr +++ b/testsuite/tests/th/T4135.stderr @@ -1,2 +1,2 @@ -instance Bug.C (GHC.Base.Maybe a_0) - where type Bug.T (GHC.Base.Maybe a_0) = GHC.Types.Char +instance Bug.C (GHC.Maybe.Maybe a_0) + where type Bug.T (GHC.Maybe.Maybe a_0) = GHC.Types.Char diff --git a/testsuite/tests/th/T5037.stderr b/testsuite/tests/th/T5037.stderr index 944cfa5c8c..67d7e2e7c6 100644 --- a/testsuite/tests/th/T5037.stderr +++ b/testsuite/tests/th/T5037.stderr @@ -1,3 +1,3 @@ -f_0 :: GHC.Base.Maybe GHC.Types.Int -> GHC.Types.Int -f_0 (GHC.Base.Nothing) = 3 -f_0 (GHC.Base.Just x_1) = x +f_0 :: GHC.Maybe.Maybe GHC.Types.Int -> GHC.Types.Int +f_0 (GHC.Maybe.Nothing) = 3 +f_0 (GHC.Maybe.Just x_1) = x diff --git a/testsuite/tests/th/T8953.stderr b/testsuite/tests/th/T8953.stderr index c724a8ea26..3dad41244b 100644 --- a/testsuite/tests/th/T8953.stderr +++ b/testsuite/tests/th/T8953.stderr @@ -1,6 +1,6 @@ type family T8953.Poly (a_0 :: k_1) :: * type instance T8953.Poly (x_2 :: GHC.Types.Bool) = GHC.Types.Int -type instance T8953.Poly (x_3 :: GHC.Base.Maybe k_4) = GHC.Types.Double +type instance T8953.Poly (x_3 :: GHC.Maybe.Maybe k_4) = GHC.Types.Double type family T8953.Silly :: k_0 -> * type instance T8953.Silly = (Data.Proxy.Proxy :: * -> *) type instance T8953.Silly = (Data.Proxy.Proxy :: (* -> *) -> *) diff --git a/testsuite/tests/th/TH_RichKinds2.stderr b/testsuite/tests/th/TH_RichKinds2.stderr index 8970da8bdb..a0b29a15e3 100644 --- a/testsuite/tests/th/TH_RichKinds2.stderr +++ b/testsuite/tests/th/TH_RichKinds2.stderr @@ -1,8 +1,8 @@ TH_RichKinds2.hs:25:4: warning: - data SMaybe_0 :: (k_0 -> *) -> GHC.Base.Maybe k_0 -> * where - SNothing_2 :: SMaybe_0 s_3 'GHC.Base.Nothing - SJust_4 :: (s_5 a_6) -> SMaybe_0 s_5 ('GHC.Base.Just a_6) + data SMaybe_0 :: (k_0 -> *) -> GHC.Maybe.Maybe k_0 -> * where + SNothing_2 :: SMaybe_0 s_3 'GHC.Maybe.Nothing + SJust_4 :: (s_5 a_6) -> SMaybe_0 s_5 ('GHC.Maybe.Just a_6) type instance TH_RichKinds2.Map f_7 '[] = '[] type instance TH_RichKinds2.Map f_8 ('(GHC.Types.:) h_9 t_10) = '(GHC.Types.:) (f_8 h_9) diff --git a/testsuite/tests/th/TH_reifyDecl2.stderr b/testsuite/tests/th/TH_reifyDecl2.stderr index 64436f811e..2e7650bc23 100644 --- a/testsuite/tests/th/TH_reifyDecl2.stderr +++ b/testsuite/tests/th/TH_reifyDecl2.stderr @@ -1,2 +1,2 @@ -data GHC.Base.Maybe (a_0 :: *) - = GHC.Base.Nothing | GHC.Base.Just a_0 +data GHC.Maybe.Maybe (a_0 :: *) + = GHC.Maybe.Nothing | GHC.Maybe.Just a_0 diff --git a/testsuite/tests/th/TH_repGuard.stderr b/testsuite/tests/th/TH_repGuard.stderr index bbef7eed59..ce93ab937d 100644 --- a/testsuite/tests/th/TH_repGuard.stderr +++ b/testsuite/tests/th/TH_repGuard.stderr @@ -1,7 +1,7 @@ foo_0 :: GHC.Types.Int -> GHC.Types.Int foo_0 x_1 | x_1 GHC.Classes.== 5 = 6 foo_0 x_2 = 7 -bar_0 :: GHC.Base.Maybe GHC.Types.Int -> GHC.Types.Int -bar_0 x_1 | GHC.Base.Just y_2 <- x_1 +bar_0 :: GHC.Maybe.Maybe GHC.Types.Int -> GHC.Types.Int +bar_0 x_1 | GHC.Maybe.Just y_2 <- x_1 = y_2 bar_0 _ = 9 diff --git a/testsuite/tests/typecheck/should_compile/T14273.stderr b/testsuite/tests/typecheck/should_compile/T14273.stderr index f307c77ded..ca739a3ac7 100644 --- a/testsuite/tests/typecheck/should_compile/T14273.stderr +++ b/testsuite/tests/typecheck/should_compile/T14273.stderr @@ -12,7 +12,7 @@ T14273.hs:7:27: warning: [-Wdeferred-type-errors (in -Wdefault)] instance Show Ordering -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ ...plus 23 others - ...plus 68 instances involving out-of-scope types + ...plus 69 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the first argument of ‘Just’, namely ‘(show _a)’ In the expression: Just (show _a) @@ -65,7 +65,7 @@ T14273.hs:13:10: warning: [-Wdeferred-type-errors (in -Wdefault)] instance Show Ordering -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ ...plus 23 others - ...plus 68 instances involving out-of-scope types + ...plus 69 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: show (_h ++ []) In an equation for ‘foo’: foo xs = show (_h ++ []) diff --git a/testsuite/tests/typecheck/should_compile/holes2.stderr b/testsuite/tests/typecheck/should_compile/holes2.stderr index 6421709f85..329e939c5d 100644 --- a/testsuite/tests/typecheck/should_compile/holes2.stderr +++ b/testsuite/tests/typecheck/should_compile/holes2.stderr @@ -9,7 +9,7 @@ holes2.hs:3:5: warning: [-Wdeferred-type-errors (in -Wdefault)] instance Show Ordering -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ ...plus 23 others - ...plus 68 instances involving out-of-scope types + ...plus 69 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: show _ In an equation for ‘f’: f = show _ diff --git a/testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr index 6ddc274e72..17c487ffee 100644 --- a/testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr +++ b/testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr @@ -78,7 +78,7 @@ valid_hole_fits.hs:27:5: warning: [-Wtyped-holes (in -Wdefault)] Just :: forall a. a -> Maybe a with Just @Integer (imported from ‘Data.Maybe’ at valid_hole_fits.hs:5:1-17 - (and originally defined in ‘GHC.Base’)) + (and originally defined in ‘GHC.Maybe’)) return :: forall (m :: * -> *) a. Monad m => a -> m a with return @Maybe @Integer (imported from ‘Prelude’ at valid_hole_fits.hs:3:1-40 @@ -98,7 +98,7 @@ valid_hole_fits.hs:30:5: warning: [-Wdeferred-type-errors (in -Wdefault)] instance Show Ordering -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ ...plus 23 others - ...plus 68 instances involving out-of-scope types + ...plus 69 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: show _ In an equation for ‘f’: f = show _ @@ -148,7 +148,7 @@ valid_hole_fits.hs:34:5: warning: [-Wdeferred-type-errors (in -Wdefault)] instance Show Ordering -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ ...plus 23 others - ...plus 68 instances involving out-of-scope types + ...plus 69 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: show (_ (_ :: Bool)) In an equation for ‘h’: h = show (_ (_ :: Bool)) @@ -172,7 +172,7 @@ valid_hole_fits.hs:34:11: warning: [-Wtyped-holes (in -Wdefault)] Just :: forall a. a -> Maybe a with Just @Bool (imported from ‘Data.Maybe’ at valid_hole_fits.hs:5:1-17 - (and originally defined in ‘GHC.Base’)) + (and originally defined in ‘GHC.Maybe’)) id :: forall a. a -> a with id @Bool (imported from ‘Prelude’ at valid_hole_fits.hs:3:1-40 diff --git a/testsuite/tests/typecheck/should_fail/T14884.stderr b/testsuite/tests/typecheck/should_fail/T14884.stderr index 8adae18262..89ddef9947 100644 --- a/testsuite/tests/typecheck/should_fail/T14884.stderr +++ b/testsuite/tests/typecheck/should_fail/T14884.stderr @@ -42,7 +42,7 @@ T14884.hs:4:7: error: instance Show Ordering -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ ...plus 23 others - ...plus 65 instances involving out-of-scope types + ...plus 66 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the first argument of ‘_’, namely ‘print’ In the expression: _ print "abc" diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr index accc6b69f3..ace7e916c8 100644 --- a/testsuite/tests/typecheck/should_fail/T5095.stderr +++ b/testsuite/tests/typecheck/should_fail/T5095.stderr @@ -7,7 +7,7 @@ T5095.hs:9:9: error: instance Eq Integer -- Defined in ‘integer-gmp-1.0.1.0:GHC.Integer.Type’ ...plus 23 others - ...plus six instances involving out-of-scope types + ...plus 7 instances involving out-of-scope types (use -fprint-potential-instances to see them all) (The choice depends on the instantiation of ‘a’ To pick the first instance above, use IncoherentInstances diff --git a/testsuite/tests/typecheck/should_fail/tcfail008.stderr b/testsuite/tests/typecheck/should_fail/tcfail008.stderr index d84c3b90e3..1e7bc19585 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail008.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail008.stderr @@ -1,21 +1,22 @@ tcfail008.hs:3:5: error: - Ambiguous type variable ‘a0’ arising from the literal ‘1’ - prevents the constraint ‘(Num a0)’ from being solved. - Relevant bindings include o :: [a0] (bound at tcfail008.hs:3:1) - Probable fix: use a type annotation to specify what ‘a0’ should be. - These potential instances exist: - instance Num Integer -- Defined in ‘GHC.Num’ - instance Num Double -- Defined in ‘GHC.Float’ - instance Num Float -- Defined in ‘GHC.Float’ - ...plus two others - (use -fprint-potential-instances to see them all) - In the first argument of ‘(:)’, namely ‘1’ - In the expression: 1 : 2 - In an equation for ‘o’: o = 1 : 2 + • Ambiguous type variable ‘a0’ arising from the literal ‘1’ + prevents the constraint ‘(Num a0)’ from being solved. + Relevant bindings include o :: [a0] (bound at tcfail008.hs:3:1) + Probable fix: use a type annotation to specify what ‘a0’ should be. + These potential instances exist: + instance Num Integer -- Defined in ‘GHC.Num’ + instance Num Double -- Defined in ‘GHC.Float’ + instance Num Float -- Defined in ‘GHC.Float’ + ...plus two others + ...plus one instance involving out-of-scope types + (use -fprint-potential-instances to see them all) + • In the first argument of ‘(:)’, namely ‘1’ + In the expression: 1 : 2 + In an equation for ‘o’: o = 1 : 2 tcfail008.hs:3:7: error: - No instance for (Num [a0]) arising from the literal ‘2’ - In the second argument of ‘(:)’, namely ‘2’ - In the expression: 1 : 2 - In an equation for ‘o’: o = 1 : 2 + • No instance for (Num [a0]) arising from the literal ‘2’ + • In the second argument of ‘(:)’, namely ‘2’ + In the expression: 1 : 2 + In an equation for ‘o’: o = 1 : 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr b/testsuite/tests/typecheck/should_fail/tcfail072.stderr index 89f1e8323c..c3fdb254d0 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail072.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr @@ -10,8 +10,8 @@ tcfail072.hs:23:13: error: instance Ord Ordering -- Defined in ‘GHC.Classes’ instance Ord Integer -- Defined in ‘integer-gmp-1.0.1.0:GHC.Integer.Type’ - instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’ - ...plus 22 others + instance Ord () -- Defined in ‘GHC.Classes’ + ...plus 21 others ...plus three instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: g A diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.stderr b/testsuite/tests/typecheck/should_fail/tcfail133.stderr index 80e5ea7e28..bbaf091226 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail133.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail133.stderr @@ -12,7 +12,7 @@ tcfail133.hs:68:7: error: instance (Number a, Digit b, Show a, Show b) => Show (a :@ b) -- Defined at tcfail133.hs:11:54 ...plus 25 others - ...plus 11 instances involving out-of-scope types + ...plus 12 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: show $ add (One :@ Zero) (One :@ One) In an equation for ‘foo’: diff --git a/testsuite/tests/typecheck/should_fail/tcfail182.stderr b/testsuite/tests/typecheck/should_fail/tcfail182.stderr index 8d621dab5f..35e2e2d2c9 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail182.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail182.stderr @@ -3,7 +3,8 @@ tcfail182.hs:9:3: error: • Couldn't match expected type ‘Prelude.Maybe a’ with actual type ‘Maybe a0’ NB: ‘Maybe’ is defined at tcfail182.hs:6:1-18 - ‘Prelude.Maybe’ is defined in ‘GHC.Base’ in package ‘base-4.12.0.0’ + ‘Prelude.Maybe’ + is defined in ‘GHC.Maybe’ in package ‘base-4.12.0.0’ • In the pattern: Foo In an equation for ‘f’: f Foo = 3 • Relevant bindings include |