[Git][ghc/ghc][wip/andreask/opt-bindersof] Avoid allocating intermediate lists for non recursive bindings.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Mon Sep 26 22:57:16 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/opt-bindersof at Glasgow Haskell Compiler / GHC
Commits:
36438646 by Andreas Klebinger at 2022-09-27T00:55:20+02:00
Avoid allocating intermediate lists for non recursive bindings.
We give `Bind` a fold instance that performs better than converting to
a list and folding over that instead.
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,
+ foldBindersOfBindsStrict,
collectBinders, collectTyBinders, collectTyAndValBinders,
collectNBinders, collectNValBinders_maybe,
collectArgs, stripNArgs, collectArgsTicks, flattenBinds,
@@ -120,6 +121,7 @@ import GHC.Utils.Panic.Plain
import Data.Data hiding (TyCon)
import Data.Int
import Data.Word
+import Data.Foldable (Foldable(..))
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
@@ -315,6 +317,26 @@ data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
deriving Data
+instance Foldable Bind where
+ -- We want these to inline if the function is given as argument, so that the function
+ -- arguments will be a known function call.
+ {-# INLINE foldr #-}
+ foldr f = \r bind -> case bind of
+ NonRec b _ -> f b r
+ Rec pairs -> foldr f r . map fst $ pairs
+ {-# INLINE foldl' #-}
+ foldl' f = \r bind -> case bind of
+ NonRec b _ -> f r b
+ Rec pairs -> foldl' f r . map fst $ pairs
+ {-# INLINE foldMap #-}
+ foldMap f = \bind -> case bind of
+ NonRec b _ -> f b
+ Rec pairs -> foldMap f . map fst $ pairs
+ {-# INLINE foldMap' #-}
+ foldMap' f = \bind -> case bind of
+ NonRec b _ -> f b
+ Rec pairs -> foldMap' f . map fst $ pairs
+
{-
Note [Shadowing]
~~~~~~~~~~~~~~~~
@@ -1943,6 +1965,7 @@ exprToType _bad = pprPanic "exprToType" empty
-}
-- | Extract every variable by this group
+-- {-# INLINEABLE bindersOf #-}
bindersOf :: Bind b -> [b]
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism] in GHC.Core.Lint
@@ -1953,6 +1976,11 @@ bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
bindersOfBinds :: [Bind b] -> [b]
bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
+-- We inline this to avoid unknown function calls.
+{-# INLINE foldBindersOfBindsStrict #-}
+foldBindersOfBindsStrict :: (a -> b -> a) -> a -> [Bind b] -> a
+foldBindersOfBindsStrict f = \z binds -> foldl' (foldl' f) z binds
+
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
=====================================
@@ -812,10 +812,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
=====================================
@@ -949,8 +949,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 )
@@ -601,8 +601,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 that can't live elsewhere because of import loops.
+ 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 $ foldl' 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/364386467ae12847e001d5ad6ea6c473fb38e6d6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/364386467ae12847e001d5ad6ea6c473fb38e6d6
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/20220926/23997da0/attachment-0001.html>
More information about the ghc-commits
mailing list