[Git][ghc/ghc][wip/T20138] 3 commits: CSE: Combine identical LitAlts
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Sun Jun 4 19:59:15 UTC 2023
Sebastian Graf pushed to branch wip/T20138 at Glasgow Haskell Compiler / GHC
Commits:
0d0a9023 by Sebastian Graf at 2023-06-04T20:18:45+02:00
CSE: Combine identical LitAlts
- - - - -
d58369da by Sebastian Graf at 2023-06-04T21:58:52+02:00
Revert the changes to CSE
- - - - -
b2312393 by Sebastian Graf at 2023-06-04T21:59:00+02:00
Improve the Simplifier instead
- - - - -
5 changed files:
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Utils.hs
- + testsuite/tests/simplCore/should_compile/T20138.hs
- + testsuite/tests/simplCore/should_compile/T20138.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -2300,7 +2300,7 @@ prepareAlts scrut case_bndr alts
-- The multiplicity on case_bndr's is the multiplicity of the
-- case expression The newly introduced patterns in
-- refineDefaultAlt must be scaled by this multiplicity
- (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2
+ (yes3, idcs3, alts3) = combineIdenticalAlts scrut case_bndr idcs1 alts2
-- "idcs" stands for "impossible default data constructors"
-- i.e. the constructors that can't match the default case
; when yes2 $ tick (FillInCaseDefault case_bndr)
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -109,7 +109,7 @@ import GHC.Utils.Misc
import Data.ByteString ( ByteString )
import Data.Function ( on )
-import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
+import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, (\\) )
import Data.Ord ( comparing )
import qualified Data.Set as Set
import GHC.Types.RepType (isZeroBitTy)
@@ -952,14 +952,16 @@ missed the first one.)
-}
-combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT
+combineIdenticalAlts :: CoreExpr -- Scrutinee
+ -> Id -- Case binder
+ -> [AltCon] -- Constructors that cannot match DEFAULT
-> [CoreAlt]
-> (Bool, -- True <=> something happened
[AltCon], -- New constructors that cannot match DEFAULT
[CoreAlt]) -- New alternatives
-- See Note [Combine identical alternatives]
-- True <=> we did some combining, result is a single DEFAULT alternative
-combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts)
+combineIdenticalAlts scrut case_bndr imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts)
| all isDeadBinder bndrs1 -- Remember the default
, not (null elim_rest) -- alternative comes first
= (True, imposs_deflt_cons', deflt_alt : filtered_rest)
@@ -974,12 +976,18 @@ combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts)
DEFAULT -> []
_ -> [con1]
- cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
- identical_to_alt1 (Alt _con bndrs rhs)
- = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1
+
+ identical_to_alt1 (Alt con bndrs rhs)
+ = all isDeadBinder bndrs && cheapEqAlts unfs rhs rhs1
+ where
+ unfs
+ | DEFAULT <- con = emptyVarEnv
+ | otherwise = mkVarEnv [ (v,mkAltExpr con bndrs arg_tys) | v <- subst_bndrs ]
+ subst_bndrs = (case_bndr : [ scrut_var | Var scrut_var <- [scrut] ]) Data.List.\\ bndrs1
+ arg_tys = tyConAppArgs (idType case_bndr)
tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest
-combineIdenticalAlts imposs_cons alts
+combineIdenticalAlts _ _ imposs_cons alts
= (False, imposs_cons, alts)
-- Scales the multiplicity of the binders of a list of case alternatives. That
@@ -993,6 +1001,36 @@ scaleAltsBy w alts = map scaleAlt alts
scaleBndr :: CoreBndr -> CoreBndr
scaleBndr b = scaleVarBy w b
+-- | Cheap expression equality test comparing to the (soon to be) DEFAULT RHS.
+-- The IdEnv contains unfoldings to be applied in the DEFAULT RHS that express
+-- local equalities that hold in the RHS we try to equate to
+cheapEqAlts :: IdEnv CoreExpr -> CoreExpr -> CoreExpr -> Bool
+cheapEqAlts unf_env rhs default_rhs
+ = go rhs default_rhs
+ where
+ go (Var v1) (Var v2) = v1 == v2
+ go e1 (Var v2)
+ | Just unf <- lookupVarEnv unf_env v2 -- only need to expand the case binder in the DEFAULT alt
+ = go e1 unf
+ | Just unf <- get_unf v2 = go e1 unf
+ go (Var v1) e2
+ | Just unf <- get_unf v1 = go unf e2
+
+ go (Lit lit1) (Lit lit2) = lit1 == lit2
+ go (Type t1) (Type t2) = t1 `eqType` t2
+ go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2
+ go (App f1 a1) (App f2 a2) = f1 `go` f2 && a1 `go` a2
+ go (Cast e1 t1) (Cast e2 t2) = e1 `go` e2 && t1 `eqCoercion` t2
+
+ go (Tick t1 e1) e2 | tickishFloatable t1 = go e1 e2
+ go e1 (Tick t2 e2) | tickishFloatable t2 = go e1 e2
+ go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2
+
+ go _ _ = False
+
+ get_unf :: Var -> Maybe CoreExpr
+ get_unf v | isId v = expandUnfolding_maybe (idUnfolding v)
+ | otherwise = Nothing
{- *********************************************************************
* *
=====================================
testsuite/tests/simplCore/should_compile/T20138.hs
=====================================
@@ -0,0 +1,22 @@
+module T20138 where
+
+f :: Int -> Int
+f n = case n of
+ 2 -> n
+ n -> n
+
+g :: Int -> Int
+g n = case n of
+ 2 -> 2
+ n -> n
+
+h :: Int -> Int
+h n = case n of
+ 2 -> maxBound
+ n -> n
+
+data O = O !Ordering
+
+k :: O -> O
+k (O LT) = O LT
+k (O o) = O o
=====================================
testsuite/tests/simplCore/should_compile/T20138.stderr
=====================================
@@ -0,0 +1,118 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 85, types: 37, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 6, types: 2, coercions: 0, joins: 0/0}
+T20138.$WO :: Ordering %1 -> O
+T20138.$WO
+ = \ (conrep :: Ordering) ->
+ case conrep of conrep1 { __DEFAULT -> T20138.O conrep1 }
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+f :: Int -> Int
+f = \ (n :: Int) -> n
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T20138.g1 :: Int
+T20138.g1 = GHC.Types.I# 2#
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+g :: Int -> Int
+g = \ (n :: Int) -> n
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T20138.k1 :: O
+T20138.k1 = T20138.O GHC.Types.LT
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+k :: O -> O
+k = \ (ds :: O) -> ds
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T20138.$trModule4 :: GHC.Prim.Addr#
+T20138.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T20138.$trModule3 :: GHC.Types.TrName
+T20138.$trModule3 = GHC.Types.TrNameS T20138.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T20138.$trModule2 :: GHC.Prim.Addr#
+T20138.$trModule2 = "T20138"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T20138.$trModule1 :: GHC.Types.TrName
+T20138.$trModule1 = GHC.Types.TrNameS T20138.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T20138.$trModule :: GHC.Types.Module
+T20138.$trModule
+ = GHC.Types.Module T20138.$trModule3 T20138.$trModule1
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep :: GHC.Types.KindRep
+$krep
+ = GHC.Types.KindRepTyConApp
+ GHC.Types.$tcOrdering (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T20138.$tcO2 :: GHC.Prim.Addr#
+T20138.$tcO2 = "O"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T20138.$tcO1 :: GHC.Types.TrName
+T20138.$tcO1 = GHC.Types.TrNameS T20138.$tcO2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T20138.$tcO :: GHC.Types.TyCon
+T20138.$tcO
+ = GHC.Types.TyCon
+ 1145581556550476387#Word64
+ 1434093014026668163#Word64
+ T20138.$trModule
+ T20138.$tcO1
+ 0#
+ GHC.Types.krep$*
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep1 :: GHC.Types.KindRep
+$krep1
+ = GHC.Types.KindRepTyConApp
+ T20138.$tcO (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T20138.$tc'O1 :: GHC.Types.KindRep
+T20138.$tc'O1 = GHC.Types.KindRepFun $krep $krep1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T20138.$tc'O3 :: GHC.Prim.Addr#
+T20138.$tc'O3 = "'O"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T20138.$tc'O2 :: GHC.Types.TrName
+T20138.$tc'O2 = GHC.Types.TrNameS T20138.$tc'O3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T20138.$tc'O :: GHC.Types.TyCon
+T20138.$tc'O
+ = GHC.Types.TyCon
+ 12109796057866694799#Word64
+ 5332816606609293872#Word64
+ T20138.$trModule
+ T20138.$tc'O2
+ 0#
+ T20138.$tc'O1
+
+-- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0}
+h :: Int -> Int
+h = \ (n :: Int) ->
+ case n of wild { GHC.Types.I# ds ->
+ case ds of {
+ __DEFAULT -> wild;
+ 2# -> GHC.Base.maxInt
+ }
+ }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -368,6 +368,7 @@ test('T19780', normal, compile, ['-O2'])
test('T19794', normal, compile, ['-O'])
test('T19890', [ grep_errmsg(r'= T19890.foo1') ], compile, ['-O -ddump-simpl'])
test('T20125', [ grep_errmsg(r'= T20125.MkT') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
+test('T20138', [ grep_errmsg(r'(^g|^k|maxInt)') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-idinfo'])
test('T20143', [ grep_errmsg(r'unsafeEqualityProof') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
test('T20174', normal, compile, [''])
test('T16373', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8072fe6ddc9996dd0dab61c3392c1b1d81d6a713...b23123936ae3b935c2ae097ecabc79abe11153e4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8072fe6ddc9996dd0dab61c3392c1b1d81d6a713...b23123936ae3b935c2ae097ecabc79abe11153e4
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230604/ecc25f73/attachment-0001.html>
More information about the ghc-commits
mailing list