summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Builtin/Names.hs5
-rw-r--r--compiler/GHC/Builtin/Types.hs8
-rw-r--r--compiler/GHC/Builtin/primops.txt.pp36
-rw-r--r--compiler/GHC/ByteCode/Asm.hs9
-rw-r--r--compiler/GHC/Cmm.hs6
-rw-r--r--compiler/GHC/Cmm/Expr.hs11
-rw-r--r--compiler/GHC/CmmToAsm/Ppr.hs14
-rw-r--r--compiler/GHC/CmmToC.hs193
-rw-r--r--compiler/GHC/Core.hs4
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs59
-rw-r--r--compiler/GHC/CoreToByteCode.hs57
-rw-r--r--compiler/GHC/HsToCore/Foreign/Call.hs32
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs6
-rw-r--r--compiler/GHC/HsToCore/Quote.hs5
-rw-r--r--compiler/GHC/Runtime/Heap/Inspect.hs4
-rw-r--r--compiler/GHC/StgToCmm/DataCon.hs17
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs26
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs6
-rw-r--r--compiler/GHC/Types/Literal.hs211
-rw-r--r--compiler/GHC/Utils/Outputable.hs30
20 files changed, 540 insertions, 199 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 881753f6f2..cf0f72c50f 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -336,7 +336,7 @@ basicKnownKeyNames
-- FFI primitive types that are not wired-in.
stablePtrTyConName, ptrTyConName, funPtrTyConName,
int8TyConName, int16TyConName, int32TyConName, int64TyConName,
- word16TyConName, word32TyConName, word64TyConName,
+ word8TyConName, word16TyConName, word32TyConName, word64TyConName,
-- Others
otherwiseIdName, inlineIdName,
@@ -1463,7 +1463,8 @@ int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey
int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey
-- Word module
-word16TyConName, word32TyConName, word64TyConName :: Name
+word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name
+word8TyConName = tcQual gHC_WORD (fsLit "Word8") word8TyConKey
word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey
word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey
word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 52febf72d2..d06bc4a12b 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -55,7 +55,7 @@ module GHC.Builtin.Types (
wordTyCon, wordDataCon, wordTyConName, wordTy,
-- * Word8
- word8TyCon, word8DataCon, word8TyConName, word8Ty,
+ word8TyCon, word8DataCon, word8Ty,
-- * List
listTyCon, listTyCon_RDR, listTyConName, listTyConKey,
@@ -251,7 +251,6 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they
, floatTyCon
, intTyCon
, wordTyCon
- , word8TyCon
, listTyCon
, orderingTyCon
, maybeTyCon
@@ -354,10 +353,9 @@ nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")
justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")
justDataConKey justDataCon
-wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name
+wordTyConName, wordDataConName, word8DataConName :: Name
wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon
wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon
-word8TyConName = mkWiredInTyConName UserSyntax gHC_WORD (fsLit "Word8") word8TyConKey word8TyCon
word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon
floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name
@@ -1641,7 +1639,7 @@ word8TyCon = pcTyCon word8TyConName
(NoSourceText, fsLit "HsWord8"))) []
[word8DataCon]
word8DataCon :: DataCon
-word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon
+word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon
floatTy :: Type
floatTy = mkTyConTy floatTyCon
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index ecc71baa69..364f4f0300 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/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#
@@ -332,8 +332,8 @@ section "Word8#"
primtype Word8#
-primop Word8Extend "extendWord8#" GenPrimOp Word8# -> Word#
-primop Word8Narrow "narrowWord8#" GenPrimOp Word# -> Word8#
+primop Word8ExtendOp "extendWord8#" GenPrimOp Word8# -> Word#
+primop Word8NarrowOp "narrowWord8#" GenPrimOp Word# -> Word8#
primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8#
@@ -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#
@@ -414,8 +414,8 @@ section "Word16#"
primtype Word16#
-primop Word16Extend "extendWord16#" GenPrimOp Word16# -> Word#
-primop Word16Narrow "narrowWord16#" GenPrimOp Word# -> Word16#
+primop Word16ExtendOp "extendWord16#" GenPrimOp Word16# -> Word#
+primop Word16NarrowOp "narrowWord16#" GenPrimOp Word# -> Word16#
primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16#
@@ -448,6 +448,26 @@ primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int#
primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int#
primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int#
+------------------------------------------------------------------------
+section "Int32#"
+ {Operations on 32-bit integers.}
+------------------------------------------------------------------------
+
+primtype Int32#
+
+primop Int32ExtendOp "extendInt32#" GenPrimOp Int32# -> Int#
+primop Int32NarrowOp "narrowInt32#" GenPrimOp Int# -> Int32#
+
+------------------------------------------------------------------------
+section "Word32#"
+ {Operations on 32-bit unsigned integers.}
+------------------------------------------------------------------------
+
+primtype Word32#
+
+primop Word32ExtendOp "extendWord32#" GenPrimOp Word32# -> Word#
+primop Word32NarrowOp "narrowWord32#" GenPrimOp Word# -> Word32#
+
#if WORD_SIZE_IN_BITS < 64
------------------------------------------------------------------------
section "Int64#"
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index 92255f9ea0..ff8bacd6cc 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -464,6 +464,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"
@@ -478,6 +484,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]
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs
index 5c4c619b69..3a461fa03c 100644
--- a/compiler/GHC/Cmm.hs
+++ b/compiler/GHC/Cmm.hs
@@ -228,6 +228,12 @@ data CmmStatic
| CmmFileEmbed FilePath
-- ^ an embedded binary file
+instance Outputable CmmStatic where
+ ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit
+ ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n
+ ppr (CmmString _) = text "CmmString"
+ ppr (CmmFileEmbed fp) = text "CmmFileEmbed" <+> text fp
+
-- Static data before SRT generation
data GenCmmStatics (rawOnly :: Bool) where
CmmStatics
diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs
index 08ab27c410..e1251c6c27 100644
--- a/compiler/GHC/Cmm/Expr.hs
+++ b/compiler/GHC/Cmm/Expr.hs
@@ -39,6 +39,7 @@ import GHC.Cmm.CLabel
import GHC.Cmm.MachOp
import GHC.Cmm.Type
import GHC.Utils.Panic (panic)
+import GHC.Utils.Outputable
import GHC.Types.Unique
import Data.Set (Set)
@@ -210,6 +211,16 @@ data CmmLit
-- of bytes used
deriving Eq
+instance Outputable CmmLit where
+ ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w
+ ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w
+ ppr (CmmVec xs) = text "CmmVec" <+> ppr xs
+ ppr (CmmLabel _) = text "CmmLabel"
+ ppr (CmmLabelOff _ _) = text "CmmLabelOff"
+ ppr (CmmLabelDiffOff _ _ _ _) = text "CmmLabelDiffOff"
+ ppr (CmmBlock blk) = text "CmmBlock" <+> ppr blk
+ ppr CmmHighStackMark = text "CmmHighStackMark"
+
cmmExprType :: Platform -> CmmExpr -> CmmType
cmmExprType platform = \case
(CmmLit lit) -> cmmLitType platform lit
diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs
index da99a0db07..a3606219da 100644
--- a/compiler/GHC/CmmToAsm/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/Ppr.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE CPP, MagicHash #-}
-----------------------------------------------------------------------------
--
@@ -38,9 +38,17 @@ import Data.Word
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
-import GHC.Exts
+import GHC.Exts hiding (extendWord8#)
import GHC.Word
+#if MIN_VERSION_base(4,16,0)
+import GHC.Base (extendWord8#)
+#else
+extendWord8# :: Word# -> Word#
+extendWord8# w = w
+{-# INLINE extendWord8# #-}
+#endif
+
-- -----------------------------------------------------------------------------
-- Converting floating-point literals to integrals for printing
@@ -103,7 +111,7 @@ pprASCII str
-- we know that the Chars we create are in the ASCII range
-- so we bypass the check in "chr"
chr' :: Word8 -> Char
- chr' (W8# w#) = C# (chr# (word2Int# w#))
+ chr' (W8# w#) = C# (chr# (word2Int# (extendWord8# w#)))
octal :: Word8 -> String
octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index d1f722febd..0733369679 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -159,8 +159,14 @@ pprWordArray platform is_ro lbl ds
-- See Note [StgWord alignment]
, pprAlignment (wordWidth platform)
, text "= {" ]
- $$ nest 8 (commafy (pprStatics platform ds))
+ $$ nest 8 (commafy (staticLitsToWords platform $ toLits ds))
$$ text "};"
+ where
+ toLits :: [CmmStatic] -> [CmmLit]
+ toLits = map f
+ where
+ f (CmmStaticLit lit) = lit
+ f static = pprPanic "pprWordArray: Unexpected literal" (pprStatic platform static)
pprAlignment :: Width -> SDoc
pprAlignment words =
@@ -501,59 +507,69 @@ pprLit1 platform lit = case lit of
-- ---------------------------------------------------------------------------
-- Static data
-pprStatics :: Platform -> [CmmStatic] -> [SDoc]
-pprStatics platform = pprStatics'
+-- | Produce a list of word sized literals encoding the given list of 'CmmLit's.
+staticLitsToWords :: Platform -> [CmmLit] -> [SDoc]
+staticLitsToWords platform = go . foldMap decomposeMultiWord
where
- pprStatics' = \case
- [] -> []
- (CmmStaticLit (CmmFloat f W32) : rest)
- -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
- | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
- -> pprLit1 platform (floatToWord platform f) : pprStatics' rest'
- -- adjacent floats aren't padded but combined into a single word
- | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest
- -> pprLit1 platform (floatPairToWord platform f g) : pprStatics' rest'
- | wordWidth platform == W32
- -> pprLit1 platform (floatToWord platform f) : pprStatics' rest
- | otherwise
- -> pprPanic "pprStatics: float" (vcat (map ppr' rest))
- where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l)
- ppr' _other = text "bad static!"
-
- (CmmStaticLit (CmmFloat f W64) : rest)
- -> map (pprLit1 platform) (doubleToWords platform f) ++ pprStatics' rest
-
- (CmmStaticLit (CmmInt i W64) : rest)
- | wordWidth platform == W32
- -> case platformByteOrder platform of
- BigEndian -> pprStatics' (CmmStaticLit (CmmInt q W32) :
- CmmStaticLit (CmmInt r W32) : rest)
- LittleEndian -> pprStatics' (CmmStaticLit (CmmInt r W32) :
- CmmStaticLit (CmmInt q W32) : rest)
- where r = i .&. 0xffffffff
- q = i `shiftR` 32
-
- (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest)
- | wordWidth platform == W64
- -> case platformByteOrder platform of
- BigEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest)
- LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest)
-
- (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest)
- | wordWidth platform == W32
- -> case platformByteOrder platform of
- BigEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest)
- LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest)
-
- (CmmStaticLit (CmmInt _ w) : _)
- | w /= wordWidth platform
- -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)
-
- (CmmStaticLit lit : rest)
- -> pprLit1 platform lit : pprStatics' rest
-
- (other : _)
- -> pprPanic "pprStatics: other" (pprStatic platform other)
+ -- rem_bytes is how many bytes remain in the word we are currently filling.
+ -- accum is the word we are filling.
+ go :: [CmmLit] -> [SDoc]
+ go [] = []
+ go lits@(lit : _)
+ | Just _ <- isSubWordLit lit
+ = goSubWord wordWidthBytes 0 lits
+ go (lit : rest)
+ = pprLit1 platform lit : go rest
+
+ goSubWord :: Int -> Integer -> [CmmLit] -> [SDoc]
+ goSubWord rem_bytes accum (lit : rest)
+ | Just (bytes, w) <- isSubWordLit lit
+ , rem_bytes >= widthInBytes w
+ = let accum' =
+ case platformByteOrder platform of
+ BigEndian -> (accum `shiftL` widthInBits w) .|. bytes
+ LittleEndian -> (accum `shiftL` widthInBits w) .|. byteSwap w bytes
+ in goSubWord (rem_bytes - widthInBytes w) accum' rest
+ goSubWord rem_bytes accum rest
+ = pprWord (byteSwap (wordWidth platform) $ accum `shiftL` (8*rem_bytes)) : go rest
+
+ -- Decompose multi-word or floating-point literals into multiple
+ -- single-word (or smaller) literals.
+ decomposeMultiWord :: CmmLit -> [CmmLit]
+ decomposeMultiWord (CmmFloat n W64)
+ -- This will produce a W64 integer, which will then be broken up further
+ -- on the next iteration on 32-bit platforms.
+ = [doubleToWord64 n]
+ decomposeMultiWord (CmmFloat n W32)
+ = [floatToWord32 n]
+ decomposeMultiWord (CmmInt n W64)
+ | W32 <- wordWidth platform
+ = [CmmInt hi W32, CmmInt lo W32]
+ where
+ hi = n `shiftR` 32
+ lo = n .&. 0xffffffff
+ decomposeMultiWord lit = [lit]
+
+ -- Decompose a sub-word-sized literal into the integer value and its
+ -- (sub-word-sized) width.
+ isSubWordLit :: CmmLit -> Maybe (Integer, Width)
+ isSubWordLit lit =
+ case lit of
+ CmmInt n w
+ | w < wordWidth platform -> Just (n, w)
+ _ -> Nothing
+
+ wordWidthBytes = widthInBytes $ wordWidth platform
+
+ pprWord :: Integer -> SDoc
+ pprWord n = pprHexVal platform n (wordWidth platform)
+
+byteSwap :: Width -> Integer -> Integer
+byteSwap width n = foldl' f 0 bytes
+ where
+ f acc m = (acc `shiftL` 8) .|. m
+ bytes = [ byte i | i <- [0..widthInBytes width - 1] ]
+ byte i = (n `shiftR` (i*8)) .&. 0xff
pprStatic :: Platform -> CmmStatic -> SDoc
pprStatic platform s = case s of
@@ -1252,69 +1268,30 @@ pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))
-- This is a hack to turn the floating point numbers into ints that we
-- can safely initialise to static locations.
-castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
-castFloatToWord32Array = U.castSTUArray
-
-castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
-castDoubleToWord64Array = U.castSTUArray
-
-floatToWord :: Platform -> Rational -> CmmLit
-floatToWord platform r
- = runST (do
+floatToWord32 :: Rational -> CmmLit
+floatToWord32 r
+ = runST $ do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 (fromRational r)
arr' <- castFloatToWord32Array arr
w32 <- readArray arr' 0
- return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform))
- )
- where wo | wordWidth platform == W64
- , BigEndian <- platformByteOrder platform
- = 32
- | otherwise
- = 0
-
-floatPairToWord :: Platform -> Rational -> Rational -> CmmLit
-floatPairToWord platform r1 r2
- = runST (do
- arr <- newArray_ ((0::Int),1)
- writeArray arr 0 (fromRational r1)
- writeArray arr 1 (fromRational r2)
- arr' <- castFloatToWord32Array arr
- w32_1 <- readArray arr' 0
- w32_2 <- readArray arr' 1
- return (pprWord32Pair w32_1 w32_2)
- )
- where pprWord32Pair w32_1 w32_2
- | BigEndian <- platformByteOrder platform =
- CmmInt ((shiftL i1 32) .|. i2) W64
- | otherwise =
- CmmInt ((shiftL i2 32) .|. i1) W64
- where i1 = toInteger w32_1
- i2 = toInteger w32_2
-
-doubleToWords :: Platform -> Rational -> [CmmLit]
-doubleToWords platform r
- = runST (do
+ return (CmmInt (toInteger w32) W32)
+ where
+ castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
+ castFloatToWord32Array = U.castSTUArray
+
+doubleToWord64 :: Rational -> CmmLit
+doubleToWord64 r
+ = runST $ do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 (fromRational r)
arr' <- castDoubleToWord64Array arr
w64 <- readArray arr' 0
- return (pprWord64 w64)
- )
- where targetWidth = wordWidth platform
- pprWord64 w64
- | targetWidth == W64 =
- [ CmmInt (toInteger w64) targetWidth ]
- | targetWidth == W32 =
- [ CmmInt (toInteger targetW1) targetWidth
- , CmmInt (toInteger targetW2) targetWidth
- ]
- | otherwise = panic "doubleToWords.pprWord64"
- where (targetW1, targetW2) = case platformByteOrder platform of
- BigEndian -> (wHi, wLo)
- LittleEndian -> (wLo, wHi)
- wHi = w64 `shiftR` 32
- wLo = w64 .&. 0xFFFFffff
+ return $ CmmInt (toInteger w64) W64
+ where
+ castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
+ castDoubleToWord64Array = U.castSTUArray
+
-- ---------------------------------------------------------------------------
-- Utils
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 57976e836a..523c8e3d79 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -29,6 +29,7 @@ module GHC.Core (
mkIntLit, mkIntLitWrap,
mkWordLit, mkWordLitWrap,
+ mkWord8Lit,
mkWord64LitWord64, mkInt64LitInt64,
mkCharLit, mkStringLit,
mkFloatLit, mkFloatLitFloat,
@@ -1997,6 +1998,9 @@ mkWordLit platform w = Lit (mkLitWord platform w)
mkWordLitWrap :: Platform -> Integer -> Expr b
mkWordLitWrap platform w = Lit (mkLitWordWrap platform w)
+mkWord8Lit :: Integer -> Expr b
+mkWord8Lit w = Lit (mkLitWord8 w)
+
mkWord64LitWord64 :: Word64 -> Expr b
mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index e02a470d7e..8eb920cdc9 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -198,6 +198,46 @@ primOpRules nm = \case
SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogical ]
-- coercions
+
+ Int8ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+ Int16ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+ Int32ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+ Int8NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit
+ , subsumedByPrimOp Int8NarrowOp
+ , narrowSubsumesAnd AndIOp Int8NarrowOp 8 ]
+ Int16NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit
+ , subsumedByPrimOp Int8NarrowOp
+ , subsumedByPrimOp Int16NarrowOp
+ , narrowSubsumesAnd AndIOp Int16NarrowOp 16 ]
+ Int32NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit
+ , subsumedByPrimOp Int8NarrowOp
+ , subsumedByPrimOp Int16NarrowOp
+ , subsumedByPrimOp Int32NarrowOp
+ , narrowSubsumesAnd AndIOp Int32NarrowOp 32 ]
+
+ Word8ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
+ , extendNarrowPassthrough Word8NarrowOp 0xFF
+ ]
+ Word16ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
+ , extendNarrowPassthrough Word16NarrowOp 0xFFFF
+ ]
+ Word32ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
+ , extendNarrowPassthrough Word32NarrowOp 0xFFFFFFFF
+ ]
+ Word8NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit
+ , subsumedByPrimOp Word8NarrowOp
+ , narrowSubsumesAnd AndOp Word8NarrowOp 8 ]
+ Word16NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit
+ , subsumedByPrimOp Word8NarrowOp
+ , subsumedByPrimOp Word16NarrowOp
+ , narrowSubsumesAnd AndOp Word16NarrowOp 16 ]
+ Word32NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit
+ , subsumedByPrimOp Word8NarrowOp
+ , subsumedByPrimOp Word16NarrowOp
+ , subsumedByPrimOp Word32NarrowOp
+ , narrowSubsumesAnd AndOp Word32NarrowOp 32 ]
+
+
WordToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform wordToIntLit
, inversePrimOp IntToWordOp ]
IntToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform intToWordLit
@@ -625,8 +665,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
@@ -636,8 +682,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
@@ -697,6 +749,13 @@ subsumedByPrimOp primop = do
matchPrimOpId primop primop_id
return e
+-- | Transform `extendWordN (narrowWordN x)` into `x .&. 0xFF..FF`
+extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr
+extendNarrowPassthrough narrow_primop n = do
+ [Var primop_id `App` x] <- getArgs
+ matchPrimOpId narrow_primop primop_id
+ return (Var (mkPrimOpId AndOp) `App` x `App` Lit (LitNumber LitNumWord n))
+
-- | narrow subsumes bitwise `and` with full mask (cf #16402):
--
-- narrowN (x .&. m)
diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs
index f8cb9737d9..96c7ea9dec 100644
--- a/compiler/GHC/CoreToByteCode.hs
+++ b/compiler/GHC/CoreToByteCode.hs
@@ -1387,6 +1387,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
@@ -1405,6 +1411,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
@@ -1621,24 +1633,39 @@ pushAtom d p (AnnVar var)
pushAtom _ _ (AnnLit lit) = do
platform <- targetPlatform <$> getDynFlags
- let code rep
- = let size_words = WordOff (argRepSizeW platform rep)
- in return (unitOL (PUSH_UBX lit (trunc16W size_words)),
- wordsToBytes platform size_words)
+ let code :: PrimRep -> BcM (BCInstrList, ByteOff)
+ code rep =
+ return (unitOL instr, size_bytes)
+ where
+ size_bytes = ByteOff $ primRepSizeB platform rep
+ -- Here we handle the non-word-width cases specifically since we
+ -- must emit different bytecode for them.
+ instr =
+ case size_bytes of
+ 1 -> PUSH_UBX8 lit
+ 2 -> PUSH_UBX16 lit
+ 4 -> PUSH_UBX32 lit
+ _ -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes)
case lit of
- LitLabel _ _ _ -> code N
- LitFloat _ -> code F
- LitDouble _ -> code D
- LitChar _ -> code N
- LitNullAddr -> code N
- LitString _ -> code N
- LitRubbish -> code N
+ LitLabel _ _ _ -> code AddrRep
+ LitFloat _ -> code FloatRep
+ LitDouble _ -> code DoubleRep
+ LitChar _ -> code WordRep
+ LitNullAddr -> code AddrRep
+ LitString _ -> code AddrRep
+ LitRubbish -> code WordRep
LitNumber nt _ -> case nt of
- LitNumInt -> code N
- LitNumWord -> code N
- LitNumInt64 -> code L
- LitNumWord64 -> code L
+ LitNumInt -> code IntRep
+ LitNumWord -> code WordRep
+ LitNumInt8 -> code Int8Rep
+ LitNumWord8 -> code Word8Rep
+ LitNumInt16 -> code Int16Rep
+ LitNumWord16 -> code Word16Rep
+ LitNumInt32 -> code Int32Rep
+ LitNumWord32 -> code Word32Rep
+ LitNumInt64 -> code Int64Rep
+ LitNumWord64 -> code Word64Rep
-- 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.
diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs
index e580057b77..f28d476c05 100644
--- a/compiler/GHC/HsToCore/Foreign/Call.hs
+++ b/compiler/GHC/HsToCore/Foreign/Call.hs
@@ -21,9 +21,7 @@ where
#include "HsVersions.h"
-
import GHC.Prelude
-import GHC.Platform
import GHC.Core
@@ -41,7 +39,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
@@ -355,36 +352,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
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index cae1d3f115..1dea63982f 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -849,6 +849,12 @@ 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'
Word64Rep -> 'l'
AddrRep -> 'p'
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 16d17fd82e..7f2d0b5d85 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -2784,11 +2784,10 @@ repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
repLiteral (HsStringPrim _ bs)
- = do platform <- getPlatform
- word8_ty <- lookupType word8TyConName
+ = do word8_ty <- lookupType word8TyConName
let w8s = unpack bs
w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
- [mkWordLit platform (toInteger w8)]) w8s
+ [mkWord8Lit (toInteger w8)]) w8s
rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]
repLiteral lit
= do lit' <- case lit of
diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs
index 1b912339e5..d5758cdfbd 100644
--- a/compiler/GHC/Runtime/Heap/Inspect.hs
+++ b/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)
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
index 681f1461f1..18a8775cdd 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ b/compiler/GHC/StgToCmm/DataCon.hs
@@ -102,6 +102,21 @@ cgTopRhsCon dflags id con args
nv_args_w_offsets) =
mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args)
+ ; let
+ -- Decompose padding into units of length 8, 4, 2, or 1 bytes to
+ -- allow the implementation of mk_payload to use widthFromBytes,
+ -- which only handles these cases.
+ fix_padding (x@(Padding n off) : rest)
+ | n == 0 = fix_padding rest
+ | n `elem` [1,2,4,8] = x : fix_padding rest
+ | n > 8 = add_pad 8
+ | n > 4 = add_pad 4
+ | n > 2 = add_pad 2
+ | otherwise = add_pad 1
+ where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest)
+ fix_padding (x : rest) = x : fix_padding rest
+ fix_padding [] = []
+
mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do
amode <- getArgAmode arg
@@ -117,7 +132,7 @@ cgTopRhsCon dflags id con args
info_tbl = mkDataConInfoTable profile con True ptr_wds nonptr_wds
- ; payload <- mapM mk_payload nv_args_w_offsets
+ ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)
-- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
-- NB2: all the amodes should be Lits!
-- TODO (osa): Why?
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 625e76f085..4d13d3960c 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1195,8 +1195,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)
@@ -1213,8 +1213,8 @@ emitPrimOp dflags primop = case primop of
-- Word8# unsigned ops
- Word8Extend -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform))
- Word8Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8)
+ Word8ExtendOp -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform))
+ Word8NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8)
Word8NotOp -> \args -> opTranslate args (MO_Not W8)
Word8AddOp -> \args -> opTranslate args (MO_Add W8)
Word8SubOp -> \args -> opTranslate args (MO_Sub W8)
@@ -1231,8 +1231,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)
@@ -1249,8 +1249,8 @@ emitPrimOp dflags primop = case primop of
-- Word16# unsigned ops
- Word16Extend -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform))
- Word16Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16)
+ Word16ExtendOp -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform))
+ Word16NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16)
Word16NotOp -> \args -> opTranslate args (MO_Not W16)
Word16AddOp -> \args -> opTranslate args (MO_Add W16)
Word16SubOp -> \args -> opTranslate args (MO_Sub W16)
@@ -1265,6 +1265,16 @@ emitPrimOp dflags primop = case primop of
Word16LtOp -> \args -> opTranslate args (MO_U_Lt W16)
Word16NeOp -> \args -> opTranslate args (MO_Ne W16)
+-- Int32# signed ops
+
+ Int32ExtendOp -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform))
+ Int32NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32)
+
+-- Word32# unsigned ops
+
+ Word32ExtendOp -> \args -> opTranslate args (MO_UU_Conv W32 (wordWidth platform))
+ Word32NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W32)
+
-- Char# ops
CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth platform))
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index dbb4481d72..8cca28cc5a 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/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
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index 461f4ac70a..a5c855a4fa 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/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
@@ -40,9 +46,13 @@ module GHC.Types.Literal
-- ** Coercions
, wordToIntLit, intToWordLit
- , narrowLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
+ , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit
+ , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit
+ , extendIntLit, extendWordLit
+ , int8Lit, int16Lit, int32Lit
+ , word8Lit, word16Lit, word32Lit
, charToIntLit, intToCharLit
, floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit
, nullAddrLit, rubbishLit, floatToDoubleLit, doubleToFloatLit
@@ -152,8 +162,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)
@@ -163,8 +179,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
{-
@@ -290,6 +312,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
@@ -305,7 +333,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
@@ -364,6 +398,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)
@@ -418,7 +530,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) &&
@@ -466,6 +591,8 @@ mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l)
narrow8IntLit, narrow16IntLit, narrow32IntLit,
narrow8WordLit, narrow16WordLit, narrow32WordLit,
+ int8Lit, int16Lit, int32Lit,
+ word8Lit, word16Lit, word32Lit,
charToIntLit, intToCharLit,
floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit,
floatToDoubleLit, doubleToFloatLit
@@ -489,16 +616,46 @@ intToWordLit platform (LitNumber LitNumInt i)
intToWordLit _ l = pprPanic "intToWordLit" (ppr l)
-- | Narrow a literal number (unchecked result range)
-narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
-narrowLit _ (LitNumber nt i) = LitNumber nt (toInteger (fromInteger i :: a))
-narrowLit _ l = pprPanic "narrowLit" (ppr l)
-
-narrow8IntLit = narrowLit (Proxy :: Proxy Int8)
-narrow16IntLit = narrowLit (Proxy :: Proxy Int16)
-narrow32IntLit = narrowLit (Proxy :: Proxy Int32)
-narrow8WordLit = narrowLit (Proxy :: Proxy Word8)
-narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
-narrow32WordLit = narrowLit (Proxy :: Proxy Word32)
+narrowLit' :: forall a. Integral a => Proxy a -> LitNumType -> Literal -> Literal
+narrowLit' _ nt' (LitNumber _ i) = LitNumber nt' (toInteger (fromInteger i :: a))
+narrowLit' _ _ l = pprPanic "narrowLit" (ppr l)
+
+narrow8IntLit = narrowLit' (Proxy :: Proxy Int8) LitNumInt
+narrow16IntLit = narrowLit' (Proxy :: Proxy Int16) LitNumInt
+narrow32IntLit = narrowLit' (Proxy :: Proxy Int32) LitNumInt
+narrow8WordLit = narrowLit' (Proxy :: Proxy Word8) LitNumWord
+narrow16WordLit = narrowLit' (Proxy :: Proxy Word16) LitNumWord
+narrow32WordLit = narrowLit' (Proxy :: Proxy Word32) LitNumWord
+
+narrowInt8Lit, narrowInt16Lit, narrowInt32Lit,
+ narrowWord8Lit, narrowWord16Lit, narrowWord32Lit :: Literal -> Literal
+narrowInt8Lit = narrowLit' (Proxy :: Proxy Int8) LitNumInt8
+narrowInt16Lit = narrowLit' (Proxy :: Proxy Int16) LitNumInt16
+narrowInt32Lit = narrowLit' (Proxy :: Proxy Int32) LitNumInt32
+narrowWord8Lit = narrowLit' (Proxy :: Proxy Word8) LitNumWord8
+narrowWord16Lit = narrowLit' (Proxy :: Proxy Word16) LitNumWord16
+narrowWord32Lit = narrowLit' (Proxy :: Proxy Word32) LitNumWord32
+
+-- | Extend a fixed-width literal (e.g. 'Int16#') to a word-sized literal (e.g.
+-- 'Int#').
+extendWordLit, extendIntLit :: Platform -> Literal -> Literal
+extendWordLit platform (LitNumber _nt i) = mkLitWord platform i
+extendWordLit _platform l = pprPanic "extendWordLit" (ppr l)
+extendIntLit platform (LitNumber _nt i) = mkLitInt platform i
+extendIntLit _platform l = pprPanic "extendIntLit" (ppr l)
+
+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)
@@ -572,8 +729,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
@@ -585,8 +748,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
@@ -601,8 +770,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
@@ -623,8 +798,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
@@ -700,8 +881,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)
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 3698c5a4b2..7cbd0c4ffd 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -62,7 +62,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,
@@ -1149,22 +1151,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
---------------------
View Lorry Controller Status