Add `timesInt2#` primop

2 files changed, 99 insertions, 0 deletions

diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index f96820de81..01516136c2 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -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, [''])
diff --git a/testsuite/tests/codeGen/should_run/cgrun079.hs b/testsuite/tests/codeGen/should_run/cgrun079.hs
new file mode 100644
index 0000000000..e299c860c3
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cgrun079.hs
@@ -0,0 +1,98 @@
+{-# 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