Add quotRem rules (#22152)

  case quotRemInt# x y of
     (# q, _ #) -> body
  ====>
   case quotInt# x y of
     q -> body

  case quotRemInt# x y of
     (# _, r #) -> body
  ====>
   case remInt# x y of
     r -> body

5 files changed, 92 insertions, 0 deletions

diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 86fdc5cdb5..fb863d65cb 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -27,6 +27,7 @@ module GHC.Core.Opt.ConstantFold
    ( primOpRules
    , builtinRules
    , caseRules
+   , caseRules2
    )
 where
 
@@ -3192,6 +3193,61 @@ caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x
 caseRules _ _ = Nothing
 
 
+-- | Case rules
+--
+-- It's important that occurence info are present, hence the use of In* types.
+caseRules2
+   :: InExpr  -- ^ Scutinee
+   -> InId    -- ^ Case-binder
+   -> [InAlt] -- ^ Alternatives in standard (increasing) order
+   -> Maybe (InExpr, InId, [InAlt])
+caseRules2 scrut bndr alts
+
+  -- case quotRem# x y of
+  --    (# q, _ #) -> body
+  -- ====>
+  --  case quot# x y of
+  --    q -> body
+  --
+  -- case quotRem# x y of
+  --    (# _, r #) -> body
+  -- ====>
+  --  case rem# x y of
+  --    r -> body
+  | BinOpApp x op y <- scrut
+  , Just (quot,rem) <- is_any_quot_rem op
+  , [Alt (DataAlt _) [q,r] body] <- alts
+  , isDeadBinder bndr
+  , dead_q <- isDeadBinder q
+  , dead_r <- isDeadBinder r
+  , dead_q || dead_r
+  = if
+      | dead_q    -> Just $ (BinOpApp x rem  y, r, [Alt DEFAULT [] body])
+      | dead_r    -> Just $ (BinOpApp x quot y, q, [Alt DEFAULT [] body])
+      | otherwise -> Nothing
+
+  | otherwise
+  = Nothing
+
+
+-- | If the given primop is a quotRem, return the corresponding (quot,rem).
+is_any_quot_rem :: PrimOp -> Maybe (PrimOp, PrimOp)
+is_any_quot_rem = \case
+  IntQuotRemOp    -> Just (IntQuotOp ,  IntRemOp)
+  Int8QuotRemOp   -> Just (Int8QuotOp,  Int8RemOp)
+  Int16QuotRemOp  -> Just (Int16QuotOp, Int16RemOp)
+  Int32QuotRemOp  -> Just (Int32QuotOp, Int32RemOp)
+  -- Int64QuotRemOp doesn't exist (yet)
+
+  WordQuotRemOp   -> Just (WordQuotOp,   WordRemOp)
+  Word8QuotRemOp  -> Just (Word8QuotOp,  Word8RemOp)
+  Word16QuotRemOp -> Just (Word16QuotOp, Word16RemOp)
+  Word32QuotRemOp -> Just (Word32QuotOp, Word32RemOp)
+  -- Word64QuotRemOp doesn't exist (yet)
+
+  _ -> Nothing
+
+
 tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon
 tx_lit_con _        _      DEFAULT    = Just DEFAULT
 tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l)
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index c0ee65d320..ae667676d6 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -19,6 +19,7 @@ import GHC.Driver.Flags
 
 import GHC.Core
 import GHC.Core.Opt.Simplify.Monad
+import GHC.Core.Opt.ConstantFold
 import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
 import GHC.Core.TyCo.Compare( eqType )
 import GHC.Core.Opt.Simplify.Env
@@ -3039,6 +3040,14 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont
        ; case mb_rule of
            Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'
            Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }
+
+--------------------------------------------------
+--      3. Primop-related case-rules
+--------------------------------------------------
+
+  |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts
+  = reallyRebuildCase env scrut' case_bndr' alts' cont
+
   where
     all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]
     is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
diff --git a/testsuite/tests/primops/should_compile/T22152.hs b/testsuite/tests/primops/should_compile/T22152.hs
new file mode 100644
index 0000000000..177c9a136d
--- /dev/null
+++ b/testsuite/tests/primops/should_compile/T22152.hs
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques #-}
+module T22152 (toHours) where
+
+{-# INLINE toHoursMinutesSeconds #-}
+toHoursMinutesSeconds :: Int -> (Int, Int, Int)
+toHoursMinutesSeconds t = (h, m', s)
+  where
+    (h, m') = m `quotRem` 60
+    (m, s) = toMinutesSeconds t
+
+toMinutesSeconds :: Int -> (Int, Int)
+toMinutesSeconds t = t `quotRem` 60
+
+toHours t = h
+  where
+    (h, _, _) = toHoursMinutesSeconds t
diff --git a/testsuite/tests/primops/should_compile/T22152.stderr b/testsuite/tests/primops/should_compile/T22152.stderr
new file mode 100644
index 0000000000..505bca04a7
--- /dev/null
+++ b/testsuite/tests/primops/should_compile/T22152.stderr
@@ -0,0 +1,10 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 11, types: 5, coercions: 0, joins: 0/0}
+
+toHours
+  = \ t -> case t of { I# x -> I# (quotInt# (quotInt# x 60#) 60#) }
+
+
+
diff --git a/testsuite/tests/primops/should_compile/all.T b/testsuite/tests/primops/should_compile/all.T
index 82fa474c8b..94ef2b5c4f 100644
--- a/testsuite/tests/primops/should_compile/all.T
+++ b/testsuite/tests/primops/should_compile/all.T
@@ -6,3 +6,4 @@ test('LevAddrToAny', normal, compile, [''])
 test('UnliftedMutVar_Comp', normal, compile, [''])
 test('UnliftedStableName', normal, compile, [''])
 test('KeepAliveWrapper', normal, compile, ['-O'])
+test('T22152', normal, compile, [''])