diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2018-10-09 12:39:14 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2018-10-09 12:40:23 -0400 |
| commit | d728c3c578cc9e9205def2c1e96934487b364b7b (patch) | |
| tree | c542d0ea89dad09c0b8a887266375e4303f9a3a6 | |
| parent | 4eeeb51d5f51083d0ae393009a7fd246223e9791 (diff) | |
| download | haskell-d728c3c578cc9e9205def2c1e96934487b364b7b.tar.gz | |
Revert "Add Int8# and Word8#"
This unfortunately broke i386 support since it introduced references to
byte-sized registers that don't exist on that architecture.
Reverts binary submodule
This reverts commit 5d5307f943d7581d7013ffe20af22233273fba06.
43 files changed, 179 insertions, 1267 deletions
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 601b1d9b85..d129d601f4 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -6,7 +6,7 @@ module CmmExpr ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr - , CmmReg(..), cmmRegType, cmmRegWidth + , CmmReg(..), cmmRegType , CmmLit(..), cmmLitType , LocalReg(..), localRegType , GlobalReg(..), isArgReg, globalRegType @@ -273,9 +273,6 @@ 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 70e53d2325..c5e9d9bf27 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -107,14 +107,6 @@ 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 @@ -400,7 +392,6 @@ 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 @@ -492,7 +483,6 @@ 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 11e4df5bf4..42d64842e2 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -97,8 +97,6 @@ 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 @@ -133,10 +131,8 @@ primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" primRepForeignHint LiftedRep = AddrHint primRepForeignHint UnliftedRep = AddrHint primRepForeignHint IntRep = SignedHint -primRepForeignHint Int8Rep = SignedHint -primRepForeignHint Int64Rep = SignedHint primRepForeignHint WordRep = NoHint -primRepForeignHint Word8Rep = NoHint +primRepForeignHint Int64Rep = SignedHint 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 bcd03bfa67..70229d067d 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -38,7 +38,6 @@ import OrdList import SMRep (ByteOff) import UniqSupply import Util -import Panic ----------------------------------------------------------------------------- @@ -310,33 +309,18 @@ copyIn :: DynFlags -> Convention -> Area copyIn dflags conv area formals extra_stk = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) where - -- 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" + 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 - in CmmAssign local expr + init_offset = widthInBytes (wordWidth dflags) -- infotable - -- Non VanillaRegs - ci (reg, RegisterParam r) = - CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) + (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk - 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 + (stk_size, args) = assignArgumentsPos dflags stk_off conv + localRegType formals -- Factoring out the common parts of the copyout functions yielded something -- more complicated: @@ -362,21 +346,8 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff where (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) - -- 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, RegisterParam r) (rs, ms) + = (r:rs, mkAssign (CmmGlobal r) v <*> ms) co (v, StackParam off) (rs, ms) = (rs, mkStore (CmmStackSlot area off) v <*> ms) @@ -403,28 +374,6 @@ 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 17fef7fc97..a979d49501 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -646,9 +646,6 @@ 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 95f96dc16f..2ea04079d0 100644 --- a/compiler/codeGen/StgCmmArgRep.hs +++ b/compiler/codeGen/StgCmmArgRep.hs @@ -70,8 +70,6 @@ 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 2c73e2ee04..f5437c0c3b 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -881,29 +881,19 @@ 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 (wordWidth dflags)) + IntQuotRemOp | ncg && (x86ish + || ppc) -> Left (MO_S_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericIntQuotRemOp 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)) + WordQuotRemOp | ncg && (x86ish + || ppc) -> Left (MO_U_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericWordQuotRemOp 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)) @@ -959,20 +949,20 @@ callishPrimOpSupported dflags op ArchPPC_64 _ -> True _ -> False -genericIntQuotRemOp :: Width -> GenericOp -genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y] +genericIntQuotRemOp :: DynFlags -> GenericOp +genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*> + (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> mkAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem width) [arg_x, arg_y]) + (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y]) genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" -genericWordQuotRemOp :: Width -> GenericOp -genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y] +genericWordQuotRemOp :: DynFlags -> GenericOp +genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*> + (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> mkAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem width) [arg_x, arg_y]) + (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y]) genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" genericWordQuotRem2Op :: DynFlags -> GenericOp @@ -1326,42 +1316,6 @@ 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 e673cfed0a..022fe89306 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 _) -> return $! pushPadding l + (Padding l _) -> pushPadding l (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) more_push_code <- do_pushery (d + arg_bytes) args return (push `appOL` more_push_code) @@ -1569,16 +1569,11 @@ pushConstrAtom d p (AnnVar v) pushConstrAtom d p expr = pushAtom d p expr -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) +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 -- ----------------------------------------------------------------------------- -- 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 636751b6bf..18734009c6 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -1193,9 +1193,6 @@ 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 @@ -1457,7 +1454,6 @@ 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 66f959a86b..a2e26bd68b 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -644,27 +644,20 @@ 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 @@ -675,26 +668,16 @@ 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. - MO_XX_Conv W8 W32 -> integerExtend W8 W32 MOV x - MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x - MO_XX_Conv W8 W16 -> integerExtend W8 W16 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. - -- 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 + -- 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. MO_FF_Conv W32 W64 | sse2 -> coerceFP2FP W64 x @@ -804,7 +787,6 @@ 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 @@ -840,21 +822,6 @@ 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 @@ -949,18 +916,6 @@ 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 @@ -2322,18 +2277,6 @@ 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 @@ -2375,22 +2318,6 @@ 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 @@ -2534,10 +2461,6 @@ 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) @@ -2777,10 +2700,7 @@ genCCall64' dflags target dest_regs args = do push_args rest code' | otherwise = do - -- 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 () + 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 8cc61ed789..c7000c9f4b 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -383,13 +383,7 @@ x86_regUsageOfInstr platform instr SUB _ src dst -> usageRM src dst SBB _ src dst -> usageRM src dst IMUL _ src dst -> usageRM src dst - - -- 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] - + 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 d4c92df753..03d4fce794 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -327,7 +327,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: " ++ show i + _ -> sLit "very naughty I386 byte register" }) ppr32_reg_word i = ptext @@ -364,7 +364,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: " ++ show i + _ -> sLit "very naughty x86_64 byte register" }) ppr64_reg_word i = ptext @@ -789,11 +789,8 @@ 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) @@ -1079,6 +1076,9 @@ 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 46d4484e47..d69eaebdcb 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, - int8PrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, + int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, integerTyConKey, naturalTyConKey, listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, @@ -1703,39 +1703,37 @@ floatTyConKey = mkPreludeTyConUnique 12 funTyConKey = mkPreludeTyConUnique 13 intPrimTyConKey = mkPreludeTyConUnique 14 intTyConKey = mkPreludeTyConUnique 15 -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 +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 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, - wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, - word16TyConKey, word32PrimTyConKey, word32TyConKey, - word64PrimTyConKey, word64TyConKey, + wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey, + word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, @@ -1752,25 +1750,24 @@ ioTyConKey = mkPreludeTyConUnique 57 voidPrimTyConKey = mkPreludeTyConUnique 58 wordPrimTyConKey = mkPreludeTyConUnique 59 wordTyConKey = mkPreludeTyConUnique 60 -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 +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 -- dotnet interop objectTyConKey :: Unique @@ -2044,7 +2041,7 @@ sumRepDataConKey = mkPreludeDataConUnique 73 runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique] liftedRepDataConKey :: Unique runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys) - = map mkPreludeDataConUnique [74..84] + = map mkPreludeDataConUnique [74..82] unliftedRepDataConKeys = vecRepDataConKey : tupleRepDataConKey : @@ -2054,29 +2051,29 @@ unliftedRepDataConKeys = vecRepDataConKey : -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecCount vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [85..90] +vecCountDataConKeys = map mkPreludeDataConUnique [83..88] -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecElem vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [91..100] +vecElemDataConKeys = map mkPreludeDataConUnique [89..98] -- Typeable things kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, kindRepFunDataConKey, kindRepTYPEDataConKey, kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey :: Unique -kindRepTyConAppDataConKey = mkPreludeDataConUnique 101 -kindRepVarDataConKey = mkPreludeDataConUnique 102 -kindRepAppDataConKey = mkPreludeDataConUnique 103 -kindRepFunDataConKey = mkPreludeDataConUnique 104 -kindRepTYPEDataConKey = mkPreludeDataConUnique 105 -kindRepTypeLitSDataConKey = mkPreludeDataConUnique 106 -kindRepTypeLitDDataConKey = mkPreludeDataConUnique 107 +kindRepTyConAppDataConKey = mkPreludeDataConUnique 100 +kindRepVarDataConKey = mkPreludeDataConUnique 101 +kindRepAppDataConKey = mkPreludeDataConUnique 102 +kindRepFunDataConKey = mkPreludeDataConUnique 103 +kindRepTYPEDataConKey = mkPreludeDataConUnique 104 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 105 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 106 typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique -typeLitSymbolDataConKey = mkPreludeDataConUnique 108 -typeLitNatDataConKey = mkPreludeDataConUnique 109 +typeLitSymbolDataConKey = mkPreludeDataConUnique 107 +typeLitNatDataConKey = mkPreludeDataConUnique 108 ---------------- Template Haskell ------------------- diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index d9e47be060..4a69df8e3e 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -64,9 +64,6 @@ module TysPrim( weakPrimTyCon, mkWeakPrimTy, threadIdPrimTyCon, threadIdPrimTy, - int8PrimTyCon, int8PrimTy, - word8PrimTyCon, word8PrimTy, - int32PrimTyCon, int32PrimTy, word32PrimTyCon, word32PrimTy, @@ -88,9 +85,8 @@ import GhcPrelude import {-# SOURCE #-} TysWiredIn ( runtimeRepTy, unboxedTupleKind, liftedTypeKind , vecRepDataConTyCon, tupleRepDataConTyCon - , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy - , wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy - , addrRepDataConTy + , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy + , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy , floatRepDataConTy, doubleRepDataConTy , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy , vec64DataConTy @@ -147,7 +143,6 @@ exposedPrimTyCons , doublePrimTyCon , floatPrimTyCon , intPrimTyCon - , int8PrimTyCon , int32PrimTyCon , int64PrimTyCon , bcoPrimTyCon @@ -168,7 +163,6 @@ exposedPrimTyCons , proxyPrimTyCon , threadIdPrimTyCon , wordPrimTyCon - , word8PrimTyCon , word32PrimTyCon , word64PrimTyCon @@ -192,14 +186,12 @@ mkBuiltInPrimTc fs unique tycon BuiltInSyntax -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, 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 = 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 @@ -508,10 +500,8 @@ 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 @@ -553,11 +543,6 @@ 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 @@ -573,11 +558,6 @@ 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 30ce75ca8a..20c7d2792a 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -107,9 +107,8 @@ module TysWiredIn ( vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, - liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, - wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy, - addrRepDataConTy, + liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, + wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, @@ -415,18 +414,10 @@ 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 "Int8Rep" - , fsLit "Int64Rep" - , fsLit "Word8Rep" - , fsLit "Word64Rep" - , fsLit "AddrRep" - , fsLit "FloatRep" - , fsLit "DoubleRep" - ] + , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep" + , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" ] runtimeRepSimpleDataConKeys runtimeRepSimpleDataCons @@ -1179,8 +1170,8 @@ runtimeRepSimpleDataCons :: [DataCon] liftedRepDataCon :: DataCon runtimeRepSimpleDataCons@(liftedRepDataCon : _) = zipWithLazy mk_runtime_rep_dc - [ LiftedRep, UnliftedRep, IntRep, WordRep, Int8Rep, Int64Rep - , Word8Rep, Word64Rep, AddrRep, FloatRep, DoubleRep ] + [ LiftedRep, UnliftedRep, IntRep, WordRep, Int64Rep + , Word64Rep, AddrRep, FloatRep, DoubleRep ] runtimeRepSimpleDataConNames where mk_runtime_rep_dc primrep name @@ -1188,13 +1179,11 @@ runtimeRepSimpleDataCons@(liftedRepDataCon : _) -- See Note [Wiring in RuntimeRep] liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, int8RepDataConTy, wordRepDataConTy, int64RepDataConTy, - word8RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: Type + intRepDataConTy, wordRepDataConTy, int64RepDataConTy, + word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type [liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, wordRepDataConTy, int8RepDataConTy, int64RepDataConTy, - word8RepDataConTy, word64RepDataConTy, - addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy] + intRepDataConTy, wordRepDataConTy, int64RepDataConTy, + 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 51e0a78e8e..b777fa187b 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -22,9 +22,9 @@ runtimeRepTy :: Type liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, - wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy, - addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type +liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, + wordRepDataConTy, int64RepDataConTy, 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 162a650b1e..7360ccb758 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -344,88 +344,6 @@ 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 a5b8ea67db..694aa4ebf7 100644 --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -228,9 +228,6 @@ 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 @@ -258,10 +255,8 @@ primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot LiftedRep = PtrSlot primRepSlot UnliftedRep = PtrSlot primRepSlot IntRep = WordSlot -primRepSlot Int8Rep = WordSlot -primRepSlot Int64Rep = Word64Slot primRepSlot WordRep = WordSlot -primRepSlot Word8Rep = WordSlot +primRepSlot Int64Rep = Word64Slot primRepSlot Word64Rep = Word64Slot primRepSlot AddrRep = WordSlot primRepSlot FloatRep = FloatSlot diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index e984a726de..32f081b15d 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -77,7 +77,7 @@ import FastString import Pair import Bag -import Data.List ( find, partition, intersperse ) +import Data.List ( 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 ty (nlHsVar a) (nlHsVar b)) + nested_eq ty a b = nlHsPar (eq_Expr tycon 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 op (dataConOrigArgTys data_con) + mkCompareFields tycon 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 intPrimTy op ah_RDR bh_RDR + unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR -mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs +mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr GhcPs -- Generates nested comparisons for (a1,a2...) against (b1,b2,...) -- where the ai,bi have the given types -mkCompareFields op tys +mkCompareFields tycon op tys = go tys as_RDRs bs_RDRs where go [] _ _ = eqResult op go [ty] (a:_) (b:_) - | isUnliftedType ty = unliftedOrdOp ty op a b + | isUnliftedType ty = unliftedOrdOp tycon 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 op tys where a_expr = nlHsVar a b_expr = nlHsVar b - (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty + (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty -unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs -unliftedOrdOp ty op a b +unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs +unliftedOrdOp tycon 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 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" ty + (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty wrap prim_op = genPrimOpApp a_expr prim_op b_expr a_expr = nlHsVar a b_expr = nlHsVar b @@ -1197,25 +1197,16 @@ 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 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 + | 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 -- Fixity stuff is_infix = dataConIsInfix data_con @@ -1451,13 +1442,10 @@ 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, - extendWord8_RDR, extendInt8_RDR :: RdrName + eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") @@ -1486,24 +1474,12 @@ 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#") @@ -1522,10 +1498,6 @@ 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#") - - {- ************************************************************************ * * @@ -1583,7 +1555,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" ty + where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty pkg_name = unitIdString . moduleUnitId . nameModule $ tycon_name @@ -2105,60 +2077,55 @@ 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 TcDerivInfer -box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty 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 --------------------- 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 TcDerivInfer -primOrdOps str ty = assoc_ty_id str ordOpTbl ty +-- See Note [Deriving and unboxed types] in TcDeriv +primOrdOps str tycon ty = assoc_ty_id str tycon 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 ty = (assoc_ty_id str litConTbl ty, \v -> boxed v) +primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty + , \v -> nlHsVar boxRDR `nlHsApp` v + ) where - boxed v - | ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v - | otherwise = assoc_ty_id str boxConTbl ty v + boxRDR + | ty `eqType` addrPrimTy = unpackCString_RDR + | otherwise = assoc_ty_id str tycon boxConTbl ty 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)) ] --- 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)) +boxConTbl :: [(Type, RdrName)] +boxConTbl + = [(charPrimTy , getRdrName charDataCon ) + ,(intPrimTy , getRdrName intDataCon ) + ,(wordPrimTy , getRdrName wordDataCon ) + ,(floatPrimTy , getRdrName floatDataCon ) + ,(doublePrimTy, getRdrName doubleDataCon) ] - -- | A table of postfix modifiers for unboxed values. postfixModTbl :: [(Type, String)] postfixModTbl @@ -2167,14 +2134,6 @@ postfixModTbl ,(wordPrimTy , "##") ,(floatPrimTy , "#" ) ,(doublePrimTy, "##") - ,(int8PrimTy, "#") - ,(word8PrimTy, "##") - ] - -primConvTbl :: [(Type, String)] -primConvTbl = - [ (int8PrimTy, "narrowInt8#") - , (word8PrimTy, "narrowWord8#") ] litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] @@ -2198,20 +2157,17 @@ litConTbl ] -- | Lookup `Type` in an association list. -assoc_ty_id :: HasCallStack => String -- The class involved +assoc_ty_id :: String -- The class involved + -> TyCon -- The tycon involved -> [(Type,a)] -- The table -> Type -- The type -> a -- The result of the lookup -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 +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'] ----------------------------------------------------------------------- @@ -2220,12 +2176,12 @@ and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- -eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -eq_Expr ty a b +eq_Expr :: TyCon -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +eq_Expr tycon ty a b | not (isUnliftedType ty) = genOpApp a eq_RDR b | otherwise = genPrimOpApp a prim_eq b where - (_, _, prim_eq, _, _) = primOrdOps "Eq" ty + (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 83a3e0cade..6f53bc3c98 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -1309,11 +1309,9 @@ 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 @@ -1359,9 +1357,7 @@ 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 a38af74efe..447317ca47 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -637,10 +637,6 @@ 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 @@ -657,10 +653,6 @@ 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/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 821fffcf81..0d4fc825cf 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -664,10 +664,8 @@ runtimeRepTypeRep r = SumRep rs -> kindedTypeRep @_ @'SumRep `kApp` buildList (map runtimeRepTypeRep rs) IntRep -> rep @'IntRep - Int8Rep -> rep @'Int8Rep - Int64Rep -> rep @'Int64Rep WordRep -> rep @'WordRep - Word8Rep -> rep @'Word8Rep + Int64Rep -> rep @'Int64Rep Word64Rep -> rep @'Word64Rep AddrRep -> rep @'AddrRep FloatRep -> rep @'FloatRep diff --git a/libraries/binary b/libraries/binary -Subproject 0318374b832ebe52a8d01bff2dd7bab8e747fbd +Subproject 38adf7ce1ad6a497fba61de500c3f35b186303a diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 7ab870684d..d06c0be307 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -394,10 +394,8 @@ 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 - | Int8Rep -- ^ signed, 8-bit value - | Int64Rep -- ^ signed, 64-bit value (on 32-bit only) | WordRep -- ^ unsigned, word-sized value - | Word8Rep -- ^ unsigned, 8-bit value + | Int64Rep -- ^ signed, 64-bit value (on 32-bit only) | 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 deleted file mode 100644 index 4124e074aa..0000000000 --- a/testsuite/tests/ffi/should_run/PrimFFIInt8.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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 deleted file mode 100644 index ea90ee3198..0000000000 --- a/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout +++ /dev/null @@ -1 +0,0 @@ -45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c b/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c deleted file mode 100644 index dc51687530..0000000000 --- a/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c +++ /dev/null @@ -1,7 +0,0 @@ -#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 deleted file mode 100644 index 87e46636d1..0000000000 --- a/testsuite/tests/ffi/should_run/PrimFFIWord8.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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 deleted file mode 100644 index ea90ee3198..0000000000 --- a/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout +++ /dev/null @@ -1 +0,0 @@ -45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c b/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c deleted file mode 100644 index 535ed4185c..0000000000 --- a/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c +++ /dev/null @@ -1,7 +0,0 @@ -#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 9223b3d1b3..fd0af7ebc3 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -188,7 +188,3 @@ 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 deleted file mode 100644 index 77f4cea21a..0000000000 --- a/testsuite/tests/primops/should_run/ArithInt8.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# 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 deleted file mode 100644 index 16990fb3c5..0000000000 --- a/testsuite/tests/primops/should_run/ArithInt8.stdout +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index ceac789878..0000000000 --- a/testsuite/tests/primops/should_run/ArithWord8.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# 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 deleted file mode 100644 index b745ea0a48..0000000000 --- a/testsuite/tests/primops/should_run/ArithWord8.stdout +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index daea22701d..0000000000 --- a/testsuite/tests/primops/should_run/CmpInt8.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# 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 deleted file mode 100644 index 191d2b4b26..0000000000 --- a/testsuite/tests/primops/should_run/CmpInt8.stdout +++ /dev/null @@ -1,6 +0,0 @@ -Pass: (==) -Pass: (/=) -Pass: (<) -Pass: (>) -Pass: (<=) -Pass: (>=) diff --git a/testsuite/tests/primops/should_run/CmpWord8.hs b/testsuite/tests/primops/should_run/CmpWord8.hs deleted file mode 100644 index 101f7837b5..0000000000 --- a/testsuite/tests/primops/should_run/CmpWord8.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# 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 deleted file mode 100644 index 191d2b4b26..0000000000 --- a/testsuite/tests/primops/should_run/CmpWord8.stdout +++ /dev/null @@ -1,6 +0,0 @@ -Pass: (==) -Pass: (/=) -Pass: (<) -Pass: (>) -Pass: (<=) -Pass: (>=) diff --git a/testsuite/tests/primops/should_run/ShowPrim.hs b/testsuite/tests/primops/should_run/ShowPrim.hs deleted file mode 100644 index 5670032f4a..0000000000 --- a/testsuite/tests/primops/should_run/ShowPrim.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# 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 deleted file mode 100644 index 5720effb8b..0000000000 --- a/testsuite/tests/primops/should_run/ShowPrim.stdout +++ /dev/null @@ -1 +0,0 @@ -Test (narrowInt8# 1#) (narrowWord8# 2##) diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index ecf995bea8..742206d93d 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -17,8 +17,3 @@ 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 e422c1fa58..e4779bf916 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -834,8 +834,6 @@ 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" |