[Git][ghc/ghc][wip/angerman/aarch64-ncg] 4 commits: [CmmSized Int] unpacked ints, part 2
Moritz Angermann
gitlab at gitlab.haskell.org
Fri Oct 23 14:06:56 UTC 2020
Moritz Angermann pushed to branch wip/angerman/aarch64-ncg at Glasgow Haskell Compiler / GHC
Commits:
872b3b35 by Moritz Angermann at 2020-10-23T10:44:32+08:00
[CmmSized Int] unpacked ints, part 2
- - - - -
39b8861c by Moritz Angermann at 2020-10-23T21:58:18+08:00
[CmmSized Int] unpacked ints, part 3
- - - - -
a6e59c84 by Moritz Angermann at 2020-10-23T21:58:51+08:00
[CmmSized Int] T8832 fix test stdout.
- - - - -
657c5e6a by Moritz Angermann at 2020-10-23T21:59:07+08:00
[Debug] Fix CmmFloat warnings.
- - - - -
14 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/CoreToByteCode.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Foreign/Decl.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToCmm/Utils.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/parser/should_run/BinaryLiterals2.hs
- testsuite/tests/simplCore/should_compile/T8832.stdout
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -291,8 +291,8 @@ section "Int8#"
primtype Int8#
-primop Int8Extend "extendInt8#" GenPrimOp Int8# -> Int#
-primop Int8Narrow "narrowInt8#" GenPrimOp Int# -> Int8#
+primop Int8ExtendOp "extendInt8#" GenPrimOp Int8# -> Int#
+primop Int8NarrowOp "narrowInt8#" GenPrimOp Int# -> Int8#
primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8#
@@ -373,8 +373,8 @@ section "Int16#"
primtype Int16#
-primop Int16Extend "extendInt16#" GenPrimOp Int16# -> Int#
-primop Int16Narrow "narrowInt16#" GenPrimOp Int# -> Int16#
+primop Int16ExtendOp "extendInt16#" GenPrimOp Int16# -> Int#
+primop Int16NarrowOp "narrowInt16#" GenPrimOp Int# -> Int16#
primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16#
@@ -412,8 +412,8 @@ section "Int32#"
{Operations on 32-bit integers.}
------------------------------------------------------------------------
-primop Int32Extend "extendInt32#" GenPrimOp Int32# -> Int#
-primop Int32Narrow "narrowInt32#" GenPrimOp Int# -> Int32#
+primop Int32ExtendOp "extendInt32#" GenPrimOp Int32# -> Int#
+primop Int32NarrowOp "narrowInt32#" GenPrimOp Int# -> Int32#
------------------------------------------------------------------------
section "Word16#"
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -457,6 +457,12 @@ assembleI platform i = case i of
literal (LitNumber nt i) = case nt of
LitNumInt -> int (fromIntegral i)
LitNumWord -> int (fromIntegral i)
+ LitNumInt8 -> int8 (fromIntegral i)
+ LitNumWord8 -> int8 (fromIntegral i)
+ LitNumInt16 -> int16 (fromIntegral i)
+ LitNumWord16 -> int16 (fromIntegral i)
+ LitNumInt32 -> int32 (fromIntegral i)
+ LitNumWord32 -> int32 (fromIntegral i)
LitNumInt64 -> int64 (fromIntegral i)
LitNumWord64 -> int64 (fromIntegral i)
LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"
@@ -471,6 +477,9 @@ assembleI platform i = case i of
float = words . mkLitF
double = words . mkLitD platform
int = words . mkLitI
+ int8 = words . mkLitI64 platform
+ int16 = words . mkLitI64 platform
+ int32 = words . mkLitI64 platform
int64 = words . mkLitI64 platform
words ws = lit (map BCONPtrWord ws)
word w = words [w]
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -193,6 +193,32 @@ primOpRules nm = \case
SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogical ]
-- coercions
+
+ Int8ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
+ matchPrimOpId Int8NarrowOp primop_id
+ return (Var (mkPrimOpId Narrow8IntOp) `App` e) ]
+ Int16ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
+ matchPrimOpId Int16NarrowOp primop_id
+ return (Var (mkPrimOpId Narrow16IntOp) `App` e) ]
+ Int32ExtendOp -> mkPrimOpRule nm 1 [ do [Var primop_id `App` e] <- getArgs
+ matchPrimOpId Int32NarrowOp primop_id
+ return (Var (mkPrimOpId Narrow32IntOp) `App` e) ]
+ Int8NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Int8NarrowOp
+ , narrowSubsumesAnd AndIOp Int8NarrowOp 8 ]
+ Int16NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Int8NarrowOp
+ , subsumedByPrimOp Int16NarrowOp
+ , narrowSubsumesAnd AndIOp Int16NarrowOp 16 ]
+ Int32NarrowOp -> mkPrimOpRule nm 1 [ subsumedByPrimOp Int8NarrowOp
+ , subsumedByPrimOp Int16NarrowOp
+ , subsumedByPrimOp Int32NarrowOp
+ , narrowSubsumesAnd AndIOp Int32NarrowOp 32 ]
+ -- Int64NarrowOp -> mkPrimOpRule nm 1 [ narrowSubsumesAnd AndIOp Int64NarrowOp 64 ]
+
+ -- Word8Narrow -> mkPrimOpRule nm 1 [ narrowSubsumesAnd AndOp Word8Narrow 8 ]
+ -- Word16Narrow -> mkPrimOpRule nm 1 [ narrowSubsumesAnd AndOp Word16Narrow 16 ]
+ -- Word32Narrow -> mkPrimOpRule nm 1 [ narrowSubsumesAnd AndOp Word32Narrow 32 ]
+ -- Word64Narrow -> mkPrimOpRule nm 1 [ narrowSubsumesAnd AndOp Word64Narrow 64 ]
+
WordToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform wordToIntLit
, inversePrimOp IntToWordOp ]
IntToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform intToWordLit
@@ -593,8 +619,14 @@ isMinBound :: Platform -> Literal -> Bool
isMinBound _ (LitChar c) = c == minBound
isMinBound platform (LitNumber nt i) = case nt of
LitNumInt -> i == platformMinInt platform
+ LitNumInt8 -> i == toInteger (minBound :: Int8)
+ LitNumInt16 -> i == toInteger (minBound :: Int16)
+ LitNumInt32 -> i == toInteger (minBound :: Int32)
LitNumInt64 -> i == toInteger (minBound :: Int64)
LitNumWord -> i == 0
+ LitNumWord8 -> i == 0
+ LitNumWord16 -> i == 0
+ LitNumWord32 -> i == 0
LitNumWord64 -> i == 0
LitNumNatural -> i == 0
LitNumInteger -> False
@@ -604,8 +636,14 @@ isMaxBound :: Platform -> Literal -> Bool
isMaxBound _ (LitChar c) = c == maxBound
isMaxBound platform (LitNumber nt i) = case nt of
LitNumInt -> i == platformMaxInt platform
+ LitNumInt8 -> i == toInteger (maxBound :: Int8)
+ LitNumInt16 -> i == toInteger (maxBound :: Int16)
+ LitNumInt32 -> i == toInteger (maxBound :: Int32)
LitNumInt64 -> i == toInteger (maxBound :: Int64)
LitNumWord -> i == platformMaxWord platform
+ LitNumWord8 -> i == toInteger (maxBound :: Word8)
+ LitNumWord16 -> i == toInteger (maxBound :: Word16)
+ LitNumWord32 -> i == toInteger (maxBound :: Word32)
LitNumWord64 -> i == toInteger (maxBound :: Word64)
LitNumNatural -> False
LitNumInteger -> False
=====================================
compiler/GHC/CoreToByteCode.hs
=====================================
@@ -1383,6 +1383,12 @@ primRepToFFIType platform r
VoidRep -> FFIVoid
IntRep -> signed_word
WordRep -> unsigned_word
+ Int8Rep -> FFISInt8
+ Word8Rep -> FFIUInt8
+ Int16Rep -> FFISInt16
+ Word16Rep -> FFIUInt16
+ Int32Rep -> FFISInt32
+ Word32Rep -> FFIUInt32
Int64Rep -> FFISInt64
Word64Rep -> FFIUInt64
AddrRep -> FFIPointer
@@ -1401,6 +1407,12 @@ mkDummyLiteral platform pr
= case pr of
IntRep -> mkLitInt platform 0
WordRep -> mkLitWord platform 0
+ Int8Rep -> mkLitInt8 0
+ Word8Rep -> mkLitWord8 0
+ Int16Rep -> mkLitInt16 0
+ Word16Rep -> mkLitWord16 0
+ Int32Rep -> mkLitInt32 0
+ Word32Rep -> mkLitWord32 0
Int64Rep -> mkLitInt64 0
Word64Rep -> mkLitWord64 0
AddrRep -> LitNullAddr
@@ -1633,6 +1645,12 @@ pushAtom _ _ (AnnLit lit) = do
LitNumber nt _ -> case nt of
LitNumInt -> code N
LitNumWord -> code N
+ LitNumInt8 -> code (toArgRep Int8Rep)
+ LitNumWord8 -> code (toArgRep Word8Rep)
+ LitNumInt16 -> code (toArgRep Int16Rep)
+ LitNumWord16 -> code (toArgRep Word16Rep)
+ LitNumInt32 -> code (toArgRep Int32Rep)
+ LitNumWord32 -> code (toArgRep Word32Rep)
LitNumInt64 -> code L
LitNumWord64 -> code L
-- No LitInteger's or LitNatural's should be left by the time this is
=====================================
compiler/GHC/HsToCore/Foreign/Call.hs
=====================================
@@ -21,9 +21,7 @@ where
#include "HsVersions.h"
-
import GHC.Prelude
-import GHC.Platform
import GHC.Core
@@ -40,7 +38,6 @@ import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Types.Id ( Id )
import GHC.Core.Coercion
-import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim
import GHC.Core.TyCon
import GHC.Builtin.Types
@@ -354,36 +351,13 @@ resultWrapper result_ty
| Just (tycon, tycon_arg_tys) <- maybe_tc_app
, Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials
, [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument
- = do { dflags <- getDynFlags
- ; let platform = targetPlatform dflags
- ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
- ; let narrow_wrapper = maybeNarrow platform tycon
- marshal_con e = Var (dataConWrapId data_con)
+ = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
+ ; let marshal_con e = Var (dataConWrapId data_con)
`mkTyApps` tycon_arg_tys
- `App` wrapper (narrow_wrapper e)
+ `App` wrapper e
; return (maybe_ty, marshal_con) }
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
where
maybe_tc_app = splitTyConApp_maybe result_ty
-
--- When the result of a foreign call is smaller than the word size, we
--- need to sign- or zero-extend the result up to the word size. The C
--- standard appears to say that this is the responsibility of the
--- caller, not the callee.
-
-maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr)
-maybeNarrow platform tycon
- | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
- | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
- | tycon `hasKey` int32TyConKey
- , platformWordSizeInBytes platform > 4
- = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
-
- | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
- | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
- | tycon `hasKey` word32TyConKey
- , platformWordSizeInBytes platform > 4
- = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
- | otherwise = id
=====================================
compiler/GHC/HsToCore/Foreign/Decl.hs
=====================================
@@ -838,6 +838,10 @@ primTyDescChar platform ty
= case typePrimRep1 (getPrimTyOf ty) of
IntRep -> signed_word
WordRep -> unsigned_word
+ Int8Rep -> 'B'
+ Word8Rep -> 'b'
+ Int16Rep -> 'S'
+ Word16Rep -> 's'
Int32Rep -> 'W'
Word32Rep -> 'w'
Int64Rep -> 'L'
=====================================
compiler/GHC/Runtime/Heap/Inspect.hs
=====================================
@@ -467,6 +467,10 @@ repPrim t = rep where
| t == wordPrimTyCon = text $ show (build x :: Word)
| t == floatPrimTyCon = text $ show (build x :: Float)
| t == doublePrimTyCon = text $ show (build x :: Double)
+ | t == int8PrimTyCon = text $ show (build x :: Int8)
+ | t == word8PrimTyCon = text $ show (build x :: Word8)
+ | t == int16PrimTyCon = text $ show (build x :: Int16)
+ | t == word16PrimTyCon = text $ show (build x :: Word16)
| t == int32PrimTyCon = text $ show (build x :: Int32)
| t == word32PrimTyCon = text $ show (build x :: Word32)
| t == int64PrimTyCon = text $ show (build x :: Int64)
=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -112,6 +112,8 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
(CmmLit _, AddrHint) -> pure ()
(CmmReg _, AddrHint) -> pure ()
(CmmRegOff _ _, AddrHint) -> pure ()
+ (CmmLit (CmmFloat _ w), SignedHint w') | w == w' -> pure ()
+ (CmmLit (CmmFloat _ w), NoHint w') | w == w' -> pure ()
(CmmLit (CmmInt _ w), SignedHint w') | w == w' -> pure ()
(CmmLit (CmmInt _ w), NoHint w') | w == w' -> pure ()
(CmmReg (CmmLocal (LocalReg _ ty)), _) | isFloatType ty -> pure ()
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1172,8 +1172,8 @@ emitPrimOp dflags primop = case primop of
-- Int8# signed ops
- Int8Extend -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform))
- Int8Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8)
+ Int8ExtendOp -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform))
+ Int8NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8)
Int8NegOp -> \args -> opTranslate args (MO_S_Neg W8)
Int8AddOp -> \args -> opTranslate args (MO_Add W8)
Int8SubOp -> \args -> opTranslate args (MO_Sub W8)
@@ -1208,8 +1208,8 @@ emitPrimOp dflags primop = case primop of
-- Int16# signed ops
- Int16Extend -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform))
- Int16Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16)
+ Int16ExtendOp -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform))
+ Int16NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16)
Int16NegOp -> \args -> opTranslate args (MO_S_Neg W16)
Int16AddOp -> \args -> opTranslate args (MO_Add W16)
Int16SubOp -> \args -> opTranslate args (MO_Sub W16)
@@ -1226,8 +1226,8 @@ emitPrimOp dflags primop = case primop of
-- Int32# signed ops
- Int32Extend -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform))
- Int32Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32)
+ Int32ExtendOp -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform))
+ Int32NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32)
-- Word16# unsigned ops
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -106,8 +106,14 @@ mkSimpleLit platform = \case
(wordWidth platform)
LitNullAddr -> zeroCLit platform
(LitNumber LitNumInt i) -> CmmInt i (wordWidth platform)
+ (LitNumber LitNumInt8 i) -> CmmInt i W8
+ (LitNumber LitNumInt16 i) -> CmmInt i W16
+ (LitNumber LitNumInt32 i) -> CmmInt i W32
(LitNumber LitNumInt64 i) -> CmmInt i W64
(LitNumber LitNumWord i) -> CmmInt i (wordWidth platform)
+ (LitNumber LitNumWord8 i) -> CmmInt i W8
+ (LitNumber LitNumWord16 i) -> CmmInt i W16
+ (LitNumber LitNumWord32 i) -> CmmInt i W32
(LitNumber LitNumWord64 i) -> CmmInt i W64
(LitFloat r) -> CmmFloat r W32
(LitDouble r) -> CmmFloat r W64
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -17,6 +17,12 @@ module GHC.Types.Literal
-- ** Creating Literals
, mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked
, mkLitWord, mkLitWordWrap, mkLitWordWrapC
+ , mkLitInt8, mkLitInt8Wrap
+ , mkLitWord8, mkLitWord8Wrap
+ , mkLitInt16, mkLitInt16Wrap
+ , mkLitWord16, mkLitWord16Wrap
+ , mkLitInt32, mkLitInt32Wrap
+ , mkLitWord32, mkLitWord32Wrap
, mkLitInt64, mkLitInt64Wrap
, mkLitWord64, mkLitWord64Wrap
, mkLitFloat, mkLitDouble
@@ -43,6 +49,8 @@ module GHC.Types.Literal
, narrowLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
+ , int8Lit, int16Lit, int32Lit
+ , word8Lit, word16Lit, word32Lit
, charToIntLit, intToCharLit
, floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit
, nullAddrLit, rubbishLit, floatToDoubleLit, doubleToFloatLit
@@ -153,8 +161,14 @@ data LitNumType
= LitNumInteger -- ^ @Integer@ (see Note [BigNum literals])
| LitNumNatural -- ^ @Natural@ (see Note [BigNum literals])
| LitNumInt -- ^ @Int#@ - according to target machine
+ | LitNumInt8 -- ^ @Int8#@ - exactly 8 bits
+ | LitNumInt16 -- ^ @Int16#@ - exactly 16 bits
+ | LitNumInt32 -- ^ @Int32#@ - exactly 32 bits
| LitNumInt64 -- ^ @Int64#@ - exactly 64 bits
| LitNumWord -- ^ @Word#@ - according to target machine
+ | LitNumWord8 -- ^ @Word8#@ - exactly 8 bits
+ | LitNumWord16 -- ^ @Word16#@ - exactly 16 bits
+ | LitNumWord32 -- ^ @Word32#@ - exactly 32 bits
| LitNumWord64 -- ^ @Word64#@ - exactly 64 bits
deriving (Data,Enum,Eq,Ord)
@@ -164,8 +178,14 @@ litNumIsSigned nt = case nt of
LitNumInteger -> True
LitNumNatural -> False
LitNumInt -> True
+ LitNumInt8 -> True
+ LitNumInt16 -> True
+ LitNumInt32 -> True
LitNumInt64 -> True
LitNumWord -> False
+ LitNumWord8 -> False
+ LitNumWord16 -> False
+ LitNumWord32 -> False
LitNumWord64 -> False
{-
@@ -293,6 +313,12 @@ wrapLitNumber platform v@(LitNumber nt i) = case nt of
LitNumWord -> case platformWordSize platform of
PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32))
PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64))
+ LitNumInt8 -> LitNumber nt (toInteger (fromIntegral i :: Int8))
+ LitNumWord8 -> LitNumber nt (toInteger (fromIntegral i :: Word8))
+ LitNumInt16 -> LitNumber nt (toInteger (fromIntegral i :: Int16))
+ LitNumWord16 -> LitNumber nt (toInteger (fromIntegral i :: Word16))
+ LitNumInt32 -> LitNumber nt (toInteger (fromIntegral i :: Int32))
+ LitNumWord32 -> LitNumber nt (toInteger (fromIntegral i :: Word32))
LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64))
LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64))
LitNumInteger -> v
@@ -308,7 +334,13 @@ litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool
litNumCheckRange platform nt i = case nt of
LitNumInt -> platformInIntRange platform i
LitNumWord -> platformInWordRange platform i
+ LitNumInt8 -> inInt8Range i
+ LitNumInt16 -> inInt16Range i
+ LitNumInt32 -> inInt32Range i
LitNumInt64 -> inInt64Range i
+ LitNumWord8 -> inWord8Range i
+ LitNumWord16 -> inWord16Range i
+ LitNumWord32 -> inWord32Range i
LitNumWord64 -> inWord64Range i
LitNumNatural -> i >= 0
LitNumInteger -> True
@@ -367,6 +399,84 @@ mkLitWordWrapC platform i = (n, i /= i')
where
n@(LitNumber _ i') = mkLitWordWrap platform i
+-- | Creates a 'Literal' of type @Int8#@
+mkLitInt8 :: Integer -> Literal
+mkLitInt8 x = ASSERT2( inInt8Range x, integer x ) (mkLitInt8Unchecked x)
+
+-- | Creates a 'Literal' of type @Int8#@.
+-- If the argument is out of the range, it is wrapped.
+mkLitInt8Wrap :: Platform -> Integer -> Literal
+mkLitInt8Wrap platform i = wrapLitNumber platform $ mkLitInt8Unchecked i
+
+-- | Creates a 'Literal' of type @Int8#@ without checking its range.
+mkLitInt8Unchecked :: Integer -> Literal
+mkLitInt8Unchecked i = LitNumber LitNumInt8 i
+
+-- | Creates a 'Literal' of type @Word8#@
+mkLitWord8 :: Integer -> Literal
+mkLitWord8 x = ASSERT2( inWord8Range x, integer x ) (mkLitWord8Unchecked x)
+
+-- | Creates a 'Literal' of type @Word8#@.
+-- If the argument is out of the range, it is wrapped.
+mkLitWord8Wrap :: Platform -> Integer -> Literal
+mkLitWord8Wrap platform i = wrapLitNumber platform $ mkLitWord8Unchecked i
+
+-- | Creates a 'Literal' of type @Word8#@ without checking its range.
+mkLitWord8Unchecked :: Integer -> Literal
+mkLitWord8Unchecked i = LitNumber LitNumWord8 i
+
+-- | Creates a 'Literal' of type @Int16#@
+mkLitInt16 :: Integer -> Literal
+mkLitInt16 x = ASSERT2( inInt16Range x, integer x ) (mkLitInt16Unchecked x)
+
+-- | Creates a 'Literal' of type @Int16#@.
+-- If the argument is out of the range, it is wrapped.
+mkLitInt16Wrap :: Platform -> Integer -> Literal
+mkLitInt16Wrap platform i = wrapLitNumber platform $ mkLitInt16Unchecked i
+
+-- | Creates a 'Literal' of type @Int16#@ without checking its range.
+mkLitInt16Unchecked :: Integer -> Literal
+mkLitInt16Unchecked i = LitNumber LitNumInt16 i
+
+-- | Creates a 'Literal' of type @Word16#@
+mkLitWord16 :: Integer -> Literal
+mkLitWord16 x = ASSERT2( inWord16Range x, integer x ) (mkLitWord16Unchecked x)
+
+-- | Creates a 'Literal' of type @Word16#@.
+-- If the argument is out of the range, it is wrapped.
+mkLitWord16Wrap :: Platform -> Integer -> Literal
+mkLitWord16Wrap platform i = wrapLitNumber platform $ mkLitWord16Unchecked i
+
+-- | Creates a 'Literal' of type @Word16#@ without checking its range.
+mkLitWord16Unchecked :: Integer -> Literal
+mkLitWord16Unchecked i = LitNumber LitNumWord16 i
+
+-- | Creates a 'Literal' of type @Int32#@
+mkLitInt32 :: Integer -> Literal
+mkLitInt32 x = ASSERT2( inInt32Range x, integer x ) (mkLitInt32Unchecked x)
+
+-- | Creates a 'Literal' of type @Int32#@.
+-- If the argument is out of the range, it is wrapped.
+mkLitInt32Wrap :: Platform -> Integer -> Literal
+mkLitInt32Wrap platform i = wrapLitNumber platform $ mkLitInt32Unchecked i
+
+-- | Creates a 'Literal' of type @Int32#@ without checking its range.
+mkLitInt32Unchecked :: Integer -> Literal
+mkLitInt32Unchecked i = LitNumber LitNumInt32 i
+
+-- | Creates a 'Literal' of type @Word32#@
+mkLitWord32 :: Integer -> Literal
+mkLitWord32 x = ASSERT2( inWord32Range x, integer x ) (mkLitWord32Unchecked x)
+
+-- | Creates a 'Literal' of type @Word32#@.
+-- If the argument is out of the range, it is wrapped.
+mkLitWord32Wrap :: Platform -> Integer -> Literal
+mkLitWord32Wrap platform i = wrapLitNumber platform $ mkLitWord32Unchecked i
+
+-- | Creates a 'Literal' of type @Word32#@ without checking its range.
+mkLitWord32Unchecked :: Integer -> Literal
+mkLitWord32Unchecked i = LitNumber LitNumWord32 i
+
-- | Creates a 'Literal' of type @Int64#@
mkLitInt64 :: Integer -> Literal
mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)
@@ -421,7 +531,20 @@ mkLitNatural x = ASSERT2( inNaturalRange x, integer x )
inNaturalRange :: Integer -> Bool
inNaturalRange x = x >= 0
-inInt64Range, inWord64Range :: Integer -> Bool
+inInt8Range, inWord8Range, inInt16Range, inWord16Range :: Integer -> Bool
+inInt32Range, inWord32Range, inInt64Range, inWord64Range :: Integer -> Bool
+inInt8Range x = x >= toInteger (minBound :: Int8) &&
+ x <= toInteger (maxBound :: Int8)
+inWord8Range x = x >= toInteger (minBound :: Word8) &&
+ x <= toInteger (maxBound :: Word8)
+inInt16Range x = x >= toInteger (minBound :: Int16) &&
+ x <= toInteger (maxBound :: Int16)
+inWord16Range x = x >= toInteger (minBound :: Word16) &&
+ x <= toInteger (maxBound :: Word16)
+inInt32Range x = x >= toInteger (minBound :: Int32) &&
+ x <= toInteger (maxBound :: Int32)
+inWord32Range x = x >= toInteger (minBound :: Word32) &&
+ x <= toInteger (maxBound :: Word32)
inInt64Range x = x >= toInteger (minBound :: Int64) &&
x <= toInteger (maxBound :: Int64)
inWord64Range x = x >= toInteger (minBound :: Word64) &&
@@ -474,6 +597,8 @@ isLitValue = isJust . isLitValue_maybe
narrow8IntLit, narrow16IntLit, narrow32IntLit,
narrow8WordLit, narrow16WordLit, narrow32WordLit,
+ int8Lit, int16Lit, int32Lit,
+ word8Lit, word16Lit, word32Lit,
charToIntLit, intToCharLit,
floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit,
floatToDoubleLit, doubleToFloatLit
@@ -508,6 +633,19 @@ narrow8WordLit = narrowLit (Proxy :: Proxy Word8)
narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
narrow32WordLit = narrowLit (Proxy :: Proxy Word32)
+int8Lit (LitNumber _ i) = mkLitInt8 i
+int8Lit l = pprPanic "int8Lit" (ppr l)
+int16Lit (LitNumber _ i) = mkLitInt16 i
+int16Lit l = pprPanic "int16Lit" (ppr l)
+int32Lit (LitNumber _ i) = mkLitInt32 i
+int32Lit l = pprPanic "int32Lit" (ppr l)
+word8Lit (LitNumber _ i) = mkLitWord8 i
+word8Lit l = pprPanic "word8Lit" (ppr l)
+word16Lit (LitNumber _ i) = mkLitWord16 i
+word16Lit l = pprPanic "word16Lit" (ppr l)
+word32Lit (LitNumber _ i) = mkLitWord32 i
+word32Lit l = pprPanic "word32Lit" (ppr l)
+
charToIntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c))
charToIntLit l = pprPanic "charToIntLit" (ppr l)
intToCharLit (LitNumber _ i) = LitChar (chr (fromInteger i))
@@ -580,8 +718,14 @@ litIsTrivial (LitNumber nt _) = case nt of
LitNumInteger -> False
LitNumNatural -> False
LitNumInt -> True
+ LitNumInt8 -> True
+ LitNumInt16 -> True
+ LitNumInt32 -> True
LitNumInt64 -> True
LitNumWord -> True
+ LitNumWord8 -> True
+ LitNumWord16 -> True
+ LitNumWord32 -> True
LitNumWord64 -> True
litIsTrivial _ = True
@@ -593,8 +737,14 @@ litIsDupable platform x = case x of
LitNumInteger -> platformInIntRange platform i
LitNumNatural -> platformInWordRange platform i
LitNumInt -> True
+ LitNumInt8 -> True
+ LitNumInt16 -> True
+ LitNumInt32 -> True
LitNumInt64 -> True
LitNumWord -> True
+ LitNumWord8 -> True
+ LitNumWord16 -> True
+ LitNumWord32 -> True
LitNumWord64 -> True
(LitString _) -> False
_ -> True
@@ -609,8 +759,14 @@ litIsLifted (LitNumber nt _) = case nt of
LitNumInteger -> True
LitNumNatural -> True
LitNumInt -> False
+ LitNumInt8 -> False
+ LitNumInt16 -> False
+ LitNumInt32 -> False
LitNumInt64 -> False
LitNumWord -> False
+ LitNumWord8 -> False
+ LitNumWord16 -> False
+ LitNumWord32 -> False
LitNumWord64 -> False
litIsLifted _ = False
@@ -631,8 +787,14 @@ literalType (LitNumber lt _) = case lt of
LitNumInteger -> integerTy
LitNumNatural -> naturalTy
LitNumInt -> intPrimTy
+ LitNumInt8 -> int8PrimTy
+ LitNumInt16 -> int16PrimTy
+ LitNumInt32 -> int32PrimTy
LitNumInt64 -> int64PrimTy
LitNumWord -> wordPrimTy
+ LitNumWord8 -> word8PrimTy
+ LitNumWord16 -> word16PrimTy
+ LitNumWord32 -> word32PrimTy
LitNumWord64 -> word64PrimTy
literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a)
where
@@ -707,8 +869,14 @@ pprLiteral add_par (LitNumber nt i)
LitNumInteger -> pprIntegerVal add_par i
LitNumNatural -> pprIntegerVal add_par i
LitNumInt -> pprPrimInt i
+ LitNumInt8 -> pprPrimInt8 i
+ LitNumInt16 -> pprPrimInt16 i
+ LitNumInt32 -> pprPrimInt32 i
LitNumInt64 -> pprPrimInt64 i
LitNumWord -> pprPrimWord i
+ LitNumWord8 -> pprPrimWord8 i
+ LitNumWord16 -> pprPrimWord16 i
+ LitNumWord32 -> pprPrimWord32 i
LitNumWord64 -> pprPrimWord64 i
pprLiteral add_par (LitLabel l mb fod) =
add_par (text "__label" <+> b <+> ppr fod)
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -59,7 +59,9 @@ module GHC.Utils.Outputable (
primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix,
primInt64Suffix, primWord64Suffix, primIntSuffix,
- pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,
+ pprPrimChar, pprPrimInt, pprPrimWord,
+ pprPrimInt8, pprPrimInt16, pprPrimInt32, pprPrimInt64,
+ pprPrimWord8, pprPrimWord16, pprPrimWord32, pprPrimWord64,
pprFastFilePath, pprFilePathString,
@@ -1018,22 +1020,40 @@ pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
-- Postfix modifiers for unboxed literals.
-- See Note [Printing of literals in Core] in "GHC.Types.Literal".
primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc
-primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc
+primDoubleSuffix, primWordSuffix :: SDoc
+primInt8Suffix, primWord8Suffix :: SDoc
+primInt16Suffix, primWord16Suffix :: SDoc
+primInt32Suffix, primWord32Suffix :: SDoc
+primInt64Suffix, primWord64Suffix :: SDoc
primCharSuffix = char '#'
primFloatSuffix = char '#'
primIntSuffix = char '#'
primDoubleSuffix = text "##"
primWordSuffix = text "##"
-primInt64Suffix = text "L#"
-primWord64Suffix = text "L##"
+primInt8Suffix = text "#8"
+primWord8Suffix = text "##8"
+primInt16Suffix = text "#16"
+primWord16Suffix = text "##16"
+primInt32Suffix = text "#32"
+primWord32Suffix = text "##32"
+primInt64Suffix = text "#64"
+primWord64Suffix = text "##64"
-- | Special combinator for showing unboxed literals.
pprPrimChar :: Char -> SDoc
-pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc
+pprPrimInt, pprPrimWord :: Integer -> SDoc
+pprPrimInt8, pprPrimInt16, pprPrimInt32, pprPrimInt64 :: Integer -> SDoc
+pprPrimWord8, pprPrimWord16, pprPrimWord32, pprPrimWord64 :: Integer -> SDoc
pprPrimChar c = pprHsChar c <> primCharSuffix
pprPrimInt i = integer i <> primIntSuffix
pprPrimWord w = word w <> primWordSuffix
+pprPrimInt8 i = integer i <> primInt8Suffix
+pprPrimInt16 i = integer i <> primInt16Suffix
+pprPrimInt32 i = integer i <> primInt32Suffix
pprPrimInt64 i = integer i <> primInt64Suffix
+pprPrimWord8 w = word w <> primWord8Suffix
+pprPrimWord16 w = word w <> primWord16Suffix
+pprPrimWord32 w = word w <> primWord32Suffix
pprPrimWord64 w = word w <> primWord64Suffix
---------------------
=====================================
testsuite/tests/parser/should_run/BinaryLiterals2.hs
=====================================
@@ -6,6 +6,7 @@
module Main where
+import GHC.Base
import GHC.Types
import GHC.Int
@@ -26,4 +27,4 @@ main = do
, -0B11111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111
]
- print [ I8# -0B10000000#, I8# 0B1111111# ]
+ print [ I8# (narrowInt8# -0B10000000#), I8# (narrowInt8# 0B1111111#) ]
=====================================
testsuite/tests/simplCore/should_compile/T8832.stdout
=====================================
@@ -1,7 +1,7 @@
i = GHC.Types.I# 0#
-i8 = GHC.Int.I8# 0#
-i16 = GHC.Int.I16# 0#
-i32 = GHC.Int.I32# 0#
+i8 = GHC.Int.I8# (GHC.Prim.narrowInt8# 0#)
+i16 = GHC.Int.I16# (GHC.Prim.narrowInt16# 0#)
+i32 = GHC.Int.I32# (GHC.Prim.narrowInt32# 0#)
i64 = GHC.Int.I64# 0#
w = GHC.Types.W# 0##
w8 = GHC.Word.W8# 0##
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0506dc0ffd0b70af352b76625d7b4be5d7505992...657c5e6a78d0068d62e702edc02c2eec03528d71
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0506dc0ffd0b70af352b76625d7b4be5d7505992...657c5e6a78d0068d62e702edc02c2eec03528d71
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201023/e763b1aa/attachment-0001.html>
More information about the ghc-commits
mailing list