[Git][ghc/ghc][wip/simplifier-tweaks] Optimise every time we do mkTransCo
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jun 30 21:48:19 UTC 2023
Simon Peyton Jones pushed to branch wip/simplifier-tweaks at Glasgow Haskell Compiler / GHC
Commits:
ce6e6c6f by Simon Peyton Jones at 2023-06-30T22:47:56+01:00
Optimise every time we do mkTransCo
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.Core.Opt.Simplify.Env (
getInScope, setInScopeFromE, setInScopeFromF,
setInScopeSet, modifyInScope, addNewInScopeIds,
getSimplRules, enterRecGroupRHSs,
+ bumpCallDepth, reSimplifying,
-- * Substitution results
SimplSR(..), mkContEx, substId, lookupRecBndr,
@@ -61,28 +62,31 @@ import GHC.Core.Utils
import GHC.Core.Multiplicity ( scaleScaled )
import GHC.Core.Unfold
import GHC.Core.TyCo.Subst (emptyIdSubstEnv)
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Data.OrdList
-import GHC.Data.Graph.UnVar
-import GHC.Types.Id as Id
import GHC.Core.Make ( mkWildValBinder, mkCoreLet )
-import GHC.Builtin.Types
-import qualified GHC.Core.Type as Type
import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo
, extendTvSubst, extendCvSubst )
import qualified GHC.Core.Coercion as Coercion
import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )
-import GHC.Core.Coercion.Opt( OptCoercionOpts(..) )
-import GHC.Platform ( Platform )
+import qualified GHC.Core.Type as Type
+
+import GHC.Types.Var
+import GHC.Types.Var.Env
+import GHC.Types.Var.Set
+import GHC.Types.Id as Id
import GHC.Types.Basic
+import GHC.Types.Unique.FM ( pprUniqFM )
+
+import GHC.Builtin.Types
+
+import GHC.Data.OrdList
+import GHC.Data.Graph.UnVar
+import GHC.Platform ( Platform )
+
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
-import GHC.Types.Unique.FM ( pprUniqFM )
import Data.List ( intersperse, mapAccumL )
@@ -182,6 +186,8 @@ data SimplEnv
, seInScope :: !InScopeSet -- OutVars only
, seCaseDepth :: !Int -- Depth of multi-branch case alternatives
+ , seCallDepth :: !Int -- 0 initially, 1 when we inline an already-simplified
+ -- unfolding, and simplify again; and so on
}
seArityOpts :: SimplEnv -> ArityOpts
@@ -496,7 +502,8 @@ mkSimplEnv mode fam_envs
, seCvSubst = emptyVarEnv
, seIdSubst = emptyVarEnv
, seRecIds = emptyUnVarSet
- , seCaseDepth = 0 }
+ , seCaseDepth = 0
+ , seCallDepth = 0 }
-- The top level "enclosing CC" is "SUBSUMED".
init_in_scope :: InScopeSet
@@ -532,6 +539,12 @@ updMode upd env
bumpCaseDepth :: SimplEnv -> SimplEnv
bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }
+bumpCallDepth :: SimplEnv -> SimplEnv
+bumpCallDepth env = env { seCallDepth = seCallDepth env + 1 }
+
+reSimplifying :: SimplEnv -> Bool
+reSimplifying (SimplEnv { seCallDepth = n }) = n>0
+
---------------------
extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
@@ -617,11 +630,9 @@ setInScopeFromE.
---------------------
zapSubstEnv :: SimplEnv -> SimplEnv
-zapSubstEnv env@(SimplEnv { seMode = mode })
+zapSubstEnv env@(SimplEnv { seMode = mode, seCallDepth = n })
= env { seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv
- , seMode = mode { sm_co_opt_opts = OptCoercionOpts False } }
- -- Zapping coercion optimisation here saves a /lot/ in T18223;
- -- reduces compiled time allocation by more than 50%
+ , seCallDepth = n+1 }
setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -18,7 +18,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.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst )
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Inline
@@ -1334,7 +1334,10 @@ simplCoercionF env co cont
simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion env co
- = do { let opt_co = optCoercion opts (getSubst env) co
+ = do { let opt_co | reSimplifying env
+ = substCo env co
+ | otherwise
+ = optCoercion opts (getSubst env) co
; seqCo opt_co `seq` return opt_co }
where
opts = seOptCoercionOpts env
@@ -1615,6 +1618,9 @@ simplCast env body co0 cont0
else addCoerce co1 cont0
; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
where
+ empty_subst = mkEmptySubst (seInScope env)
+ opts = seOptCoercionOpts env
+
-- If the first parameter is MRefl, then simplifying revealed a
-- reflexive coercion. Omit.
addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont
@@ -1623,10 +1629,10 @@ simplCast env body co0 cont0
addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont
addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity]
- | isReflexiveCo co' = return cont
- | otherwise = addCoerce co' cont
+ | isReflCo co' = return cont
+ | otherwise = addCoerce co' cont
where
- co' = mkTransCo co1 co2
+ co' = optCoercion opts empty_subst (mkTransCo co1 co2)
addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
| Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce6e6c6f9bced132be8e01f65116414fe69906b8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce6e6c6f9bced132be8e01f65116414fe69906b8
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/20230630/243e2680/attachment-0001.html>
More information about the ghc-commits
mailing list