summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2021-01-12 23:50:23 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-03-20 07:49:50 -0400
commit62b0e1bcc537b415ba969e00a417d6aded94c309 (patch)
treecc0645b050e4d470870cad97a2a59d6150e7afce
parent1f94e0f7601f8e22fdd81a47f130650265a44196 (diff)
downloadhaskell-62b0e1bcc537b415ba969e00a417d6aded94c309.tar.gz
Make the simplifier slightly stricter.
This commit reduces allocations by the simplifier by 3% for the Cabal test at -O2. We do this by making a few select fields, bindings and arguments strict which reduces allocations for the simplifier by around 3% in total for the Cabal test. Which is about 2% fewer allocations in total at -O2. ------------------------- Metric Decrease: T18698a T18698b T9233 T9675 T9872a T9872b T9872c T9872d T10421 T12425 T13253 T5321FD T9961 -------------------------
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs80
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Env.hs72
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Utils.hs8
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs5
-rw-r--r--compiler/GHC/Data/OrdList.hs17
5 files changed, 133 insertions, 49 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index c531da6050..701573a55d 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -167,6 +167,38 @@ It's quite convenient. This way we don't need to manipulate the substitution all
the time: every update to a binder is automatically reflected to its bound
occurrences.
+Note [Bangs in the Simplifier]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Both SimplFloats and SimplEnv do *not* generally benefit from making
+their fields strict. I don't know if this is because of good use of
+laziness or unintended side effects like closures capturing more variables
+after WW has run.
+
+But the end result is that we keep these lazy, but force them in some places
+where we know it's beneficial to the compiler.
+
+Similarly environments returned from functions aren't *always* beneficial to
+force. In some places they would never be demanded so forcing them early
+increases allocation. In other places they almost always get demanded so
+it's worthwhile to force them early.
+
+Would it be better to through every allocation of e.g. SimplEnv and decide
+wether or not to make this one strict? Absolutely! Would be a good use of
+someones time? Absolutely not! I made these strict that showed up during
+a profiled build or which I noticed while looking at core for one reason
+or another.
+
+The result sadly is that we end up with "random" bangs in the simplifier
+where we sometimes force e.g. the returned environment from a function and
+sometimes we don't for the same function. Depending on the context around
+the call. The treatment is also not very consistent. I only added bangs
+where I saw it making a difference either in the core or benchmarks. Some
+patterns where it would be beneficial aren't convered as a consequence as
+I neither have the time to go through all of the core and some cases are
+too small to show up in benchmarks.
+
+
+
************************************************************************
* *
\subsection{Bindings}
@@ -182,7 +214,8 @@ simplTopBinds env0 binds0
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
-- See note [Glomming] in "GHC.Core.Opt.OccurAnal".
- ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)
+ -- See Note [Bangs in the Simplifier]
+ ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)
; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0
; freeTick SimplifierDone
; return (floats, env2) }
@@ -195,7 +228,9 @@ simplTopBinds env0 binds0
simpl_binds env [] = return (emptyFloats env, env)
simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind
; (floats, env2) <- simpl_binds env1 binds
- ; return (float `addFloats` floats, env2) }
+ -- See Note [Bangs in the Simplifier]
+ ; let !floats1 = float `addFloats` floats
+ ; return (floats1, env2) }
simpl_bind env (Rec pairs)
= simplRecBind env TopLevel Nothing pairs
@@ -296,7 +331,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= ASSERT( isId bndr )
ASSERT2( not (isJoinId bndr), ppr bndr )
-- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
- do { let rhs_env = rhs_se `setInScopeFromE` env
+ do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]
(tvs, body) = case collectTyAndValBinders rhs of
(tvs, [], body)
| surely_not_lam body -> (tvs, body)
@@ -942,7 +977,7 @@ might do the same again.
-}
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-simplExpr env (Type ty)
+simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]
= do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType]
; return (Type ty') }
@@ -973,7 +1008,7 @@ simplExprF :: SimplEnv
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplExprF env e cont
+simplExprF !env e !cont -- See Note [Bangs in the Simplifier]
= {- pprTrace "simplExprF" (vcat
[ ppr e
, text "cont =" <+> ppr cont
@@ -1870,24 +1905,33 @@ outside. Surprisingly tricky!
simplVar :: SimplEnv -> InVar -> SimplM OutExpr
-- Look up an InVar in the environment
simplVar env var
- | isTyVar var = return (Type (substTyVar env var))
- | isCoVar var = return (Coercion (substCoVar env var))
+ -- Why $! ? See Note [Bangs in the Simplifier]
+ | isTyVar var = return $! Type $! (substTyVar env var)
+ | isCoVar var = return $! Coercion $! (substCoVar env var)
| otherwise
= case substId env var of
- ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
+ ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids
+ in simplExpr env' e
DoneId var1 -> return (Var var1)
DoneEx e _ -> return e
simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
simplIdF env var cont
= case substId env var of
- ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
- -- Don't trim; haven't already simplified e,
- -- so the cont is not embodied in e
-
- DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)
-
- DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)
+ ContEx tvs cvs ids e ->
+ let env' = setSubstEnv env tvs cvs ids
+ in simplExprF env' e cont
+ -- Don't trim; haven't already simplified e,
+ -- so the cont is not embodied in e
+
+ DoneId var1 ->
+ let cont' = trimJoinCont var (isJoinId_maybe var1) cont
+ in completeCall env var1 cont'
+
+ DoneEx e mb_join ->
+ let env' = zapSubstEnv env
+ cont' = trimJoinCont var mb_join cont
+ in simplExprF env' e cont'
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
@@ -1908,12 +1952,14 @@ completeCall env var cont
-- Inline the variable's RHS
= do { checkedTick (UnfoldingDone var)
; dump_inline expr cont
- ; simplExprF (zapSubstEnv env) expr cont }
+ ; let env1 = zapSubstEnv env
+ ; simplExprF env1 expr cont }
| otherwise
-- Don't inline; instead rebuild the call
= do { rule_base <- getSimplRules
- ; let info = mkArgInfo env var (getRules rule_base var)
+ ; let rules = getRules rule_base var
+ info = mkArgInfo env var rules
n_val_args call_cont
; rebuildCall env info cont }
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 1bfa38e481..d1b33b0290 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -90,7 +90,7 @@ data SimplEnv
-- Static in the sense of lexically scoped,
-- wrt the original expression
- seMode :: SimplMode
+ seMode :: !SimplMode
-- The current substitution
, seTvSubst :: TvSubstEnv -- InTyVar |--> OutType
@@ -103,7 +103,7 @@ data SimplEnv
-- The current set of in-scope variables
-- They are all OutVars, and all bound in this module
- , seInScope :: InScopeSet -- OutVars only
+ , seInScope :: !InScopeSet -- OutVars only
, seCaseDepth :: !Int -- Depth of multi-branch case alternatives
}
@@ -325,7 +325,10 @@ setMode :: SimplMode -> SimplEnv -> SimplEnv
setMode mode env = env { seMode = mode }
updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
-updMode upd env = env { seMode = upd (seMode env) }
+updMode upd env
+ = -- Avoid keeping env alive in case inlining fails.
+ let mode = upd $! (seMode env)
+ in env { seMode = mode }
bumpCaseDepth :: SimplEnv -> SimplEnv
bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }
@@ -363,8 +366,12 @@ setInScopeFromF env floats = env { seInScope = sfInScope floats }
addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
-- The new Ids are guaranteed to be freshly allocated
addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
- = env { seInScope = in_scope `extendInScopeSetList` vs,
- seIdSubst = id_subst `delVarEnvList` vs }
+-- See Note [Bangs in the Simplifier]
+ = let !in_scope1 = in_scope `extendInScopeSetList` vs
+ !id_subst1 = id_subst `delVarEnvList` vs
+ in
+ env { seInScope = in_scope1,
+ seIdSubst = id_subst1 }
-- Why delete? Consider
-- let x = a*b in (x, \x -> x+3)
-- We add [x |-> a*b] to the substitution, but we must
@@ -544,8 +551,8 @@ mkFloatBind env bind
= SimplFloats { sfLetFloats = unitLetFloat bind
, sfJoinFloats = emptyJoinFloats
, sfInScope = in_scope' }
-
- in_scope' = seInScope env `extendInScopeSetBind` bind
+ -- See Note [Bangs in the Simplifier]
+ !in_scope' = seInScope env `extendInScopeSetBind` bind
extendFloats :: SimplFloats -> OutBind -> SimplFloats
-- Add this binding to the floats, and extend the in-scope env too
@@ -616,10 +623,11 @@ mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff
, sfJoinFloats = jfloats'
, sfInScope = in_scope }
where
- floats' | isNilOL bs = emptyLetFloats
- | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs)))
- jfloats' | isNilOL jbs = emptyJoinFloats
- | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
+ -- See Note [Bangs in the Simplifier]
+ !floats' | isNilOL bs = emptyLetFloats
+ | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs)))
+ !jfloats' | isNilOL jbs = emptyJoinFloats
+ | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
wrapFloats :: SimplFloats -> OutExpr -> OutExpr
-- Wrap the floats around the expression; they should all
@@ -649,12 +657,14 @@ getTopFloatBinds (SimplFloats { sfLetFloats = lbs
= ASSERT( isNilOL jbs ) -- Can't be any top-level join bindings
letFloatBinds lbs
+{-# INLINE mapLetFloats #-}
mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
mapLetFloats (LetFloats fs ff) fun
- = LetFloats (mapOL app fs) ff
+ = LetFloats fs1 ff
where
app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
- app (Rec bs) = Rec (map fun bs)
+ app (Rec bs) = Rec (strictMap fun bs)
+ !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier]
{-
************************************************************************
@@ -748,7 +758,7 @@ See also Note [Scaling join point arguments].
-}
simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
-simplBinders env bndrs = mapAccumLM simplBinder env bndrs
+simplBinders !env bndrs = mapAccumLM simplBinder env bndrs
-------------
simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
@@ -757,7 +767,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
-- The substitution is extended only if the variable is cloned, because
-- we *don't* need to use it to track occurrence info.
-simplBinder env bndr
+simplBinder !env bndr
| isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
; seqTyVar tv `seq` return (env', tv) }
| otherwise = do { let (env', id) = substIdBndr env bndr
@@ -766,16 +776,18 @@ simplBinder env bndr
---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- A non-recursive let binder
-simplNonRecBndr env id
- = do { let (env1, id1) = substIdBndr env id
+simplNonRecBndr !env id
+ -- See Note [Bangs in the Simplifier]
+ = do { let (!env1, id1) = substIdBndr env id
; seqId id1 `seq` return (env1, id1) }
---------------
simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
-- Recursive let binders
simplRecBndrs env@(SimplEnv {}) ids
+ -- See Note [Bangs in the Simplifier]
= ASSERT(all (not . isJoinId) ids)
- do { let (env1, ids1) = mapAccumL substIdBndr env ids
+ do { let (!env1, ids1) = mapAccumL substIdBndr env ids
; seqIds ids1 `seq` return env1 }
@@ -810,6 +822,10 @@ substNonCoVarIdBndr
-- all fragile info is zapped
substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x)
+-- Inline to make the (OutId -> OutId) function a known call.
+-- This is especially important for `substNonCoVarIdBndr` which
+-- passes an identity lambda.
+{-# INLINE subst_id_bndr #-}
subst_id_bndr :: SimplEnv
-> InBndr -- Env and binder to transform
-> (OutId -> OutId) -- Adjust the type
@@ -817,7 +833,7 @@ subst_id_bndr :: SimplEnv
subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
old_id adjust_type
= ASSERT2( not (isCoVar old_id), ppr old_id )
- (env { seInScope = in_scope `extendInScopeSet` new_id,
+ (env { seInScope = new_in_scope,
seIdSubst = new_subst }, new_id)
-- It's important that both seInScope and seIdSubst are updated with
-- the new_id, /after/ applying adjust_type. That's why adjust_type
@@ -825,20 +841,23 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
-- place that gives a non-identity adjust_type) we'd have to fiddle
-- afresh with both seInScope and seIdSubst
where
- id1 = uniqAway in_scope old_id
- id2 = substIdType env id1
- id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
+ -- See Note [Bangs in the Simplifier]
+ !id1 = uniqAway in_scope old_id
+ !id2 = substIdType env id1
+ !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
-- and fragile OccInfo
- new_id = adjust_type id3
+ !new_id = adjust_type id3
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
-- See the notes with substTyVarBndr for the delSubstEnv
- new_subst | new_id /= old_id
+ !new_subst | new_id /= old_id
= extendVarEnv id_subst old_id (DoneId new_id)
| otherwise
= delVarEnv id_subst old_id
+ !new_in_scope = in_scope `extendInScopeSet` new_id
+
------------------------------------
seqTyVar :: TyVar -> ()
seqTyVar b = b `seq` ()
@@ -947,7 +966,7 @@ adjustJoinPointType mult new_res_ty join_id
orig_ar = idJoinArity join_id
orig_ty = idType join_id
- new_join_ty = go orig_ar orig_ty
+ new_join_ty = go orig_ar orig_ty :: Type
go 0 _ = new_res_ty
go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty
@@ -956,7 +975,8 @@ adjustJoinPointType mult new_res_ty join_id
| otherwise
= pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty)
- scale_bndr (Anon af t) = Anon af (scaleScaled mult t)
+ -- See Note [Bangs in the Simplifier]
+ scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t)
scale_bndr b@(Named _) = b
{- Note [Scaling join point arguments]
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 672b0bce72..a14e8b24a9 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1255,15 +1255,15 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
| isExitJoinId bndr = Nothing -- Note [Do not inline exit join points]
-- in module Exitify
| not (one_occ (idOccInfo bndr)) = Nothing
- | not (isStableUnfolding unf) = Just (extend_subst_with rhs)
+ | not (isStableUnfolding unf) = Just $! (extend_subst_with rhs)
-- Note [Stable unfoldings and preInlineUnconditionally]
| not (isInlinePragma inline_prag)
- , Just inl <- maybeUnfoldingTemplate unf = Just (extend_subst_with inl)
+ , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl)
| otherwise = Nothing
where
unf = idUnfolding bndr
- extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)
+ extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
one_occ IAmDead = True -- Happens in ((\x.1) v)
one_occ OneOcc{ occ_n_br = 1
@@ -1942,7 +1942,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
abstract subst (NonRec id rhs)
= do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
- subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
+ !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
; return (subst', NonRec poly_id2 poly_rhs) }
where
rhs' = GHC.Core.Subst.substExpr subst rhs
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 493b2d767a..636dc87405 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -1928,13 +1928,16 @@ GHC.Core.Multiplicity above this module.
-}
-- | A shorthand for data with an attached 'Mult' element (the multiplicity).
-data Scaled a = Scaled Mult a
+data Scaled a = Scaled !Mult a
deriving (Data.Data)
-- You might think that this would be a natural candidate for
-- Functor, Traversable but Krzysztof says (!3674) "it was too easy
-- to accidentally lift functions (substitutions, zonking etc.) from
-- Type -> Type to Scaled Type -> Scaled Type, ignoring
-- multiplicities and causing bugs". So we don't.
+ --
+ -- Being strict in a is worse for performance, so we are only strict on the
+ -- Mult part of scaled.
instance (Outputable a) => Outputable (Scaled a) where
diff --git a/compiler/GHC/Data/OrdList.hs b/compiler/GHC/Data/OrdList.hs
index 510e6f0f15..c3f659cb02 100644
--- a/compiler/GHC/Data/OrdList.hs
+++ b/compiler/GHC/Data/OrdList.hs
@@ -17,13 +17,14 @@ module GHC.Data.OrdList (
OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL,
nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
headOL,
- mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
+ mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
strictlyEqOL, strictlyOrdOL
) where
import GHC.Prelude
import Data.Foldable
+import GHC.Utils.Misc (strictMap)
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -179,6 +180,20 @@ fromOLReverse a = go a []
mapOL :: (a -> b) -> OrdList a -> OrdList b
mapOL = fmap
+mapOL' :: (a->b) -> OrdList a -> OrdList b
+mapOL' _ None = None
+mapOL' f (One x) = One $! f x
+mapOL' f (Cons x xs) = let !x1 = f x
+ !xs1 = mapOL' f xs
+ in Cons x1 xs1
+mapOL' f (Snoc xs x) = let !x1 = f x
+ !xs1 = mapOL' f xs
+ in Snoc xs1 x1
+mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1
+ !b2' = mapOL' f b2
+ in Two b1' b2'
+mapOL' f (Many xs) = Many $! strictMap f xs
+
foldrOL :: (a->b->b) -> b -> OrdList a -> b
foldrOL _ z None = z
foldrOL k z (One x) = k x z