summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorMichal Terepeta <michal.terepeta@gmail.com>2018-11-02 14:27:03 -0400
committerBen Gamari <ben@smart-cactus.org>2018-11-02 17:15:01 -0400
commit2c959a1894311e59cd2fd469c1967491c1e488f3 (patch)
treedc396ec23115f4b6a10b8295bfa94b865ff02efb /compiler
parent6bb8aaa3b4fcebf8f0de2f81f00dcc20b857c4f5 (diff)
downloadhaskell-2c959a1894311e59cd2fd469c1967491c1e488f3.tar.gz
Add Int8# and Word8#
This is the first step of implementing: https://github.com/ghc-proposals/ghc-proposals/pull/74 The main highlights/changes: primops.txt.pp gets two new sections for two new primitive types for signed and unsigned 8-bit integers (Int8# and Word8 respectively) along with basic arithmetic and comparison operations. PrimRep/RuntimeRep get two new constructors for them. All of the primops translate into the existing MachOPs. For CmmCalls the codegen will now zero-extend the values at call site (so that they can be moved to the right register) and then truncate them back their original width. x86 native codegen needed some updates, since it wasn't able to deal with the new widths, but all the changes are quite localized. LLVM backend seems to just work. This is the second attempt at merging this, after the first attempt in D4475 had to be backed out due to regressions on i386. Bumps binary submodule. Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com> Test Plan: ./validate (on both x86-{32,64}) Reviewers: bgamari, hvr, goldfire, simonmar Subscribers: rwbarton, carter Differential Revision: https://phabricator.haskell.org/D5258
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/CmmExpr.hs5
-rw-r--r--compiler/cmm/CmmMachOp.hs10
-rw-r--r--compiler/cmm/CmmUtils.hs6
-rw-r--r--compiler/cmm/MkGraph.hs73
-rw-r--r--compiler/cmm/PprC.hs3
-rw-r--r--compiler/codeGen/StgCmmArgRep.hs2
-rw-r--r--compiler/codeGen/StgCmmPrim.hs74
-rw-r--r--compiler/ghci/ByteCodeGen.hs17
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs4
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs105
-rw-r--r--compiler/nativeGen/X86/Instr.hs8
-rw-r--r--compiler/nativeGen/X86/Ppr.hs10
-rw-r--r--compiler/prelude/PrelNames.hs121
-rw-r--r--compiler/prelude/TysPrim.hs26
-rw-r--r--compiler/prelude/TysWiredIn.hs33
-rw-r--r--compiler/prelude/TysWiredIn.hs-boot6
-rw-r--r--compiler/prelude/primops.txt.pp82
-rw-r--r--compiler/simplStg/RepType.hs7
-rw-r--r--compiler/typecheck/TcGenDeriv.hs156
-rw-r--r--compiler/types/TyCon.hs4
-rw-r--r--compiler/utils/Binary.hs8
21 files changed, 579 insertions, 181 deletions
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index d129d601f4..601b1d9b85 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -6,7 +6,7 @@
module CmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
- , CmmReg(..), cmmRegType
+ , CmmReg(..), cmmRegType, cmmRegWidth
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
, GlobalReg(..), isArgReg, globalRegType
@@ -273,6 +273,9 @@ cmmRegType :: DynFlags -> CmmReg -> CmmType
cmmRegType _ (CmmLocal reg) = localRegType reg
cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
+cmmRegWidth :: DynFlags -> CmmReg -> Width
+cmmRegWidth dflags = typeWidth . cmmRegType dflags
+
localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index c5e9d9bf27..70e53d2325 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -107,6 +107,14 @@ data MachOp
| MO_FS_Conv Width Width -- Float -> Signed int
| MO_SS_Conv Width Width -- Signed int -> Signed int
| MO_UU_Conv Width Width -- unsigned int -> unsigned int
+ | MO_XX_Conv Width Width -- int -> int; puts no requirements on the
+ -- contents of upper bits when extending;
+ -- narrowing is simply truncation; the only
+ -- expectation is that we can recover the
+ -- original value by applying the opposite
+ -- MO_XX_Conv, e.g.,
+ -- MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)
+ -- is equivalent to just x.
| MO_FF_Conv Width Width -- Float -> Float
-- Vector element insertion and extraction operations
@@ -392,6 +400,7 @@ machOpResultType dflags mop tys =
MO_SS_Conv _ to -> cmmBits to
MO_UU_Conv _ to -> cmmBits to
+ MO_XX_Conv _ to -> cmmBits to
MO_FS_Conv _ to -> cmmBits to
MO_SF_Conv _ to -> cmmFloat to
MO_FF_Conv _ to -> cmmFloat to
@@ -483,6 +492,7 @@ machOpArgReps dflags op =
MO_SS_Conv from _ -> [from]
MO_UU_Conv from _ -> [from]
+ MO_XX_Conv from _ -> [from]
MO_SF_Conv from _ -> [from]
MO_FS_Conv from _ -> [from]
MO_FF_Conv from _ -> [from]
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 42d64842e2..11e4df5bf4 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -97,6 +97,8 @@ primRepCmmType dflags LiftedRep = gcWord dflags
primRepCmmType dflags UnliftedRep = gcWord dflags
primRepCmmType dflags IntRep = bWord dflags
primRepCmmType dflags WordRep = bWord dflags
+primRepCmmType _ Int8Rep = b8
+primRepCmmType _ Word8Rep = b8
primRepCmmType _ Int64Rep = b64
primRepCmmType _ Word64Rep = b64
primRepCmmType dflags AddrRep = bWord dflags
@@ -131,8 +133,10 @@ primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
primRepForeignHint LiftedRep = AddrHint
primRepForeignHint UnliftedRep = AddrHint
primRepForeignHint IntRep = SignedHint
-primRepForeignHint WordRep = NoHint
+primRepForeignHint Int8Rep = SignedHint
primRepForeignHint Int64Rep = SignedHint
+primRepForeignHint WordRep = NoHint
+primRepForeignHint Word8Rep = NoHint
primRepForeignHint Word64Rep = NoHint
primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
primRepForeignHint FloatRep = NoHint
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 70229d067d..bcd03bfa67 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -38,6 +38,7 @@ import OrdList
import SMRep (ByteOff)
import UniqSupply
import Util
+import Panic
-----------------------------------------------------------------------------
@@ -309,18 +310,33 @@ copyIn :: DynFlags -> Convention -> Area
copyIn dflags conv area formals extra_stk
= (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
where
- ci (reg, RegisterParam r) =
- CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
- ci (reg, StackParam off) =
- CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
- where ty = localRegType reg
+ -- See Note [Width of parameters]
+ ci (reg, RegisterParam r@(VanillaReg {})) =
+ let local = CmmLocal reg
+ global = CmmReg (CmmGlobal r)
+ width = cmmRegWidth dflags local
+ expr
+ | width == wordWidth dflags = global
+ | width < wordWidth dflags =
+ CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]
+ | otherwise = panic "Parameter width greater than word width"
- init_offset = widthInBytes (wordWidth dflags) -- infotable
+ in CmmAssign local expr
- (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+ -- Non VanillaRegs
+ ci (reg, RegisterParam r) =
+ CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
- (stk_size, args) = assignArgumentsPos dflags stk_off conv
- localRegType formals
+ ci (reg, StackParam off) =
+ CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
+ where ty = localRegType reg
+
+ init_offset = widthInBytes (wordWidth dflags) -- infotable
+
+ (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+
+ (stk_size, args) = assignArgumentsPos dflags stk_off conv
+ localRegType formals
-- Factoring out the common parts of the copyout functions yielded something
-- more complicated:
@@ -346,8 +362,21 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
where
(regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
- co (v, RegisterParam r) (rs, ms)
- = (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+ -- See Note [Width of parameters]
+ co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
+ let width = cmmExprWidth dflags v
+ value
+ | width == wordWidth dflags = v
+ | width < wordWidth dflags =
+ CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]
+ | otherwise = panic "Parameter width greater than word width"
+
+ in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
+
+ -- Non VanillaRegs
+ co (v, RegisterParam r) (rs, ms) =
+ (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+
co (v, StackParam off) (rs, ms)
= (rs, mkStore (CmmStackSlot area off) v <*> ms)
@@ -374,6 +403,28 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
(cmmExprType dflags) actuals
+-- Note [Width of parameters]
+--
+-- Consider passing a small (< word width) primitive like Int8# to a function
+-- through a register. It's actually non-trivial to do this without
+-- extending/narrowing:
+-- * Global registers are considered to have native word width (i.e., 64-bits on
+-- x86-64), so CmmLint would complain if we assigne an 8-bit parameter to a
+-- global register.
+-- * Same problem exists with LLVM IR.
+-- * Lowering gets harder since on x86-32 not every register exposes its lower
+-- 8 bits (e.g., for %eax we can use %al, but there isn't a corresponding
+-- 8-bit register for %edi). So we would either need to extend/narrow anyway,
+-- or complicate the calling convention.
+-- So instead, we always extend every parameter smaller than native word width
+-- in copyOutOflow and then truncate it back to the expected width in copyIn.
+-- Note that we do this in cmm using MO_XX_Conv to avoid requiring
+-- zero-/sign-extending - it's up to a backend to handle this in a most
+-- efficient way (e.g., a simple register move)
+--
+-- There was some discussion about this on this PR:
+-- https://github.com/ghc-proposals/ghc-proposals/pull/74
+
mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
-> (Int, [GlobalReg], CmmAGraph)
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index a979d49501..17fef7fc97 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -646,6 +646,9 @@ pprMachOp_for_C mop = case mop of
MO_SS_Conv from to | from == to -> empty
MO_SS_Conv _from to -> parens (machRep_S_CType to)
+ MO_XX_Conv from to | from == to -> empty
+ MO_XX_Conv _from to -> parens (machRep_U_CType to)
+
MO_FF_Conv from to | from == to -> empty
MO_FF_Conv _from to -> parens (machRep_F_CType to)
diff --git a/compiler/codeGen/StgCmmArgRep.hs b/compiler/codeGen/StgCmmArgRep.hs
index 2ea04079d0..95f96dc16f 100644
--- a/compiler/codeGen/StgCmmArgRep.hs
+++ b/compiler/codeGen/StgCmmArgRep.hs
@@ -70,6 +70,8 @@ toArgRep LiftedRep = P
toArgRep UnliftedRep = P
toArgRep IntRep = N
toArgRep WordRep = N
+toArgRep Int8Rep = N -- Gets widened to native word width for calls
+toArgRep Word8Rep = N -- Gets widened to native word width for calls
toArgRep AddrRep = N
toArgRep Int64Rep = L
toArgRep Word64Rep = L
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index c90264f14f..9da472e768 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -875,19 +875,29 @@ type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
callishPrimOpSupported dflags op
= case op of
- IntQuotRemOp | ncg && (x86ish
- || ppc) -> Left (MO_S_QuotRem (wordWidth dflags))
- | otherwise -> Right (genericIntQuotRemOp dflags)
+ IntQuotRemOp | ncg && (x86ish || ppc) ->
+ Left (MO_S_QuotRem (wordWidth dflags))
+ | otherwise ->
+ Right (genericIntQuotRemOp (wordWidth dflags))
- WordQuotRemOp | ncg && (x86ish
- || ppc) -> Left (MO_U_QuotRem (wordWidth dflags))
- | otherwise -> Right (genericWordQuotRemOp dflags)
+ Int8QuotRemOp | (ncg && x86ish)
+ || llvm -> Left (MO_S_QuotRem W8)
+ | otherwise -> Right (genericIntQuotRemOp W8)
+
+ WordQuotRemOp | ncg && (x86ish || ppc) ->
+ Left (MO_U_QuotRem (wordWidth dflags))
+ | otherwise ->
+ Right (genericWordQuotRemOp (wordWidth dflags))
WordQuotRem2Op | (ncg && (x86ish
|| ppc))
|| llvm -> Left (MO_U_QuotRem2 (wordWidth dflags))
| otherwise -> Right (genericWordQuotRem2Op dflags)
+ Word8QuotRemOp | (ncg && x86ish)
+ || llvm -> Left (MO_U_QuotRem W8)
+ | otherwise -> Right (genericWordQuotRemOp W8)
+
WordAdd2Op | (ncg && (x86ish
|| ppc))
|| llvm -> Left (MO_Add2 (wordWidth dflags))
@@ -943,20 +953,20 @@ callishPrimOpSupported dflags op
ArchPPC_64 _ -> True
_ -> False
-genericIntQuotRemOp :: DynFlags -> GenericOp
-genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]
+genericIntQuotRemOp :: Width -> GenericOp
+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]
= emit $ mkAssign (CmmLocal res_q)
- (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>
+ (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>
mkAssign (CmmLocal res_r)
- (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y])
+ (CmmMachOp (MO_S_Rem width) [arg_x, arg_y])
genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"
-genericWordQuotRemOp :: DynFlags -> GenericOp
-genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]
+genericWordQuotRemOp :: Width -> GenericOp
+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]
= emit $ mkAssign (CmmLocal res_q)
- (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>
+ (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>
mkAssign (CmmLocal res_r)
- (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y])
+ (CmmMachOp (MO_U_Rem width) [arg_x, arg_y])
genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
genericWordQuotRem2Op :: DynFlags -> GenericOp
@@ -1310,6 +1320,42 @@ translateOp dflags AddrLeOp = Just (mo_wordULe dflags)
translateOp dflags AddrGtOp = Just (mo_wordUGt dflags)
translateOp dflags AddrLtOp = Just (mo_wordULt dflags)
+-- Int8# signed ops
+
+translateOp dflags Int8Extend = Just (MO_SS_Conv W8 (wordWidth dflags))
+translateOp dflags Int8Narrow = Just (MO_SS_Conv (wordWidth dflags) W8)
+translateOp _ Int8NegOp = Just (MO_S_Neg W8)
+translateOp _ Int8AddOp = Just (MO_Add W8)
+translateOp _ Int8SubOp = Just (MO_Sub W8)
+translateOp _ Int8MulOp = Just (MO_Mul W8)
+translateOp _ Int8QuotOp = Just (MO_S_Quot W8)
+translateOp _ Int8RemOp = Just (MO_S_Rem W8)
+
+translateOp _ Int8EqOp = Just (MO_Eq W8)
+translateOp _ Int8GeOp = Just (MO_S_Ge W8)
+translateOp _ Int8GtOp = Just (MO_S_Gt W8)
+translateOp _ Int8LeOp = Just (MO_S_Le W8)
+translateOp _ Int8LtOp = Just (MO_S_Lt W8)
+translateOp _ Int8NeOp = Just (MO_Ne W8)
+
+-- Word8# unsigned ops
+
+translateOp dflags Word8Extend = Just (MO_UU_Conv W8 (wordWidth dflags))
+translateOp dflags Word8Narrow = Just (MO_UU_Conv (wordWidth dflags) W8)
+translateOp _ Word8NotOp = Just (MO_Not W8)
+translateOp _ Word8AddOp = Just (MO_Add W8)
+translateOp _ Word8SubOp = Just (MO_Sub W8)
+translateOp _ Word8MulOp = Just (MO_Mul W8)
+translateOp _ Word8QuotOp = Just (MO_U_Quot W8)
+translateOp _ Word8RemOp = Just (MO_U_Rem W8)
+
+translateOp _ Word8EqOp = Just (MO_Eq W8)
+translateOp _ Word8GeOp = Just (MO_U_Ge W8)
+translateOp _ Word8GtOp = Just (MO_U_Gt W8)
+translateOp _ Word8LeOp = Just (MO_U_Le W8)
+translateOp _ Word8LtOp = Just (MO_U_Lt W8)
+translateOp _ Word8NeOp = Just (MO_Ne W8)
+
-- Char# ops
translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags))
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 9aaaa7db64..e723258910 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -805,7 +805,7 @@ mkConAppCode orig_d _ p con args_r_to_l =
do_pushery !d (arg : args) = do
(push, arg_bytes) <- case arg of
- (Padding l _) -> pushPadding l
+ (Padding l _) -> return $! pushPadding l
(FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
more_push_code <- do_pushery (d + arg_bytes) args
return (push `appOL` more_push_code)
@@ -1570,11 +1570,16 @@ pushConstrAtom d p (AnnVar v)
pushConstrAtom d p expr = pushAtom d p expr
-pushPadding :: Int -> BcM (BCInstrList, ByteOff)
-pushPadding 1 = return (unitOL (PUSH_PAD8), 1)
-pushPadding 2 = return (unitOL (PUSH_PAD16), 2)
-pushPadding 4 = return (unitOL (PUSH_PAD32), 4)
-pushPadding x = panic $ "pushPadding x=" ++ show x
+pushPadding :: Int -> (BCInstrList, ByteOff)
+pushPadding !n = go n (nilOL, 0)
+ where
+ go n acc@(!instrs, !off) = case n of
+ 0 -> acc
+ 1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)
+ 2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)
+ 3 -> go 1 (go 2 acc)
+ 4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)
+ _ -> go (n - 4) (go 4 acc)
-- -----------------------------------------------------------------------------
-- Given a bunch of alts code and their discrs, do the donkey work
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 21abc65e5e..efc870993c 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -1193,6 +1193,9 @@ genMachOp _ op [x] = case op of
MO_UU_Conv from to
-> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
+ MO_XX_Conv from to
+ -> sameConv from (widthToLlvmInt to) LM_Bitcast LM_Bitcast
+
MO_FF_Conv from to
-> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
@@ -1454,6 +1457,7 @@ genMachOp_slow opt op [x, y] = case op of
MO_FS_Conv _ _ -> panicOp
MO_SS_Conv _ _ -> panicOp
MO_UU_Conv _ _ -> panicOp
+ MO_XX_Conv _ _ -> panicOp
MO_FF_Conv _ _ -> panicOp
MO_V_Insert {} -> panicOp
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index a2e26bd68b..38dc76090d 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -644,20 +644,27 @@ getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
-- Nop conversions
MO_UU_Conv W32 W8 -> toI8Reg W32 x
MO_SS_Conv W32 W8 -> toI8Reg W32 x
+ MO_XX_Conv W32 W8 -> toI8Reg W32 x
MO_UU_Conv W16 W8 -> toI8Reg W16 x
MO_SS_Conv W16 W8 -> toI8Reg W16 x
+ MO_XX_Conv W16 W8 -> toI8Reg W16 x
MO_UU_Conv W32 W16 -> toI16Reg W32 x
MO_SS_Conv W32 W16 -> toI16Reg W32 x
+ MO_XX_Conv W32 W16 -> toI16Reg W32 x
MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x
MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x
+ MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x
MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
+ MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x
MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x
+ MO_XX_Conv W64 W8 | not is32Bit -> toI8Reg W64 x
MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
+ MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
-- widenings
MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x
@@ -668,16 +675,32 @@ getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x
MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x
+ -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we
+ -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register
+ -- has 8-bit version). So for 32-bit code, we'll just zero-extend.
+ MO_XX_Conv W8 W32
+ | is32Bit -> integerExtend W8 W32 MOVZxL x
+ | otherwise -> integerExtend W8 W32 MOV x
+ MO_XX_Conv W8 W16
+ | is32Bit -> integerExtend W8 W16 MOVZxL x
+ | otherwise -> integerExtend W8 W16 MOV x
+ MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x
+
MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x
MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x
MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x
MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x
MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x
MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x
- -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl.
- -- However, we don't want the register allocator to throw it
- -- away as an unnecessary reg-to-reg move, so we keep it in
- -- the form of a movzl and print it as a movl later.
+ -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.
+ -- However, we don't want the register allocator to throw it
+ -- away as an unnecessary reg-to-reg move, so we keep it in
+ -- the form of a movzl and print it as a movl later.
+ -- This doesn't apply to MO_XX_Conv since in this case we don't care about
+ -- the upper bits. So we can just use MOV.
+ MO_XX_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOV x
+ MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x
+ MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x
MO_FF_Conv W32 W64
| sse2 -> coerceFP2FP W64 x
@@ -787,6 +810,7 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
MO_S_MulMayOflo rep -> imulMayOflo rep x y
+ MO_Mul W8 -> imulW8 x y
MO_Mul rep -> triv_op rep IMUL
MO_And rep -> triv_op rep AND
MO_Or rep -> triv_op rep OR
@@ -822,6 +846,21 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
triv_op width instr = trivialCode width op (Just op) x y
where op = instr (intFormat width)
+ -- Special case for IMUL for bytes, since the result of IMULB will be in
+ -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider
+ -- values.
+ imulW8 :: CmmExpr -> CmmExpr -> NatM Register
+ imulW8 arg_a arg_b = do
+ (a_reg, a_code) <- getNonClobberedReg arg_a
+ b_code <- getAnyReg arg_b
+
+ let code = a_code `appOL` b_code eax `appOL`
+ toOL [ IMUL2 format (OpReg a_reg) ]
+ format = intFormat W8
+
+ return (Fixed format eax code)
+
+
imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo rep a b = do
(a_reg, a_code) <- getNonClobberedReg a
@@ -916,6 +955,18 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
return (Any format code)
----------------------
+
+ -- See Note [DIV/IDIV for bytes]
+ div_code W8 signed quotient x y = do
+ let widen | signed = MO_SS_Conv W8 W16
+ | otherwise = MO_UU_Conv W8 W16
+ div_code
+ W16
+ signed
+ quotient
+ (CmmMachOp widen [x])
+ (CmmMachOp widen [y])
+
div_code width signed quotient x y = do
(y_op, y_code) <- getRegOrMem y -- cannot be clobbered
x_code <- getAnyReg x
@@ -2277,6 +2328,18 @@ genCCall _ is32Bit target dest_regs args = do
= divOp platform signed width results (Just arg_x_high) arg_x_low arg_y
divOp2 _ _ _ _ _
= panic "genCCall: Wrong number of arguments for divOp2"
+
+ -- See Note [DIV/IDIV for bytes]
+ divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y =
+ let widen | signed = MO_SS_Conv W8 W16
+ | otherwise = MO_UU_Conv W8 W16
+ arg_x_low_16 = CmmMachOp widen [arg_x_low]
+ arg_y_16 = CmmMachOp widen [arg_y]
+ m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high
+ in divOp
+ platform signed W16 [res_q, res_r]
+ m_arg_x_high_16 arg_x_low_16 arg_y_16
+
divOp platform signed width [res_q, res_r]
m_arg_x_high arg_x_low arg_y
= do let format = intFormat width
@@ -2318,6 +2381,22 @@ genCCall _ is32Bit target dest_regs args = do
addSubIntC _ _ _ _ _ _ _ _
= panic "genCCall: Wrong number of arguments/results for addSubIntC"
+-- Note [DIV/IDIV for bytes]
+--
+-- IDIV reminder:
+-- Size Dividend Divisor Quotient Remainder
+-- byte %ax r/m8 %al %ah
+-- word %dx:%ax r/m16 %ax %dx
+-- dword %edx:%eax r/m32 %eax %edx
+-- qword %rdx:%rax r/m64 %rax %rdx
+--
+-- We do a special case for the byte division because the current
+-- codegen doesn't deal well with accessing %ah register (also,
+-- accessing %ah in 64-bit mode is complicated because it cannot be an
+-- operand of many instructions). So we just widen operands to 16 bits
+-- and get the results from %al, %dl. This is not optimal, but a few
+-- register moves are probably not a huge deal when doing division.
+
genCCall32' :: DynFlags
-> ForeignTarget -- function to call
-> [CmmFormal] -- where to put the result
@@ -2330,7 +2409,7 @@ genCCall32' dflags target dest_regs args = do
-- Align stack to 16n for calls, assuming a starting stack
-- alignment of 16n - word_size on procedure entry. Which we
-- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
- sizes = map (arg_size . cmmExprType dflags) (reverse args)
+ sizes = map (arg_size_bytes . cmmExprType dflags) (reverse args)
raw_arg_size = sum sizes + wORD_SIZE dflags
arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size
tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE dflags
@@ -2421,8 +2500,9 @@ genCCall32' dflags target dest_regs args = do
assign_code dest_regs)
where
- arg_size :: CmmType -> Int -- Width in bytes
- arg_size ty = widthInBytes (typeWidth ty)
+ -- If the size is smaller than the word, we widen things (see maybePromoteCArg)
+ arg_size_bytes :: CmmType -> Int
+ arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth dflags))
roundTo a x | x `mod` a == 0 = x
| otherwise = x + a - (x `mod` a)
@@ -2461,6 +2541,10 @@ genCCall32' dflags target dest_regs args = do
)
| otherwise = do
+ -- Arguments can be smaller than 32-bit, but we still use @PUSH
+ -- II32@ - the usual calling conventions expect integers to be
+ -- 4-byte aligned.
+ ASSERT((typeWidth arg_ty) <= W32) return ()
(operand, code) <- getOperand arg
delta <- getDeltaNat
setDeltaNat (delta-size)
@@ -2470,7 +2554,7 @@ genCCall32' dflags target dest_regs args = do
where
arg_ty = cmmExprType dflags arg
- size = arg_size arg_ty -- Byte size
+ size = arg_size_bytes arg_ty -- Byte size
genCCall64' :: DynFlags
-> ForeignTarget -- function to call
@@ -2700,7 +2784,10 @@ genCCall64' dflags target dest_regs args = do
push_args rest code'
| otherwise = do
- ASSERT(width == W64) return ()
+ -- Arguments can be smaller than 64-bit, but we still use @PUSH
+ -- II64@ - the usual calling conventions expect integers to be
+ -- 8-byte aligned.
+ ASSERT(width <= W64) return ()
(arg_op, arg_code) <- getOperand arg
delta <- getDeltaNat
setDeltaNat (delta-arg_size)
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index c7000c9f4b..8cc61ed789 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -383,7 +383,13 @@ x86_regUsageOfInstr platform instr
SUB _ src dst -> usageRM src dst
SBB _ src dst -> usageRM src dst
IMUL _ src dst -> usageRM src dst
- IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx]
+
+ -- Result of IMULB will be in just in %ax
+ IMUL2 II8 src -> mkRU (eax:use_R src []) [eax]
+ -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and
+ -- %ax/%eax/%rax.
+ IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx]
+
MUL _ src dst -> usageRM src dst
MUL2 _ src -> mkRU (eax:use_R src []) [eax,edx]
DIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx]
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 808d22a672..acfae71b17 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -328,7 +328,7 @@ pprReg f r
(case i of {
0 -> sLit "%al"; 1 -> sLit "%bl";
2 -> sLit "%cl"; 3 -> sLit "%dl";
- _ -> sLit "very naughty I386 byte register"
+ _ -> sLit $ "very naughty I386 byte register: " ++ show i
})
ppr32_reg_word i = ptext
@@ -365,7 +365,7 @@ pprReg f r
10 -> sLit "%r10b"; 11 -> sLit "%r11b";
12 -> sLit "%r12b"; 13 -> sLit "%r13b";
14 -> sLit "%r14b"; 15 -> sLit "%r15b";
- _ -> sLit "very naughty x86_64 byte register"
+ _ -> sLit $ "very naughty x86_64 byte register: " ++ show i
})
ppr64_reg_word i = ptext
@@ -790,8 +790,11 @@ pprInstr (POP format op) = pprFormatOp (sLit "pop") format op
-- pprInstr POPA = text "\tpopal"
pprInstr NOP = text "\tnop"
+pprInstr (CLTD II8) = text "\tcbtw"
+pprInstr (CLTD II16) = text "\tcwtd"
pprInstr (CLTD II32) = text "\tcltd"
pprInstr (CLTD II64) = text "\tcqto"
+pprInstr (CLTD x) = panic $ "pprInstr: " ++ show x
pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
@@ -1077,9 +1080,6 @@ pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst
pprInstr (CMPXCHG format src dst)
= pprFormatOpOp (sLit "cmpxchg") format src dst
-pprInstr _
- = panic "X86.Ppr.pprInstr: no match"
-
pprTrigOp :: String -> Bool -> CLabel -> CLabel
-> Reg -> Reg -> Format -> SDoc
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index d69eaebdcb..46d4484e47 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -1682,7 +1682,7 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey,
byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,
doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey,
intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,
- int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey,
+ int8PrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey,
integerTyConKey, naturalTyConKey,
listTyConKey, foreignObjPrimTyConKey, maybeTyConKey,
weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey,
@@ -1703,37 +1703,39 @@ floatTyConKey = mkPreludeTyConUnique 12
funTyConKey = mkPreludeTyConUnique 13
intPrimTyConKey = mkPreludeTyConUnique 14
intTyConKey = mkPreludeTyConUnique 15
-int8TyConKey = mkPreludeTyConUnique 16
-int16TyConKey = mkPreludeTyConUnique 17
-int32PrimTyConKey = mkPreludeTyConUnique 18
-int32TyConKey = mkPreludeTyConUnique 19
-int64PrimTyConKey = mkPreludeTyConUnique 20
-int64TyConKey = mkPreludeTyConUnique 21
-integerTyConKey = mkPreludeTyConUnique 22
-naturalTyConKey = mkPreludeTyConUnique 23
-
-listTyConKey = mkPreludeTyConUnique 24
-foreignObjPrimTyConKey = mkPreludeTyConUnique 25
-maybeTyConKey = mkPreludeTyConUnique 26
-weakPrimTyConKey = mkPreludeTyConUnique 27
-mutableArrayPrimTyConKey = mkPreludeTyConUnique 28
-mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29
-orderingTyConKey = mkPreludeTyConUnique 30
-mVarPrimTyConKey = mkPreludeTyConUnique 31
-ratioTyConKey = mkPreludeTyConUnique 32
-rationalTyConKey = mkPreludeTyConUnique 33
-realWorldTyConKey = mkPreludeTyConUnique 34
-stablePtrPrimTyConKey = mkPreludeTyConUnique 35
-stablePtrTyConKey = mkPreludeTyConUnique 36
-eqTyConKey = mkPreludeTyConUnique 38
-heqTyConKey = mkPreludeTyConUnique 39
-arrayArrayPrimTyConKey = mkPreludeTyConUnique 40
-mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 41
+int8PrimTyConKey = mkPreludeTyConUnique 16
+int8TyConKey = mkPreludeTyConUnique 17
+int16TyConKey = mkPreludeTyConUnique 18
+int32PrimTyConKey = mkPreludeTyConUnique 19
+int32TyConKey = mkPreludeTyConUnique 20
+int64PrimTyConKey = mkPreludeTyConUnique 21
+int64TyConKey = mkPreludeTyConUnique 22
+integerTyConKey = mkPreludeTyConUnique 23
+naturalTyConKey = mkPreludeTyConUnique 24
+
+listTyConKey = mkPreludeTyConUnique 25
+foreignObjPrimTyConKey = mkPreludeTyConUnique 26
+maybeTyConKey = mkPreludeTyConUnique 27
+weakPrimTyConKey = mkPreludeTyConUnique 28
+mutableArrayPrimTyConKey = mkPreludeTyConUnique 29
+mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 30
+orderingTyConKey = mkPreludeTyConUnique 31
+mVarPrimTyConKey = mkPreludeTyConUnique 32
+ratioTyConKey = mkPreludeTyConUnique 33
+rationalTyConKey = mkPreludeTyConUnique 34
+realWorldTyConKey = mkPreludeTyConUnique 35
+stablePtrPrimTyConKey = mkPreludeTyConUnique 36
+stablePtrTyConKey = mkPreludeTyConUnique 37
+eqTyConKey = mkPreludeTyConUnique 39
+heqTyConKey = mkPreludeTyConUnique 40
+arrayArrayPrimTyConKey = mkPreludeTyConUnique 41
+mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 42
statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
mutVarPrimTyConKey, ioTyConKey,
- wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey,
- word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
+ wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,
+ word16TyConKey, word32PrimTyConKey, word32TyConKey,
+ word64PrimTyConKey, word64TyConKey,
liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
@@ -1750,24 +1752,25 @@ ioTyConKey = mkPreludeTyConUnique 57
voidPrimTyConKey = mkPreludeTyConUnique 58
wordPrimTyConKey = mkPreludeTyConUnique 59
wordTyConKey = mkPreludeTyConUnique 60
-word8TyConKey = mkPreludeTyConUnique 61
-word16TyConKey = mkPreludeTyConUnique 62
-word32PrimTyConKey = mkPreludeTyConUnique 63
-word32TyConKey = mkPreludeTyConUnique 64
-word64PrimTyConKey = mkPreludeTyConUnique 65
-word64TyConKey = mkPreludeTyConUnique 66
-liftedConKey = mkPreludeTyConUnique 67
-unliftedConKey = mkPreludeTyConUnique 68
-anyBoxConKey = mkPreludeTyConUnique 69
-kindConKey = mkPreludeTyConUnique 70
-boxityConKey = mkPreludeTyConUnique 71
-typeConKey = mkPreludeTyConUnique 72
-threadIdPrimTyConKey = mkPreludeTyConUnique 73
-bcoPrimTyConKey = mkPreludeTyConUnique 74
-ptrTyConKey = mkPreludeTyConUnique 75
-funPtrTyConKey = mkPreludeTyConUnique 76
-tVarPrimTyConKey = mkPreludeTyConUnique 77
-compactPrimTyConKey = mkPreludeTyConUnique 78
+word8PrimTyConKey = mkPreludeTyConUnique 61
+word8TyConKey = mkPreludeTyConUnique 62
+word16TyConKey = mkPreludeTyConUnique 63
+word32PrimTyConKey = mkPreludeTyConUnique 64
+word32TyConKey = mkPreludeTyConUnique 65
+word64PrimTyConKey = mkPreludeTyConUnique 66
+word64TyConKey = mkPreludeTyConUnique 67
+liftedConKey = mkPreludeTyConUnique 68
+unliftedConKey = mkPreludeTyConUnique 69
+anyBoxConKey = mkPreludeTyConUnique 70
+kindConKey = mkPreludeTyConUnique 71
+boxityConKey = mkPreludeTyConUnique 72
+typeConKey = mkPreludeTyConUnique 73
+threadIdPrimTyConKey = mkPreludeTyConUnique 74
+bcoPrimTyConKey = mkPreludeTyConUnique 75
+ptrTyConKey = mkPreludeTyConUnique 76
+funPtrTyConKey = mkPreludeTyConUnique 77
+tVarPrimTyConKey = mkPreludeTyConUnique 78
+compactPrimTyConKey = mkPreludeTyConUnique 79
-- dotnet interop
objectTyConKey :: Unique
@@ -2041,7 +2044,7 @@ sumRepDataConKey = mkPreludeDataConUnique 73
runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]
liftedRepDataConKey :: Unique
runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)
- = map mkPreludeDataConUnique [74..82]
+ = map mkPreludeDataConUnique [74..84]
unliftedRepDataConKeys = vecRepDataConKey :
tupleRepDataConKey :
@@ -2051,29 +2054,29 @@ unliftedRepDataConKeys = vecRepDataConKey :
-- See Note [Wiring in RuntimeRep] in TysWiredIn
-- VecCount
vecCountDataConKeys :: [Unique]
-vecCountDataConKeys = map mkPreludeDataConUnique [83..88]
+vecCountDataConKeys = map mkPreludeDataConUnique [85..90]
-- See Note [Wiring in RuntimeRep] in TysWiredIn
-- VecElem
vecElemDataConKeys :: [Unique]
-vecElemDataConKeys = map mkPreludeDataConUnique [89..98]
+vecElemDataConKeys = map mkPreludeDataConUnique [91..100]
-- Typeable things
kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,
kindRepFunDataConKey, kindRepTYPEDataConKey,
kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey
:: Unique
-kindRepTyConAppDataConKey = mkPreludeDataConUnique 100
-kindRepVarDataConKey = mkPreludeDataConUnique 101
-kindRepAppDataConKey = mkPreludeDataConUnique 102
-kindRepFunDataConKey = mkPreludeDataConUnique 103
-kindRepTYPEDataConKey = mkPreludeDataConUnique 104
-kindRepTypeLitSDataConKey = mkPreludeDataConUnique 105
-kindRepTypeLitDDataConKey = mkPreludeDataConUnique 106
+kindRepTyConAppDataConKey = mkPreludeDataConUnique 101
+kindRepVarDataConKey = mkPreludeDataConUnique 102
+kindRepAppDataConKey = mkPreludeDataConUnique 103
+kindRepFunDataConKey = mkPreludeDataConUnique 104
+kindRepTYPEDataConKey = mkPreludeDataConUnique 105
+kindRepTypeLitSDataConKey = mkPreludeDataConUnique 106
+kindRepTypeLitDDataConKey = mkPreludeDataConUnique 107
typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique
-typeLitSymbolDataConKey = mkPreludeDataConUnique 107
-typeLitNatDataConKey = mkPreludeDataConUnique 108
+typeLitSymbolDataConKey = mkPreludeDataConUnique 108
+typeLitNatDataConKey = mkPreludeDataConUnique 109
---------------- Template Haskell -------------------
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 339913b683..7d04788d51 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -66,6 +66,9 @@ module TysPrim(
weakPrimTyCon, mkWeakPrimTy,
threadIdPrimTyCon, threadIdPrimTy,
+ int8PrimTyCon, int8PrimTy,
+ word8PrimTyCon, word8PrimTy,
+
int32PrimTyCon, int32PrimTy,
word32PrimTyCon, word32PrimTy,
@@ -87,8 +90,9 @@ import GhcPrelude
import {-# SOURCE #-} TysWiredIn
( runtimeRepTy, unboxedTupleKind, liftedTypeKind
, vecRepDataConTyCon, tupleRepDataConTyCon
- , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy
- , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy
+ , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy
+ , wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy
+ , addrRepDataConTy
, floatRepDataConTy, doubleRepDataConTy
, vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy
, vec64DataConTy
@@ -145,6 +149,7 @@ exposedPrimTyCons
, doublePrimTyCon
, floatPrimTyCon
, intPrimTyCon
+ , int8PrimTyCon
, int32PrimTyCon
, int64PrimTyCon
, bcoPrimTyCon
@@ -165,6 +170,7 @@ exposedPrimTyCons
, proxyPrimTyCon
, threadIdPrimTyCon
, wordPrimTyCon
+ , word8PrimTyCon
, word32PrimTyCon
, word64PrimTyCon
@@ -188,12 +194,14 @@ mkBuiltInPrimTc fs unique tycon
BuiltInSyntax
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon
+int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon
int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon
wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon
+word8PrimTyConName = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon
word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon
word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon
addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon
@@ -513,8 +521,10 @@ primRepToRuntimeRep rep = case rep of
LiftedRep -> liftedRepDataConTy
UnliftedRep -> unliftedRepDataConTy
IntRep -> intRepDataConTy
+ Int8Rep -> int8RepDataConTy
WordRep -> wordRepDataConTy
Int64Rep -> int64RepDataConTy
+ Word8Rep -> word8RepDataConTy
Word64Rep -> word64RepDataConTy
AddrRep -> addrRepDataConTy
FloatRep -> floatRepDataConTy
@@ -556,6 +566,11 @@ intPrimTy = mkTyConTy intPrimTyCon
intPrimTyCon :: TyCon
intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep
+int8PrimTy :: Type
+int8PrimTy = mkTyConTy int8PrimTyCon
+int8PrimTyCon :: TyCon
+int8PrimTyCon = pcPrimTyCon0 int8PrimTyConName Int8Rep
+
int32PrimTy :: Type
int32PrimTy = mkTyConTy int32PrimTyCon
int32PrimTyCon :: TyCon
@@ -571,6 +586,11 @@ wordPrimTy = mkTyConTy wordPrimTyCon
wordPrimTyCon :: TyCon
wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep
+word8PrimTy :: Type
+word8PrimTy = mkTyConTy word8PrimTyCon
+word8PrimTyCon :: TyCon
+word8PrimTyCon = pcPrimTyCon0 word8PrimTyConName Word8Rep
+
word32PrimTy :: Type
word32PrimTy = mkTyConTy word32PrimTyCon
word32PrimTyCon :: TyCon
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 78a8d8c25f..7ceeeffd46 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -107,8 +107,9 @@ module TysWiredIn (
vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,
- liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy,
- wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,
+ liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy,
+ wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy,
+ addrRepDataConTy,
floatRepDataConTy, doubleRepDataConTy,
vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
@@ -414,10 +415,18 @@ sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") s
runtimeRepSimpleDataConNames :: [Name]
runtimeRepSimpleDataConNames
= zipWith3Lazy mk_special_dc_name
- [ fsLit "LiftedRep", fsLit "UnliftedRep"
+ [ fsLit "LiftedRep"
+ , fsLit "UnliftedRep"
, fsLit "IntRep"
- , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep"
- , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" ]
+ , fsLit "WordRep"
+ , fsLit "Int8Rep"
+ , fsLit "Int64Rep"
+ , fsLit "Word8Rep"
+ , fsLit "Word64Rep"
+ , fsLit "AddrRep"
+ , fsLit "FloatRep"
+ , fsLit "DoubleRep"
+ ]
runtimeRepSimpleDataConKeys
runtimeRepSimpleDataCons
@@ -1170,8 +1179,8 @@ runtimeRepSimpleDataCons :: [DataCon]
liftedRepDataCon :: DataCon
runtimeRepSimpleDataCons@(liftedRepDataCon : _)
= zipWithLazy mk_runtime_rep_dc
- [ LiftedRep, UnliftedRep, IntRep, WordRep, Int64Rep
- , Word64Rep, AddrRep, FloatRep, DoubleRep ]
+ [ LiftedRep, UnliftedRep, IntRep, WordRep, Int8Rep, Int64Rep
+ , Word8Rep, Word64Rep, AddrRep, FloatRep, DoubleRep ]
runtimeRepSimpleDataConNames
where
mk_runtime_rep_dc primrep name
@@ -1179,11 +1188,13 @@ runtimeRepSimpleDataCons@(liftedRepDataCon : _)
-- See Note [Wiring in RuntimeRep]
liftedRepDataConTy, unliftedRepDataConTy,
- intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
- word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type
+ intRepDataConTy, int8RepDataConTy, wordRepDataConTy, int64RepDataConTy,
+ word8RepDataConTy, word64RepDataConTy, addrRepDataConTy,
+ floatRepDataConTy, doubleRepDataConTy :: Type
[liftedRepDataConTy, unliftedRepDataConTy,
- intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
- word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy]
+ intRepDataConTy, wordRepDataConTy, int8RepDataConTy, int64RepDataConTy,
+ word8RepDataConTy, word64RepDataConTy,
+ addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy]
= map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons
vecCountTyCon :: TyCon
diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot
index 8cc83d7ac7..b853290da3 100644
--- a/compiler/prelude/TysWiredIn.hs-boot
+++ b/compiler/prelude/TysWiredIn.hs-boot
@@ -24,9 +24,9 @@ runtimeRepTy :: Type
liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon
-liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy,
- wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,
- floatRepDataConTy, doubleRepDataConTy :: Type
+liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy,
+ wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy,
+ addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type
vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
vec64DataConTy :: Type
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 1d879c438e..8fceec0107 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -344,6 +344,88 @@ primop ISrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int#
in the range 0 to word size - 1 inclusive.}
------------------------------------------------------------------------
+section "Int8#"
+ {Operations on 8-bit integers.}
+------------------------------------------------------------------------
+
+primtype Int8#
+
+primop Int8Extend "extendInt8#" GenPrimOp Int8# -> Int#
+primop Int8Narrow "narrowInt8#" GenPrimOp Int# -> Int8#
+
+primop Int8NegOp "negateInt8#" Monadic Int8# -> Int8#
+
+primop Int8AddOp "plusInt8#" Dyadic Int8# -> Int8# -> Int8#
+ with
+ commutable = True
+
+primop Int8SubOp "subInt8#" Dyadic Int8# -> Int8# -> Int8#
+
+primop Int8MulOp "timesInt8#" Dyadic Int8# -> Int8# -> Int8#
+ with
+ commutable = True
+
+primop Int8QuotOp "quotInt8#" Dyadic Int8# -> Int8# -> Int8#
+ with
+ can_fail = True
+
+primop Int8RemOp "remInt8#" Dyadic Int8# -> Int8# -> Int8#
+ with
+ can_fail = True
+
+primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)
+ with
+ can_fail = True
+
+primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int#
+
+------------------------------------------------------------------------
+section "Word8#"
+ {Operations on 8-bit unsigned integers.}
+------------------------------------------------------------------------
+
+primtype Word8#
+
+primop Word8Extend "extendWord8#" GenPrimOp Word8# -> Word#
+primop Word8Narrow "narrowWord8#" GenPrimOp Word# -> Word8#
+
+primop Word8NotOp "notWord8#" Monadic Word8# -> Word8#
+
+primop Word8AddOp "plusWord8#" Dyadic Word8# -> Word8# -> Word8#
+ with
+ commutable = True
+
+primop Word8SubOp "subWord8#" Dyadic Word8# -> Word8# -> Word8#
+
+primop Word8MulOp "timesWord8#" Dyadic Word8# -> Word8# -> Word8#
+ with
+ commutable = True
+
+primop Word8QuotOp "quotWord8#" Dyadic Word8# -> Word8# -> Word8#
+ with
+ can_fail = True
+
+primop Word8RemOp "remWord8#" Dyadic Word8# -> Word8# -> Word8#
+ with
+ can_fail = True
+
+primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)
+ with
+ can_fail = True
+
+primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int#
+
+------------------------------------------------------------------------
section "Word#"
{Operations on native-sized unsigned words (32+ bits).}
------------------------------------------------------------------------
diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs
index 694aa4ebf7..a5b8ea67db 100644
--- a/compiler/simplStg/RepType.hs
+++ b/compiler/simplStg/RepType.hs
@@ -228,6 +228,9 @@ layoutUbxSum sum_slots0 arg_slots0 =
-- - Float slots: Shared between floating point types.
--
-- - Void slots: Shared between void types. Not used in sums.
+--
+-- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit
+-- values, so that we can pack things more tightly.
data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
deriving (Eq, Ord)
-- Constructor order is important! If slot A could fit into slot B
@@ -255,8 +258,10 @@ primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
primRepSlot LiftedRep = PtrSlot
primRepSlot UnliftedRep = PtrSlot
primRepSlot IntRep = WordSlot
-primRepSlot WordRep = WordSlot
+primRepSlot Int8Rep = WordSlot
primRepSlot Int64Rep = Word64Slot
+primRepSlot WordRep = WordSlot
+primRepSlot Word8Rep = WordSlot
primRepSlot Word64Rep = Word64Slot
primRepSlot AddrRep = WordSlot
primRepSlot FloatRep = FloatSlot
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 84147c6b64..f4a23851dc 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -77,7 +77,7 @@ import FastString
import Pair
import Bag
-import Data.List ( partition, intersperse )
+import Data.List ( find, partition, intersperse )
type BagDerivStuff = Bag DerivStuff
@@ -218,7 +218,7 @@ gen_Eq_binds loc tycon = do
-- Using 'foldr1' here ensures that the derived code is correctly
-- associated. See Trac #10859.
where
- nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
+ nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
{-
************************************************************************
@@ -456,7 +456,7 @@ gen_Ord_binds loc tycon = do
-- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
mkInnerEqAlt op data_con
= mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
- mkCompareFields tycon op (dataConOrigArgTys data_con)
+ mkCompareFields op (dataConOrigArgTys data_con)
where
data_con_RDR = getRdrName data_con
bs_needed = take (dataConSourceArity data_con) bs_RDRs
@@ -466,17 +466,17 @@ gen_Ord_binds loc tycon = do
-- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
mkTagCmp dflags op =
untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
- unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
+ unliftedOrdOp intPrimTy op ah_RDR bh_RDR
-mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr GhcPs
+mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
-- where the ai,bi have the given types
-mkCompareFields tycon op tys
+mkCompareFields op tys
= go tys as_RDRs bs_RDRs
where
go [] _ _ = eqResult op
go [ty] (a:_) (b:_)
- | isUnliftedType ty = unliftedOrdOp tycon ty op a b
+ | isUnliftedType ty = unliftedOrdOp ty op a b
| otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
(ltResult op)
@@ -498,10 +498,10 @@ mkCompareFields tycon op tys
where
a_expr = nlHsVar a
b_expr = nlHsVar b
- (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
+ (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty
-unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
-unliftedOrdOp tycon ty op a b
+unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
+unliftedOrdOp ty op a b
= case op of
OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
ltTag_Expr eqTag_Expr gtTag_Expr
@@ -510,7 +510,7 @@ unliftedOrdOp tycon ty op a b
OrdGE -> wrap ge_op
OrdGT -> wrap gt_op
where
- (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
+ (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
wrap prim_op = genPrimOpApp a_expr prim_op b_expr
a_expr = nlHsVar a
b_expr = nlHsVar b
@@ -1197,16 +1197,25 @@ gen_Show_binds get_fixity loc tycon
show_arg :: RdrName -> Type -> LHsExpr GhcPs
show_arg b arg_ty
- | isUnliftedType arg_ty
- -- See Note [Deriving and unboxed types] in TcDeriv
- = nlHsApps compose_RDR [mk_shows_app boxed_arg,
- mk_showString_app postfixMod]
- | otherwise
- = mk_showsPrec_app arg_prec arg
- where
- arg = nlHsVar b
- boxed_arg = box "Show" tycon arg arg_ty
- postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
+ | isUnliftedType arg_ty
+ -- See Note [Deriving and unboxed types] in TcDerivInfer
+ = with_conv $
+ nlHsApps compose_RDR
+ [mk_shows_app boxed_arg, mk_showString_app postfixMod]
+ | otherwise
+ = mk_showsPrec_app arg_prec arg
+ where
+ arg = nlHsVar b
+ boxed_arg = box "Show" arg arg_ty
+ postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
+ with_conv expr
+ | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
+ nested_compose_Expr
+ [ mk_showString_app ("(" ++ conv ++ " ")
+ , expr
+ , mk_showString_app ")"
+ ]
+ | otherwise = expr
-- Fixity stuff
is_infix = dataConIsInfix data_con
@@ -1442,10 +1451,13 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
constr_RDR, dataType_RDR,
eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
+ eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR ,
eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
+ eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
- eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
+ eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
+ extendWord8_RDR, extendInt8_RDR :: RdrName
gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
@@ -1474,12 +1486,24 @@ leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
+eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#")
+ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" )
+leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#")
+gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" )
+geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#")
+
eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
+eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#")
+ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" )
+leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#")
+gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" )
+geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#")
+
eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
@@ -1498,6 +1522,10 @@ leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
+extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#")
+extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#")
+
+
{-
************************************************************************
* *
@@ -1555,7 +1583,7 @@ gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
(nlHsVar a)
| otherwise = nlHsApp (nlHsVar litE_RDR)
(primLitOp (mkBoxExp (nlHsVar a)))
- where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
+ where (primLitOp, mkBoxExp) = primLitOps "Lift" ty
pkg_name = unitIdString . moduleUnitId
. nameModule $ tycon_name
@@ -2076,55 +2104,60 @@ mkRdrFunBindSE arity
box :: String -- The class involved
- -> TyCon -- The tycon involved
-> LHsExpr GhcPs -- The argument
-> Type -- The argument type
-> LHsExpr GhcPs -- Boxed version of the arg
--- See Note [Deriving and unboxed types] in TcDeriv
-box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
- where
- box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg
---------------------
primOrdOps :: String -- The class involved
- -> TyCon -- The tycon involved
-> Type -- The type
-> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
--- See Note [Deriving and unboxed types] in TcDeriv
-primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+primOrdOps str ty = assoc_ty_id str ordOpTbl ty
primLitOps :: String -- The class involved
- -> TyCon -- The tycon involved
-> Type -- The type
-> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value
, LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value
)
-primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
- , \v -> nlHsVar boxRDR `nlHsApp` v
- )
+primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v)
where
- boxRDR
- | ty `eqType` addrPrimTy = unpackCString_RDR
- | otherwise = assoc_ty_id str tycon boxConTbl ty
+ boxed v
+ | ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v
+ | otherwise = assoc_ty_id str boxConTbl ty v
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl
= [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
+ ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR , eqInt8_RDR , geInt8_RDR , gtInt8_RDR ))
,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
+ ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR , eqWord8_RDR , geWord8_RDR , gtWord8_RDR ))
,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
-boxConTbl :: [(Type, RdrName)]
-boxConTbl
- = [(charPrimTy , getRdrName charDataCon )
- ,(intPrimTy , getRdrName intDataCon )
- ,(wordPrimTy , getRdrName wordDataCon )
- ,(floatPrimTy , getRdrName floatDataCon )
- ,(doublePrimTy, getRdrName doubleDataCon)
+-- A mapping from a primitive type to a function that constructs its boxed
+-- version.
+-- NOTE: Int8#/Word8# will become Int/Word.
+boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
+boxConTbl =
+ [ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon))
+ , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon))
+ , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
+ , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
+ , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
+ , (int8PrimTy,
+ nlHsApp (nlHsVar $ getRdrName intDataCon)
+ . nlHsApp (nlHsVar extendInt8_RDR))
+ , (word8PrimTy,
+ nlHsApp (nlHsVar $ getRdrName wordDataCon)
+ . nlHsApp (nlHsVar extendWord8_RDR))
]
+
-- | A table of postfix modifiers for unboxed values.
postfixModTbl :: [(Type, String)]
postfixModTbl
@@ -2133,6 +2166,14 @@ postfixModTbl
,(wordPrimTy , "##")
,(floatPrimTy , "#" )
,(doublePrimTy, "##")
+ ,(int8PrimTy, "#")
+ ,(word8PrimTy, "##")
+ ]
+
+primConvTbl :: [(Type, String)]
+primConvTbl =
+ [ (int8PrimTy, "narrowInt8#")
+ , (word8PrimTy, "narrowWord8#")
]
litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
@@ -2156,17 +2197,20 @@ litConTbl
]
-- | Lookup `Type` in an association list.
-assoc_ty_id :: String -- The class involved
- -> TyCon -- The tycon involved
+assoc_ty_id :: HasCallStack => String -- The class involved
-> [(Type,a)] -- The table
-> Type -- The type
-> a -- The result of the lookup
-assoc_ty_id cls_str _ tbl ty
- | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
- text "for primitive type" <+> ppr ty)
- | otherwise = head res
- where
- res = [id | (ty',id) <- tbl, ty `eqType` ty']
+assoc_ty_id cls_str tbl ty
+ | Just a <- assoc_ty_id_maybe tbl ty = a
+ | otherwise =
+ pprPanic "Error in deriving:"
+ (text "Can't derive" <+> text cls_str <+>
+ text "for primitive type" <+> ppr ty)
+
+-- | Lookup `Type` in an association list.
+assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
+assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl
-----------------------------------------------------------------------
@@ -2175,12 +2219,12 @@ and_Expr a b = genOpApp a and_RDR b
-----------------------------------------------------------------------
-eq_Expr :: TyCon -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-eq_Expr tycon ty a b
+eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+eq_Expr ty a b
| not (isUnliftedType ty) = genOpApp a eq_RDR b
| otherwise = genPrimOpApp a prim_eq b
where
- (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
+ (_, _, prim_eq, _, _) = primOrdOps "Eq" ty
untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)]
-> LHsExpr GhcPs -> LHsExpr GhcPs
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index eeebf8b9cf..7322a168ab 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -1325,9 +1325,11 @@ data PrimRep
= VoidRep
| LiftedRep
| UnliftedRep -- ^ Unlifted pointer
+ | Int8Rep -- ^ Signed, 8-bit value
| IntRep -- ^ Signed, word-sized value
| WordRep -- ^ Unsigned, word-sized value
| Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only)
+ | Word8Rep -- ^ Unsigned, 8 bit value
| Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only)
| AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')
| FloatRep
@@ -1373,7 +1375,9 @@ isGcPtrRep _ = False
primRepSizeB :: DynFlags -> PrimRep -> Int
primRepSizeB dflags IntRep = wORD_SIZE dflags
primRepSizeB dflags WordRep = wORD_SIZE dflags
+primRepSizeB _ Int8Rep = 1
primRepSizeB _ Int64Rep = wORD64_SIZE
+primRepSizeB _ Word8Rep = 1
primRepSizeB _ Word64Rep = wORD64_SIZE
primRepSizeB _ FloatRep = fLOAT_SIZE
primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 447317ca47..a38af74efe 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -637,6 +637,10 @@ instance Binary RuntimeRep where
put_ bh AddrRep = putByte bh 9
put_ bh FloatRep = putByte bh 10
put_ bh DoubleRep = putByte bh 11
+#if __GLASGOW_HASKELL__ >= 807
+ put_ bh Int8Rep = putByte bh 12
+ put_ bh Word8Rep = putByte bh 13
+#endif
get bh = do
tag <- getByte bh
@@ -653,6 +657,10 @@ instance Binary RuntimeRep where
9 -> pure AddrRep
10 -> pure FloatRep
11 -> pure DoubleRep
+#if __GLASGOW_HASKELL__ >= 807
+ 12 -> pure Int8Rep
+ 13 -> pure Word8Rep
+#endif
_ -> fail "Binary.putRuntimeRep: invalid tag"
instance Binary KindRep where