[Git][ghc/ghc][wip/T20138] CSE: Combine identical LitAlts
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Sun Jun 4 09:31:28 UTC 2023
Sebastian Graf pushed to branch wip/T20138 at Glasgow Haskell Compiler / GHC
Commits:
8072fe6d by Sebastian Graf at 2023-06-04T11:19:11+02:00
CSE: Combine identical LitAlts
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/CSE.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/CSE.hs
=====================================
@@ -17,7 +17,7 @@ import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding
, isJoinId, isJoinId_maybe, idUnfolding )
import GHC.Core.Utils ( mkAltExpr
, exprIsTickedString
- , stripTicksE, stripTicksT, mkTicks )
+ , stripTicksE, stripTicksT, mkTicks, exprIsTrivial )
import GHC.Core.FVs ( exprFreeVars )
import GHC.Core.Type ( tyConAppArgs )
import GHC.Core
@@ -702,7 +702,7 @@ cseExpr :: CSEnv -> InExpr -> OutExpr
cseExpr env (Type t) = Type (substTyUnchecked (csEnvSubst env) t)
cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
cseExpr _ (Lit lit) = Lit lit
-cseExpr env (Var v) = lookupSubst env v
+cseExpr env (Var v) = cseVar env v
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
cseExpr env (Tick t e) = Tick t (cseExpr env e)
cseExpr env (Cast e co) = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)
@@ -712,6 +712,16 @@ cseExpr env (Let bind e) = let (env', bind') = cseBind NotTopLevel env
in Let bind' (cseExpr env' e)
cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
+cseVar :: CSEnv -> InVar -> OutExpr
+cseVar env v
+ | isId v, let unf = idUnfolding v
+ , Just tmpl <- maybeUnfoldingTemplate unf
+ , let e = tryForCSE env tmpl
+ , exprIsTrivial e
+ = e
+ | otherwise
+ = lookupSubst env v
+
cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
cseCase env scrut bndr ty alts
= Case scrut1 bndr3 ty' $
@@ -735,17 +745,14 @@ cseCase env scrut bndr ty alts
arg_tys = tyConAppArgs (idType bndr3)
-- See Note [CSE for case alternatives]
- cse_alt (Alt (DataAlt con) args rhs)
- = Alt (DataAlt con) args' (tryForCSE new_env rhs)
- where
- (env', args') = addBinders alt_env args
- new_env = extendCSEnv env' con_expr con_target
- con_expr = mkAltExpr (DataAlt con) args' arg_tys
-
- cse_alt (Alt con args rhs)
- = Alt con args' (tryForCSE env' rhs)
+ cse_alt (Alt alt_con args rhs)
+ = Alt alt_con args' (tryForCSE new_env rhs)
where
(env', args') = addBinders alt_env args
+ new_env
+ | DEFAULT <- alt_con = alt_env
+ | otherwise = extendCSEnv env' con_expr con_target
+ con_expr = mkAltExpr alt_con args' arg_tys
combineAlts :: [OutAlt] -> [OutAlt]
-- See Note [Combine case alternatives]
=====================================
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/-/commit/8072fe6ddc9996dd0dab61c3392c1b1d81d6a713
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8072fe6ddc9996dd0dab61c3392c1b1d81d6a713
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/35a3e2f6/attachment-0001.html>
More information about the ghc-commits
mailing list