diff options
| author | Michal Terepeta <michal.terepeta@gmail.com> | 2018-11-02 14:27:03 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2018-11-02 17:15:01 -0400 |
| commit | 2c959a1894311e59cd2fd469c1967491c1e488f3 (patch) | |
| tree | dc396ec23115f4b6a10b8295bfa94b865ff02efb | |
| parent | 6bb8aaa3b4fcebf8f0de2f81f00dcc20b857c4f5 (diff) | |
| download | haskell-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
44 files changed, 1282 insertions, 186 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 diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs index 8e93690038..664942d878 100644 --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -837,15 +837,16 @@ freeReg :: RegNo -> Bool # if defined(MACHREGS_i386) freeReg esp = False -- %esp is the C stack pointer -freeReg esi = False -- Note [esi/edi not allocatable] +freeReg esi = False -- Note [esi/edi/ebp not allocatable] freeReg edi = False +freeReg ebp = False # endif # if defined(MACHREGS_x86_64) freeReg rsp = False -- %rsp is the C stack pointer # endif {- -Note [esi/edi not allocatable] +Note [esi/edi/ebp not allocatable] %esi is mapped to R1, so %esi would normally be allocatable while it is not being used for R1. However, %esi has no 8-bit version on x86, @@ -855,7 +856,7 @@ graph-colouring allocator also cannot handle this - it was designed with more flexibility in mind, but the current implementation is restricted to the same set of classes as the linear allocator. -Hence, on x86 esi and edi are treated as not allocatable. +Hence, on x86 esi, edi and ebp are treated as not allocatable. -} -- split patterns in two functions to prevent overlaps diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 06d225adb7..cc295b31b8 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -664,8 +664,10 @@ runtimeRepTypeRep r = SumRep rs -> kindedTypeRep @_ @'SumRep `kApp` buildList (map runtimeRepTypeRep rs) IntRep -> rep @'IntRep - WordRep -> rep @'WordRep + Int8Rep -> rep @'Int8Rep Int64Rep -> rep @'Int64Rep + WordRep -> rep @'WordRep + Word8Rep -> rep @'Word8Rep Word64Rep -> rep @'Word64Rep AddrRep -> rep @'AddrRep FloatRep -> rep @'FloatRep diff --git a/libraries/binary b/libraries/binary -Subproject 38adf7ce1ad6a497fba61de500c3f35b186303a +Subproject 0318374b832ebe52a8d01bff2dd7bab8e747fbd diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index d06c0be307..7ab870684d 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -394,8 +394,10 @@ data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type | LiftedRep -- ^ lifted; represented by a pointer | UnliftedRep -- ^ unlifted; represented by a pointer | IntRep -- ^ signed, word-sized value - | WordRep -- ^ unsigned, word-sized value + | Int8Rep -- ^ signed, 8-bit value | Int64Rep -- ^ signed, 64-bit value (on 32-bit only) + | WordRep -- ^ unsigned, word-sized value + | Word8Rep -- ^ unsigned, 8-bit value | Word64Rep -- ^ unsigned, 64-bit value (on 32-bit only) | AddrRep -- ^ A pointer, but /not/ to a Haskell value | FloatRep -- ^ a 32-bit floating point number diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8.hs b/testsuite/tests/ffi/should_run/PrimFFIInt8.hs new file mode 100644 index 0000000000..4124e074aa --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt8.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import GHC.Exts + +foreign import ccall "add_all_int8" + add_all_int8 + :: Int8# -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# + +main :: IO () +main = do + let a = narrowInt8# 0# + b = narrowInt8# 1# + c = narrowInt8# 2# + d = narrowInt8# 3# + e = narrowInt8# 4# + f = narrowInt8# 5# + g = narrowInt8# 6# + h = narrowInt8# 7# + i = narrowInt8# 8# + j = narrowInt8# 9# + x = I# (extendInt8# (add_all_int8 a b c d e f g h i j)) + print x diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout b/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout new file mode 100644 index 0000000000..ea90ee3198 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout @@ -0,0 +1 @@ +45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c b/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c new file mode 100644 index 0000000000..dc51687530 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c @@ -0,0 +1,7 @@ +#include <stdint.h> + +int8_t add_all_int8( + int8_t a, int8_t b, int8_t c, int8_t d, int8_t e, + int8_t f, int8_t g, int8_t h, int8_t i, int8_t j) { + return a + b + c + d + e + f + g + h + i + j; +} diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8.hs b/testsuite/tests/ffi/should_run/PrimFFIWord8.hs new file mode 100644 index 0000000000..87e46636d1 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord8.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import GHC.Exts + +foreign import ccall "add_all_word8" + add_all_word8 + :: Word8# -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# + +main :: IO () +main = do + let a = narrowWord8# 0## + b = narrowWord8# 1## + c = narrowWord8# 2## + d = narrowWord8# 3## + e = narrowWord8# 4## + f = narrowWord8# 5## + g = narrowWord8# 6## + h = narrowWord8# 7## + i = narrowWord8# 8## + j = narrowWord8# 9## + x = W# (extendWord8# (add_all_word8 a b c d e f g h i j)) + print x diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout b/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout new file mode 100644 index 0000000000..ea90ee3198 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout @@ -0,0 +1 @@ +45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c b/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c new file mode 100644 index 0000000000..535ed4185c --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c @@ -0,0 +1,7 @@ +#include <stdint.h> + +uint8_t add_all_word8( + uint8_t a, uint8_t b, uint8_t c, uint8_t d, uint8_t e, + uint8_t f, uint8_t g, uint8_t h, uint8_t i, uint8_t j) { + return a + b + c + d + e + f + g + h + i + j; +} diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T index fd0af7ebc3..9223b3d1b3 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -188,3 +188,7 @@ test('ffi023', [ omit_ways(['ghci']), test('T12134', [omit_ways(['ghci'])], compile_and_run, ['T12134_c.c']) test('T12614', [omit_ways(['ghci'])], compile_and_run, ['T12614_c.c']) + +test('PrimFFIInt8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt8_c.c']) + +test('PrimFFIWord8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord8_c.c']) diff --git a/testsuite/tests/primops/should_run/ArithInt8.hs b/testsuite/tests/primops/should_run/ArithInt8.hs new file mode 100644 index 0000000000..77f4cea21a --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithInt8.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Data.Int +import Data.List +import GHC.Prim +import GHC.Exts + +main :: IO () +main = do + + -- + -- Check if passing Int8# on the stack works (16 parameter function will + -- need to use stack for some of the them) + -- + let input = + [ ( (a + 0), (a + 1), (a + 2), (a + 3), + (a + 4), (a + 5), (a + 6), (a + 7), + (a + 8), (a + 9), (a + 10), (a + 11), + (a + 12), (a + 13), (a + 14), (a + 15) ) + | a <- allInt8 + ] + expected = + [ toInt8 + (a + b + c + d + e + f + g + h + + i + j + k + l + m + n + o + p) + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + actual = + [ addMany a b c d e f g h i j k l m n o p + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + checkResults "passing Int8# on the stack" input expected actual + + -- + -- negateInt8# + -- + let input = allInt8 + expected = [ toInt8 (negate a) | a <- input ] + actual = [ apply1 negateInt8# a | a <- input ] + checkResults "negateInt8#" input expected actual + + -- + -- plusInt8# + -- + let input = [ (a, b) | a <- allInt8, b <- allInt8 ] + expected = [ toInt8 (a + b) | (a, b) <- input ] + actual = [ apply2 plusInt8# a b | (a, b) <- input ] + checkResults "plusInt8#" input expected actual + + -- + -- subInt8# + -- + let input = [ (a, b) | a <- allInt8, b <- allInt8 ] + expected = [ toInt8 (a - b) | (a, b) <- input ] + actual = [ apply2 subInt8# a b | (a, b) <- input ] + checkResults "subInt8#" input expected actual + + -- + -- timesInt8# + -- + let input = [ (a, b) | a <- allInt8, b <- allInt8 ] + expected = [ toInt8 (a * b) | (a, b) <- input ] + actual = [ apply2 timesInt8# a b | (a, b) <- input ] + checkResults "timesInt8#" input expected actual + + -- + -- remInt8# + -- + let input = + [ (a, b) | a <- allInt8, b <- allInt8 + -- Don't divide by 0 or cause overflow + , b /= 0, not (a == -128 && b == -1) + ] + expected = [ toInt8 (a `rem` b) | (a, b) <- input ] + actual = [ apply2 remInt8# a b | (a, b) <- input ] + checkResults "remInt8#" input expected actual + + -- + -- quotInt8# + -- + let input = + [ (a, b) | a <- allInt8, b <- allInt8 + , b /= 0, not (a == -128 && b == -1) + ] + expected = [ toInt8 (a `quot` b) | (a, b) <- input ] + actual = [ apply2 quotInt8# a b | (a, b) <- input ] + checkResults "quotInt8#" input expected actual + + -- + -- quotRemInt8# + -- + let input = + [ (a, b) | a <- allInt8, b <- allInt8 + , b /= 0, not (a == -128 && b == -1) + ] + expected = + [ (toInt8 q, toInt8 r) | (a, b) <- input + , let (q, r) = a `quotRem` b + ] + actual = [ apply3 quotRemInt8# a b | (a, b) <- input ] + checkResults "quotRemInt8#" input expected actual + + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +allInt8 :: [Int] +allInt8 = [ minInt8 .. maxInt8 ] + +minInt8 :: Int +minInt8 = fromIntegral (minBound :: Int8) + +maxInt8 :: Int +maxInt8 = fromIntegral (maxBound :: Int8) + +toInt8 :: Int -> Int +toInt8 a = fromIntegral (fromIntegral a :: Int8) + +addMany# + :: Int8# -> Int8# -> Int8# -> Int8# + -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# +addMany# a b c d e f g h i j k l m n o p = + a `plusInt8#` b `plusInt8#` c `plusInt8#` d `plusInt8#` + e `plusInt8#` f `plusInt8#` g `plusInt8#` h `plusInt8#` + i `plusInt8#` j `plusInt8#` k `plusInt8#` l `plusInt8#` + m `plusInt8#` n `plusInt8#` o `plusInt8#` p +{-# NOINLINE addMany# #-} + +addMany + :: Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int +addMany (I# a) (I# b) (I# c) (I# d) + (I# e) (I# f) (I# g) (I# h) + (I# i) (I# j) (I# k) (I# l) + (I# m) (I# n) (I# o) (I# p) + = I# (extendInt8# int8) + where + !int8 = addMany# + (narrowInt8# a) (narrowInt8# b) (narrowInt8# c) (narrowInt8# d) + (narrowInt8# e) (narrowInt8# f) (narrowInt8# g) (narrowInt8# h) + (narrowInt8# i) (narrowInt8# j) (narrowInt8# k) (narrowInt8# l) + (narrowInt8# m) (narrowInt8# n) (narrowInt8# o) (narrowInt8# p) +{-# NOINLINE addMany #-} + +-- Convenient and also tests higher order functions on Int8# +apply1 :: (Int8# -> Int8#) -> Int -> Int +apply1 opToTest (I# a) = I# (extendInt8# (opToTest (narrowInt8# a))) +{-# NOINLINE apply1 #-} + +apply2 :: (Int8# -> Int8# -> Int8#) -> Int -> Int -> Int +apply2 opToTest (I# a) (I# b) = + let (# sa, sb #) = (# narrowInt8# a, narrowInt8# b #) + r = opToTest sa sb + in I# (extendInt8# r) +{-# NOINLINE apply2 #-} + +apply3 :: (Int8# -> Int8# -> (# Int8#, Int8# #)) -> Int -> Int -> (Int, Int) +apply3 opToTest (I# a) (I# b) = + let (# sa, sb #) = (# narrowInt8# a, narrowInt8# b #) + (# ra, rb #) = opToTest sa sb + in (I# (extendInt8# ra), I# (extendInt8# rb)) +{-# NOINLINE apply3 #-} + +instance + (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, + Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) == + (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) = + a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && + e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && + i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && + m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2 + +instance + (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, + Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p) + => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = + "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++ + "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++ + "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++ + "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++ + ")" diff --git a/testsuite/tests/primops/should_run/ArithInt8.stdout b/testsuite/tests/primops/should_run/ArithInt8.stdout new file mode 100644 index 0000000000..16990fb3c5 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithInt8.stdout @@ -0,0 +1,8 @@ +Pass: passing Int8# on the stack +Pass: negateInt8# +Pass: plusInt8# +Pass: subInt8# +Pass: timesInt8# +Pass: remInt8# +Pass: quotInt8# +Pass: quotRemInt8# diff --git a/testsuite/tests/primops/should_run/ArithWord8.hs b/testsuite/tests/primops/should_run/ArithWord8.hs new file mode 100644 index 0000000000..ceac789878 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithWord8.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Data.Word +import Data.Bits +import Data.List +import GHC.Prim +import GHC.Exts + +main :: IO () +main = do + + -- + -- Check if passing Word8# on the stack works (16 parameter function will + -- need to use stack for some of the them) + -- + let input = + [ ( (a + 0), (a + 1), (a + 2), (a + 3), + (a + 4), (a + 5), (a + 6), (a + 7), + (a + 8), (a + 9), (a + 10), (a + 11), + (a + 12), (a + 13), (a + 14), (a + 15) ) + | a <- allWord8 + ] + expected = + [ toWord8 + (a + b + c + d + e + f + g + h + + i + j + k + l + m + n + o + p) + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + actual = + [ addMany a b c d e f g h i j k l m n o p + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + checkResults "passing Word8# on the stack" input expected actual + + -- + -- notWord8# + -- + let input = allWord8 + expected = [ toWord8 (complement a) | a <- input ] + actual = [ apply1 notWord8# a | a <- input ] + checkResults "notWord8#" input expected actual + + -- + -- plusWord8# + -- + let input = [ (a, b) | a <- allWord8, b <- allWord8 ] + expected = [ toWord8 (a + b) | (a, b) <- input ] + actual = [ apply2 plusWord8# a b | (a, b) <- input ] + checkResults "plusWord8#" input expected actual + + -- + -- subWord8# + -- + let input = [ (a, b) | a <- allWord8, b <- allWord8 ] + expected = [ toWord8 (a - b) | (a, b) <- input ] + actual = [ apply2 subWord8# a b | (a, b) <- input ] + checkResults "subWord8#" input expected actual + + -- + -- timesWord8# + -- + let input = [ (a, b) | a <- allWord8, b <- allWord8 ] + expected = [ toWord8 (a * b) | (a, b) <- input ] + actual = [ apply2 timesWord8# a b | (a, b) <- input ] + checkResults "timesWord8#" input expected actual + + -- + -- remWord8# + -- + let input = + -- Don't divide by 0. + [ (a, b) | a <- allWord8, b <- allWord8 , b /= 0 ] + expected = [ toWord8 (a `rem` b) | (a, b) <- input ] + actual = [ apply2 remWord8# a b | (a, b) <- input ] + checkResults "remWord8#" input expected actual + + -- + -- quotWord8# + -- + let input = + [ (a, b) | a <- allWord8, b <- allWord8, b /= 0 ] + expected = [ toWord8 (a `quot` b) | (a, b) <- input ] + actual = [ apply2 quotWord8# a b | (a, b) <- input ] + checkResults "quotWord8#" input expected actual + + -- + -- quotRemWord8# + -- + let input = + [ (a, b) | a <- allWord8, b <- allWord8, b /= 0 ] + expected = + [ (toWord8 q, toWord8 r) | (a, b) <- input + , let (q, r) = a `quotRem` b + ] + actual = [ apply3 quotRemWord8# a b | (a, b) <- input ] + checkResults "quotRemWord8#" input expected actual + + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +allWord8 :: [Word] +allWord8 = [ minWord8 .. maxWord8 ] + +minWord8 :: Word +minWord8 = fromIntegral (minBound :: Word8) + +maxWord8 :: Word +maxWord8 = fromIntegral (maxBound :: Word8) + +toWord8 :: Word -> Word +toWord8 a = fromIntegral (fromIntegral a :: Word8) + +addMany# + :: Word8# -> Word8# -> Word8# -> Word8# + -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# +addMany# a b c d e f g h i j k l m n o p = + a `plusWord8#` b `plusWord8#` c `plusWord8#` d `plusWord8#` + e `plusWord8#` f `plusWord8#` g `plusWord8#` h `plusWord8#` + i `plusWord8#` j `plusWord8#` k `plusWord8#` l `plusWord8#` + m `plusWord8#` n `plusWord8#` o `plusWord8#` p +{-# NOINLINE addMany# #-} + +addMany + :: Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word +addMany (W# a) (W# b) (W# c) (W# d) + (W# e) (W# f) (W# g) (W# h) + (W# i) (W# j) (W# k) (W# l) + (W# m) (W# n) (W# o) (W# p) + = W# (extendWord8# word8) + where + !word8 = + addMany# + (narrowWord8# a) (narrowWord8# b) (narrowWord8# c) (narrowWord8# d) + (narrowWord8# e) (narrowWord8# f) (narrowWord8# g) (narrowWord8# h) + (narrowWord8# i) (narrowWord8# j) (narrowWord8# k) (narrowWord8# l) + (narrowWord8# m) (narrowWord8# n) (narrowWord8# o) (narrowWord8# p) +{-# NOINLINE addMany #-} + +-- Convenient and also tests higher order functions on Word8# +apply1 :: (Word8# -> Word8#) -> Word -> Word +apply1 opToTest (W# a) = W# (extendWord8# (opToTest (narrowWord8# a))) +{-# NOINLINE apply1 #-} + +apply2 :: (Word8# -> Word8# -> Word8#) -> Word -> Word -> Word +apply2 opToTest (W# a) (W# b) = + let (# sa, sb #) = (# narrowWord8# a, narrowWord8# b #) + r = opToTest sa sb + in W# (extendWord8# r) +{-# NOINLINE apply2 #-} + +apply3 + :: (Word8# -> Word8# -> (# Word8#, Word8# #)) -> Word -> Word -> (Word, Word) +apply3 opToTest (W# a) (W# b) = + let (# sa, sb #) = (# narrowWord8# a, narrowWord8# b #) + (# ra, rb #) = opToTest sa sb + in (W# (extendWord8# ra), W# (extendWord8# rb)) +{-# NOINLINE apply3 #-} + +instance + (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, + Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) == + (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) = + a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && + e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && + i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && + m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2 + +instance + (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, + Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p) + => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = + "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++ + "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++ + "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++ + "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++ + ")" diff --git a/testsuite/tests/primops/should_run/ArithWord8.stdout b/testsuite/tests/primops/should_run/ArithWord8.stdout new file mode 100644 index 0000000000..b745ea0a48 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithWord8.stdout @@ -0,0 +1,8 @@ +Pass: passing Word8# on the stack +Pass: notWord8# +Pass: plusWord8# +Pass: subWord8# +Pass: timesWord8# +Pass: remWord8# +Pass: quotWord8# +Pass: quotRemWord8# diff --git a/testsuite/tests/primops/should_run/CmpInt8.hs b/testsuite/tests/primops/should_run/CmpInt8.hs new file mode 100644 index 0000000000..daea22701d --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpInt8.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Int +import Data.List +import GHC.Prim +import GHC.Exts + + +-- Having a wrapper gives us two things: +-- * it's easier to test everything (no need for code using raw primops) +-- * we test the deriving mechanism for Int8# +data TestInt8 = T8 Int8# + deriving (Eq, Ord) + +mkT8 :: Int -> TestInt8 +mkT8 (I# a) = T8 (narrowInt8# a) + +main :: IO () +main = do + let input = [ (a, b) | a <- allInt8, b <- allInt8 ] + + -- + -- (==) + -- + let expected = [ a == b | (a, b) <- input ] + actual = [ mkT8 a == mkT8 b | (a, b) <- input ] + checkResults "(==)" input expected actual + + -- + -- (/=) + -- + let expected = [ a /= b | (a, b) <- input ] + actual = [ mkT8 a /= mkT8 b | (a, b) <- input ] + checkResults "(/=)" input expected actual + + -- + -- (<) + -- + let expected = [ a < b | (a, b) <- input ] + actual = [ mkT8 a < mkT8 b | (a, b) <- input ] + checkResults "(<)" input expected actual + + -- + -- (>) + -- + let expected = [ a > b | (a, b) <- input ] + actual = [ mkT8 a > mkT8 b | (a, b) <- input ] + checkResults "(>)" input expected actual + + -- + -- (<=) + -- + let expected = [ a <= b | (a, b) <- input ] + actual = [ mkT8 a <= mkT8 b | (a, b) <- input ] + checkResults "(<=)" input expected actual + + -- + -- (>=) + -- + let expected = [ a >= b | (a, b) <- input ] + actual = [ mkT8 a >= mkT8 b | (a, b) <- input ] + checkResults "(>=)" input expected actual + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +allInt8 :: [Int] +allInt8 = [ minInt8 .. maxInt8 ] + +minInt8 :: Int +minInt8 = fromIntegral (minBound :: Int8) + +maxInt8 :: Int +maxInt8 = fromIntegral (maxBound :: Int8) diff --git a/testsuite/tests/primops/should_run/CmpInt8.stdout b/testsuite/tests/primops/should_run/CmpInt8.stdout new file mode 100644 index 0000000000..191d2b4b26 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpInt8.stdout @@ -0,0 +1,6 @@ +Pass: (==) +Pass: (/=) +Pass: (<) +Pass: (>) +Pass: (<=) +Pass: (>=) diff --git a/testsuite/tests/primops/should_run/CmpWord8.hs b/testsuite/tests/primops/should_run/CmpWord8.hs new file mode 100644 index 0000000000..101f7837b5 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpWord8.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Word +import Data.List +import GHC.Prim +import GHC.Exts + + +-- Having a wrapper gives us two things: +-- * it's easier to test everything (no need for code using raw primops) +-- * we test the deriving mechanism for Word8# +data TestWord8 = T8 Word8# + deriving (Eq, Ord) + +mkT8 :: Word -> TestWord8 +mkT8 (W# a) = T8 (narrowWord8# a) + +main :: IO () +main = do + let input = [ (a, b) | a <- allWord8, b <- allWord8 ] + + -- + -- (==) + -- + let expected = [ a == b | (a, b) <- input ] + actual = [ mkT8 a == mkT8 b | (a, b) <- input ] + checkResults "(==)" input expected actual + + -- + -- (/=) + -- + let expected = [ a /= b | (a, b) <- input ] + actual = [ mkT8 a /= mkT8 b | (a, b) <- input ] + checkResults "(/=)" input expected actual + + -- + -- (<) + -- + let expected = [ a < b | (a, b) <- input ] + actual = [ mkT8 a < mkT8 b | (a, b) <- input ] + checkResults "(<)" input expected actual + + -- + -- (>) + -- + let expected = [ a > b | (a, b) <- input ] + actual = [ mkT8 a > mkT8 b | (a, b) <- input ] + checkResults "(>)" input expected actual + + -- + -- (<=) + -- + let expected = [ a <= b | (a, b) <- input ] + actual = [ mkT8 a <= mkT8 b | (a, b) <- input ] + checkResults "(<=)" input expected actual + + -- + -- (>=) + -- + let expected = [ a >= b | (a, b) <- input ] + actual = [ mkT8 a >= mkT8 b | (a, b) <- input ] + checkResults "(>=)" input expected actual + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +allWord8 :: [Word] +allWord8 = [ minWord8 .. maxWord8 ] + +minWord8 :: Word +minWord8 = fromIntegral (minBound :: Word8) + +maxWord8 :: Word +maxWord8 = fromIntegral (maxBound :: Word8) diff --git a/testsuite/tests/primops/should_run/CmpWord8.stdout b/testsuite/tests/primops/should_run/CmpWord8.stdout new file mode 100644 index 0000000000..191d2b4b26 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpWord8.stdout @@ -0,0 +1,6 @@ +Pass: (==) +Pass: (/=) +Pass: (<) +Pass: (>) +Pass: (<=) +Pass: (>=) diff --git a/testsuite/tests/primops/should_run/ShowPrim.hs b/testsuite/tests/primops/should_run/ShowPrim.hs new file mode 100644 index 0000000000..5670032f4a --- /dev/null +++ b/testsuite/tests/primops/should_run/ShowPrim.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts + +data Test = Test Int8# Word8# + deriving (Show) + +test1 :: Test +test1 = Test (narrowInt8# 1#) (narrowWord8# 2##) + +main :: IO () +main = print test1 diff --git a/testsuite/tests/primops/should_run/ShowPrim.stdout b/testsuite/tests/primops/should_run/ShowPrim.stdout new file mode 100644 index 0000000000..5720effb8b --- /dev/null +++ b/testsuite/tests/primops/should_run/ShowPrim.stdout @@ -0,0 +1 @@ +Test (narrowInt8# 1#) (narrowWord8# 2##) diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index 742206d93d..ecf995bea8 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -17,3 +17,8 @@ test('T10678', compile_and_run, ['-O']) test('T11296', normal, compile_and_run, ['']) test('T13825-compile', normal, compile_and_run, ['']) +test('ArithInt8', omit_ways(['ghci']), compile_and_run, ['']) +test('ArithWord8', omit_ways(['ghci']), compile_and_run, ['']) +test('CmpInt8', normal, compile_and_run, ['']) +test('CmpWord8', normal, compile_and_run, ['']) +test('ShowPrim', normal, compile_and_run, ['']) diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index e4779bf916..e422c1fa58 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -834,6 +834,8 @@ ppType (TyApp (TyCon "Any") []) = "anyTy" ppType (TyApp (TyCon "Bool") []) = "boolTy" ppType (TyApp (TyCon "Int#") []) = "intPrimTy" +ppType (TyApp (TyCon "Int8#") []) = "int8PrimTy" +ppType (TyApp (TyCon "Word8#") []) = "word8PrimTy" ppType (TyApp (TyCon "Int32#") []) = "int32PrimTy" ppType (TyApp (TyCon "Int64#") []) = "int64PrimTy" ppType (TyApp (TyCon "Char#") []) = "charPrimTy" |