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 files changed, 50 insertions, 14 deletions

diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index c1ed8d741d..7a979554e2 100644
--- a/compiler/GHC/Core.hs
+++ b/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]
diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs
index b8ba685a5e..7946f9f17b 100644
--- a/compiler/GHC/Core/Opt/Exitify.hs
+++ b/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
 
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index 1d811b12cf..168e0a1dd3 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/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
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index f56ebe4870..26dda50d4f 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/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
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index da4832c153..0dd84fdf99 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/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,
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 2fc6605d9e..ff974f9766 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/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 }
 
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index d971f1ab1b..02cd2bf8af 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/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,
 
@@ -2339,6 +2342,26 @@ 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
+
+{-
+*****************************************************
+*
 * StaticPtr
 *
 *****************************************************
diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs
index 88f27af415..96ca5d53a6 100644
--- a/compiler/GHC/Types/Var/Env.hs
+++ b/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,