diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2022-09-08 23:34:04 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-04-13 08:50:33 -0400 |
commit | 593218794199e23cdfc1a94200cbb9f404e28720 (patch) | |
tree | 651804996b6133e146ab08d2721fd1b04d4f7a8c | |
parent | 690d0225d297a8c5c423ec4e63ee709df9d96d47 (diff) | |
download | haskell-593218794199e23cdfc1a94200cbb9f404e28720.tar.gz |
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
-rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 56 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Iteration.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/primops/should_compile/T22152.hs | 16 | ||||
-rw-r--r-- | testsuite/tests/primops/should_compile/T22152.stderr | 10 | ||||
-rw-r--r-- | testsuite/tests/primops/should_compile/all.T | 1 |
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, ['']) |