Constant-folding for timesInt2# (#20374)

4 files changed, 94 insertions, 0 deletions

diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 083150ba81..a1ada95b5f 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -412,6 +412,39 @@ primOpRules nm = \case
                                     , identityPlatform onei
                                     , mulFoldingRules IntMulOp intOps
                                     ]
+   IntMul2Op   -> mkPrimOpRule nm 2 [ do
+                                        [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs
+                                        platform <- getPlatform
+                                        let r = l1 * l2
+                                        pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
+                                          [ Lit (if platformInIntRange platform r then zeroi platform else onei platform)
+                                          , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform)
+                                          , mkIntLitWrap platform r
+                                          ]
+
+                                    , zeroElem >>= \z ->
+                                        pure (mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
+                                                           [z,z,z])
+
+                                      -- timesInt2# 1# other
+                                      -- ~~~>
+                                      -- (# 0#, 0# -# (other >># (WORD_SIZE_IN_BITS-1)), other #)
+                                      -- The second element is the sign bit
+                                      -- repeated to fill a word.
+                                    , identityPlatform onei >>= \other -> do
+                                        platform <- getPlatform
+                                        pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
+                                          [ Lit (zeroi platform)
+                                          , mkCoreApps (Var (mkPrimOpId IntSubOp))
+                                              [ Lit (zeroi platform)
+                                              , mkCoreApps (Var (mkPrimOpId IntSrlOp))
+                                                [ other
+                                                , mkIntLit platform (fromIntegral (platformWordSizeInBits platform - 1))
+                                                ]
+                                              ]
+                                          , other
+                                          ]
+                                    ]
    IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
                                     , leftZero
                                     , rightIdentityPlatform onei
diff --git a/testsuite/tests/numeric/should_compile/T20374.hs b/testsuite/tests/numeric/should_compile/T20374.hs
new file mode 100644
index 0000000000..900d4b8ac5
--- /dev/null
+++ b/testsuite/tests/numeric/should_compile/T20374.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE NegativeLiterals #-}
+
+module T20374 where
+
+import GHC.Exts
+
+foo0 (# #) = timesInt2# 100005# 6832#
+foo1 (# #) = timesInt2# -100005# 6832#
+foo2 (# #) = timesInt2# -100005# -6832#
+foo3 (# #) = timesInt2# 100005# -6832#
+
+foo4 (# #) = timesInt2# 100005# 0#
+foo5 (# #) = timesInt2# 0# 6832#
+
+foo6 other = case timesInt2# 1# other of
+              (# 0#, _ , l #) -> l
+              _               -> error "Unexpected foo6 result"
+foo7 other = case timesInt2# other 1# of
+              (# 0#, _ , l #) -> l
+              _               -> error "Unexpected foo7 result"
+
+foo8 (# #) = timesInt2# 1# 128#
+
+foo9 (# #) = timesInt2# 1# -128#
+
+foo10 (# #) = let (I# m) = maxBound
+             in case timesInt2# m m of
+                  (# 1#, _ , 1# #) -> 1#
+                  _                -> error "Unexpected foo10 result"
diff --git a/testsuite/tests/numeric/should_compile/T20374.stderr b/testsuite/tests/numeric/should_compile/T20374.stderr
new file mode 100644
index 0000000000..86e3ee2180
--- /dev/null
+++ b/testsuite/tests/numeric/should_compile/T20374.stderr
@@ -0,0 +1,29 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 44, types: 107, coercions: 0, joins: 0/0}
+
+foo0 = \ _ -> (# 0#, 0#, 683234160# #)
+
+foo1 = \ _ -> (# 0#, -1#, -683234160# #)
+
+foo2 = foo0
+
+foo3 = foo1
+
+foo4 = \ _ -> (# 0#, 0#, 0# #)
+
+foo5 = foo4
+
+foo6 = \ other -> other
+
+foo7 = foo6
+
+foo8 = \ _ -> (# 0#, 0#, 128# #)
+
+foo9 = \ _ -> (# 0#, -1#, -128# #)
+
+foo10 = \ _ -> 1#
+
+
+
diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T
index 5a0f9efae3..db6867efeb 100644
--- a/testsuite/tests/numeric/should_compile/all.T
+++ b/testsuite/tests/numeric/should_compile/all.T
@@ -13,3 +13,4 @@ test('T19892', normal, compile, ['-O -ddump-rule-firings'])
 test('T20062', [ grep_errmsg(r'integer') ], compile, ['-ddump-simpl -O -dsuppress-all'])
 test('T20245', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds'])
 test('T20376', normal, compile, ['-ddump-simpl -O -dsuppress-all -dsuppress-uniques -dno-typeable-binds'])
+test('T20374', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])