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

2 files changed, 65 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