Commit 5f7cb423 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Add `timesInt2#` primop

parent 4cbd5b47
......@@ -1426,10 +1426,17 @@ dispatchPrimop dflags = \case
if ncg && (x86ish || ppc) || llvm
then Left (MO_U_Mul2 (wordWidth dflags))
else Right genericWordMul2Op
IntMul2Op -> \_ -> OpDest_CallishHandledLater $
if ncg && x86ish
then Left (MO_S_Mul2 (wordWidth dflags))
else Right genericIntMul2Op
FloatFabsOp -> \_ -> OpDest_CallishHandledLater $
if (ncg && x86ish || ppc) || llvm
then Left MO_F32_Fabs
else Right $ genericFabsOp W32
DoubleFabsOp -> \_ -> OpDest_CallishHandledLater $
if (ncg && x86ish || ppc) || llvm
then Left MO_F64_Fabs
......@@ -1870,6 +1877,31 @@ genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
topHalf (CmmReg r)])]
genericWordMul2Op _ _ = panic "genericWordMul2Op"
genericIntMul2Op :: GenericOp
genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]
= do dflags <- getDynFlags
-- Implement algorithm from Hacker's Delight, 2nd edition, p.174
let t = cmmExprType dflags arg_x
p <- newTemp t
-- 1) compute the multiplication as if numbers were unsigned
let wordMul2 = fromMaybe (panic "Unsupported out-of-line WordMul2Op")
(emitPrimOp dflags WordMul2Op [arg_x,arg_y])
wordMul2 [p,res_l]
-- 2) correct the high bits of the unsigned result
let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]
sub x y = CmmMachOp (MO_Sub ww) [x, y]
and x y = CmmMachOp (MO_And ww) [x, y]
neq x y = CmmMachOp (MO_Ne ww) [x, y]
f x y = (carryFill x) `and` y
wwm1 = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)
rl x = CmmReg (CmmLocal x)
ww = wordWidth dflags
emit $ catAGraphs
[ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)
, mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))
]
genericIntMul2Op _ _ = panic "genericIntMul2Op"
-- This replicates what we had in libraries/base/GHC/Float.hs:
--
-- abs x | x == 0 = 0 -- handles (-0.0)
......
......@@ -583,6 +583,7 @@ data CallishMachOp
| MO_UF_Conv Width
| MO_S_Mul2 Width
| MO_S_QuotRem Width
| MO_U_QuotRem Width
| MO_U_QuotRem2 Width
......
......@@ -825,6 +825,7 @@ pprCallishMachOp_for_C mop
(MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
(MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
......
......@@ -833,6 +833,7 @@ cmmPrimOpFunctions mop = do
MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow."
++ showSDoc dflags (ppr $ widthToLlvmInt w)
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
......
......@@ -2021,6 +2021,7 @@ genCCall' dflags gcp target dest_regs args
MO_AtomicRead _ -> unsupported
MO_AtomicWrite _ -> unsupported
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
......
......@@ -681,6 +681,7 @@ outOfLineMachOp_table mop
MO_AtomicRead w -> fsLit $ atomicReadLabel w
MO_AtomicWrite w -> fsLit $ atomicWriteLabel w
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
......
......@@ -2613,6 +2613,26 @@ genCCall' _ is32Bit target dest_regs args bid = do
MOV format (OpReg rax) (OpReg reg_l)]
return code
_ -> panic "genCCall: Wrong number of arguments/results for mul2"
(PrimTarget (MO_S_Mul2 width), [res_c, res_h, res_l]) ->
case args of
[arg_x, arg_y] ->
do (y_reg, y_code) <- getRegOrMem arg_y
x_code <- getAnyReg arg_x
reg_tmp <- getNewRegNat II8
let format = intFormat width
reg_h = getRegisterReg platform (CmmLocal res_h)
reg_l = getRegisterReg platform (CmmLocal res_l)
reg_c = getRegisterReg platform (CmmLocal res_c)
code = y_code `appOL`
x_code rax `appOL`
toOL [ IMUL2 format y_reg
, MOV format (OpReg rdx) (OpReg reg_h)
, MOV format (OpReg rax) (OpReg reg_l)
, SETCC CARRY (OpReg reg_tmp)
, MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)
]
return code
_ -> panic "genCCall: Wrong number of arguments/results for imul2"
_ -> if is32Bit
then genCCall32' dflags target dest_regs args
......@@ -3204,6 +3224,7 @@ outOfLineCmmOp bid mop res args
MO_UF_Conv _ -> unsupported
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
......
......@@ -251,6 +251,13 @@ primop IntMulOp "*#"
with commutable = True
fixity = infixl 7
primop IntMul2Op "timesInt2#" GenPrimOp
Int# -> Int# -> (# Int#, Int#, Int# #)
{Return a triple (isHighNeeded,high,low) where high and low are respectively
the high and low bits of the double-word result. isHighNeeded is a cheap way
to test if the high word is a sign-extension of the low word (isHighNeeded =
0#) or not (isHighNeeded = 1#).}
primop IntMulMayOfloOp "mulIntMayOflo#"
Dyadic Int# -> Int# -> Int#
{Return non-zero if there is any possibility that the upper word of a
......
......@@ -27,6 +27,16 @@
reverses the order of its bits e.g. `0b110001` becomes `0b100011`.
These primitives use optimized machine instructions when available.
- Add Int# multiplication primop:
timesInt2# :: Int# -> Int# -> (# Int#, Int#, Int# #)
`timesInt2#` computes the multiplication of its two parameters and returns a
triple (isHighNeeded,high,low) where high and low are respectively the high
and low bits of the double-word result. isHighNeeded is a cheap way to test
if the high word is a sign-extension of the low word (isHighNeeded = 0#) or
not (isHighNeeded = 1#).
## 0.6.0
- Shipped with GHC 8.8.1
......
......@@ -88,6 +88,7 @@ test('cgrun075', normal, compile_and_run, [''])
test('cgrun076', normal, compile_and_run, [''])
test('cgrun077', [when(have_cpu_feature('bmi2'), extra_hc_opts('-mbmi2'))], compile_and_run, [''])
test('cgrun078', omit_ways(['ghci']), compile_and_run, [''])
test('cgrun079', normal, compile_and_run, [''])
test('T1852', normal, compile_and_run, [''])
test('T1861', extra_run_opts('0'), compile_and_run, [''])
......
{-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
-- Tests for the timesInt2# primop
module Main ( main ) where
import Data.Bits
import GHC.Int
import GHC.Prim
import GHC.Word
import Control.Monad
#include "MachDeps.h"
imul2 :: Int -> Int -> (Int,Int,Int)
imul2 (I# x) (I# y) = case timesInt2# x y of
(# c, h, l #) -> (I# c, I# h, I# l)
checkImul2 :: Int -> Int -> IO ()
checkImul2 x y = do
-- First we compare against Integer result. Note that this test will become
-- moot when Integer implementation will use this primitive
let
w2 = fromIntegral x * (fromIntegral y :: Integer)
(c,h,l) = imul2 x y
w = case c of
0 -> fromIntegral l
_ -> int2ToInteger h l
unless (w == w2) do
putStrLn $ mconcat
[ "Failed: "
, show x
, " * "
, show y
, "\n Got: "
, show w
, "\n Expected: "
, show w2
]
-- Now we compare with a generic version using unsigned multiply.
-- This reimplements the fallback generic version that the compiler uses when
-- the mach-op isn't available so it'd better be correct too.
let (c',h',l') = genericIMul2 x y
unless ((c,h,l) == (c',h',l')) do
putStrLn $ mconcat
[ "Failed: "
, show x
, " * "
, show y
, "\n Got: "
, show (c,h,l)
, "\n Expected: "
, show (c',h',l')
]
addWordC :: Word -> Word -> (Word,Word)
addWordC (W# x) (W# y) = case addWordC# x y of
(# l,c #) -> (W# (int2Word# c), W# l)
int2ToInteger :: Int -> Int -> Integer
int2ToInteger h l
| h < 0 = case addWordC (complement (fromIntegral l)) 1 of
(c,w) -> -1 * word2ToInteger (c + complement (fromIntegral h)) w
| otherwise = word2ToInteger (fromIntegral h) (fromIntegral l)
where
word2ToInteger :: Word -> Word -> Integer
word2ToInteger x y = (fromIntegral x) `shiftL` WORD_SIZE_IN_BITS + fromIntegral y
timesWord2 :: Word -> Word -> (Int,Int)
timesWord2 (W# x) (W# y) = case timesWord2# x y of
(# h, l #) -> (I# (word2Int# h), I# (word2Int# l))
genericIMul2 :: Int -> Int -> (Int,Int,Int)
genericIMul2 x y = (c,h,l)
where
(p,l) = timesWord2 (fromIntegral x) (fromIntegral y)
h = p - f x y - f y x
c = if h == carryFill l then 0 else 1
f u v = carryFill u .&. v
-- Return either 00..00 or FF..FF depending on the carry
carryFill :: Int -> Int
carryFill x = x `shiftR` (WORD_SIZE_IN_BITS - 1)
main = do
checkImul2 10 10
checkImul2 10 (-10)
checkImul2 minBound (-1)
checkImul2 maxBound (-1)
checkImul2 minBound 0
checkImul2 maxBound 0
checkImul2 minBound minBound
checkImul2 minBound maxBound
checkImul2 maxBound maxBound
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment