[Git][ghc/ghc][master] Avoid allocating intermediate lists for non recursive bindings.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Oct 17 23:21:46 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
08ab5419 by Andreas Klebinger at 2022-10-17T19:21:15-04:00
Avoid allocating intermediate lists for non recursive bindings.
We do so by having an explicit folding function that doesn't need to
allocate intermediate lists first.
Fixes #22196
- - - - -
8 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Types/Var/Env.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -42,6 +42,7 @@ module GHC.Core (
-- ** Simple 'Expr' access functions and predicates
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
+ foldBindersOfBindStrict, foldBindersOfBindsStrict,
collectBinders, collectTyBinders, collectTyAndValBinders,
collectNBinders, collectNValBinders_maybe,
collectArgs, stripNArgs, collectArgsTicks, flattenBinds,
@@ -1926,6 +1927,21 @@ bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
bindersOfBinds :: [Bind b] -> [b]
bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
+-- We inline this to avoid unknown function calls.
+{-# INLINE foldBindersOfBindStrict #-}
+foldBindersOfBindStrict :: (a -> b -> a) -> a -> Bind b -> a
+foldBindersOfBindStrict f
+ = \z bind -> case bind of
+ NonRec b _rhs -> f z b
+ Rec pairs -> foldl' f z $ map fst pairs
+
+{-# INLINE foldBindersOfBindsStrict #-}
+foldBindersOfBindsStrict :: (a -> b -> a) -> a -> [Bind b] -> a
+foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds
+ where
+ fold_bind = (foldBindersOfBindStrict f)
+
+
rhssOfBind :: Bind b -> [Expr b]
rhssOfBind (NonRec _ rhs) = [rhs]
rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -62,7 +62,7 @@ exitifyProgram binds = map goTopLvl binds
goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)
-- Top-level bindings are never join points
- in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds
+ in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds
go :: InScopeSet -> CoreExpr -> CoreExpr
go _ e@(Var{}) = e
@@ -94,7 +94,7 @@ exitifyProgram binds = map goTopLvl binds
| otherwise = Let (Rec pairs') body'
where
is_join_rec = any (isJoinId . fst) pairs
- in_scope' = in_scope `extendInScopeSetList` bindersOf (Rec pairs)
+ in_scope' = in_scope `extendInScopeSetBind` (Rec pairs)
pairs' = mapSnd (go in_scope') pairs
body' = go in_scope' body
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -82,7 +82,7 @@ import GHC.Core.Utils ( exprType, exprIsHNF
, exprOkForSpeculation
, exprIsTopLevelBindable
, collectMakeStaticArgs
- , mkLamTypes
+ , mkLamTypes, extendInScopeSetBndrs
)
import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr )
import GHC.Core.FVs -- all of it
@@ -1566,7 +1566,7 @@ initialEnv float_lams binds
, le_subst = mkEmptySubst in_scope_toplvl
, le_env = emptyVarEnv }
where
- in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds
+ in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds
-- The Simplifier (see Note [Glomming] in GHC.Core.Opt.OccurAnal) and
-- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise)
-- may both produce top-level bindings where an early binding refers
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -815,10 +815,6 @@ addJoinFloats floats join_floats
, sfInScope = foldlOL extendInScopeSetBind
(sfInScope floats) join_floats }
-extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
-extendInScopeSetBind in_scope bind
- = extendInScopeSetList in_scope (bindersOf bind)
-
addFloats :: SimplFloats -> SimplFloats -> SimplFloats
-- Add both let-floats and join-floats for env2 to env1;
-- *plus* the in-scope set for env2, which is bigger
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -952,8 +952,7 @@ initScEnv guts
sc_vals = emptyVarEnv,
sc_annotations = anns }) }
where
- init_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet $
- bindersOfBinds (mg_binds guts)
+ init_subst = mkEmptySubst $ mkInScopeSetBndrs (mg_binds guts)
-- Acccount for top-level bindings that are not in dependency order;
-- see Note [Glomming] in GHC.Core.Opt.OccurAnal
-- Easiest thing is to bring all the top level binders into scope at once,
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -28,7 +28,7 @@ import GHC.Core
import GHC.Core.Rules
import GHC.Core.Utils ( exprIsTrivial
, mkCast, exprType
- , stripTicksTop )
+ , stripTicksTop, mkInScopeSetBndrs )
import GHC.Core.FVs
import GHC.Core.TyCo.Rep (TyCoBinder (..))
import GHC.Core.Opt.Arity( collectBindersPushingCo )
@@ -603,8 +603,10 @@ specProgram guts@(ModGuts { mg_module = this_mod
-- accidentally re-use a unique that's already in use
-- Easiest thing is to do it all at once, as if all the top-level
-- decls were mutually recursive
- ; let top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSetList $
- bindersOfBinds binds
+ ; let top_env = SE { se_subst = Core.mkEmptySubst $
+ mkInScopeSetBndrs binds
+ -- mkInScopeSetList $
+ -- bindersOfBinds binds
, se_module = this_mod
, se_dflags = dflags }
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -47,6 +47,9 @@ module GHC.Core.Utils (
stripTicksTop, stripTicksTopE, stripTicksTopT,
stripTicksE, stripTicksT,
+ -- * InScopeSet things which work over CoreBinds
+ mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs,
+
-- * StaticPtr
collectMakeStaticArgs,
@@ -2336,6 +2339,26 @@ normSplitTyConApp_maybe fam_envs ty
= Just (tc, tc_args, co)
normSplitTyConApp_maybe _ _ = Nothing
+{-
+*****************************************************
+*
+* InScopeSet things
+*
+*****************************************************
+-}
+
+
+extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
+extendInScopeSetBind (InScope in_scope) binds
+ = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds
+
+extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet
+extendInScopeSetBndrs (InScope in_scope) binds
+ = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds
+
+mkInScopeSetBndrs :: [CoreBind] -> InScopeSet
+mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds
+
{-
*****************************************************
*
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -47,7 +47,7 @@ module GHC.Types.Var.Env (
anyDVarEnv,
-- * The InScopeSet type
- InScopeSet,
+ InScopeSet(..),
-- ** Operations on InScopeSets
emptyInScopeSet, mkInScopeSet, mkInScopeSetList, delInScopeSet,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/08ab5419286d2620f2e6762607bad03c5bcd29ad
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/08ab5419286d2620f2e6762607bad03c5bcd29ad
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/20221017/9be89b35/attachment-0001.html>
More information about the ghc-commits
mailing list