Simon Peyton Jones pushed to branch wip/T27737 at Glasgow Haskell Compiler / GHC Commits: 4ae4a61b by Simon Peyton Jones at 2026-10-28T10:28:12+00:00 Simplifier: fix in-scope-set leak from lambda RHSs; drop LetFloats synonym * simpl_lam rebuilt with env', whose in-scope set contains the lambda binders, so the (usually empty) floats it returned carried an over-approximate in-scope set. Now it rebuilds with env. * doFloatFromRhs returns Nothing when there is nothing to float, as it did before the recent refactoring, so prepareBinding returns (emptyFloats env) rather than the RHS's own empty floats. Without this, simplLazyBind set the in-scope set for completeBind from those floats; re-simplifying an INLINE stable unfolding such as happyIn4 = /\t4..t104. \x -> ... (T14683, Happy-generated) then found all its type variables already in scope, renamed them all, and did a non-empty type substitution over the whole unfolding. Simplifier allocation on T14683 was up 61%; the leaked binders also inflated the in-scope set for the rest of the module, costing 1-4% on many tests (T9233, T13056, T5642, T16577, T9630, T12227, T15703, ...). All gone. * abstractFloats: the substitution's in-scope set must include the type variables being abstracted (they are free in the floats' RHSs); the returned in-scope set is env's extended with the new polymorphic bindings only. Fixes an in-scope assertion failure building haddock-library. * Replace the LetFloats type synonym by OrdList OutBind; remove some commented-out traces in SimpleOpt. Co-Authored-By: Claude Fable 5.1 <noreply@anthropic.com> - - - - - 1db13ad7 by Simon Peyton Jones at 2026-10-28T10:28:49+00:00 Fix two typos in a comment - - - - - 4 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/SimpleOpt.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -43,8 +43,7 @@ module GHC.Core.Opt.Simplify.Env ( extendFloats, isEmptyJoinFloats, doFloatFromRhs, getTopFloatBinds, - -- * LetFloats - LetFloats, FloatEnable(..), emptyLetFloats, mapLetFloats, + FloatEnable(..), mapLetFloats, -- * JoinFloats JoinFloat, JoinFloats, emptyJoinFloats, @@ -452,8 +451,8 @@ isEmptyFloats :: SimplFloats -> Bool -- Precondition: used only when sfJoins is empty isEmptyFloats (SimplFloats { sfBinds = fs , sfJoins = js }) - = assertPpr (isNilOL js) (ppr js ) $ - isNilOL fs + = assertPpr (isEmptyJoinFloats js) (ppr js ) $ + isEmptyFloatBinds fs pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective @@ -738,7 +737,7 @@ setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst {- ************************************************************************ * * -\subsection{LetFloats} +\subsection{Floats} * * ************************************************************************ @@ -891,15 +890,13 @@ let-bindings that can, and wrap the rest back around the RHS. We tried this difference to compile time, so we did not keep it. -} -type LetFloats = OrdList OutBind - -- Let-bindings only: no case-floats or tick-floats - -- Invariant: every binding satisfies the let-can-float invariant - type JoinFloat = OutBind type JoinFloats = OrdList JoinFloat doFloatFromRhs :: SimplEnv -> TopLevelFlag -> RecFlag - -> SimplFloats -> LetFloats + -> SimplFloats + -> OrdList OutBind -- Let-bindings only (from prepareRhs); they + -- satisfy the let-can-float invariant -> OutExpr -> Maybe SimplFloats -- Contains let-bindings only -- See Note [doFloatFromRhs] @@ -908,10 +905,11 @@ doFloatFromRhs :: SimplEnv -> TopLevelFlag -> RecFlag -- -- If you change this function look also at FloatIn.noFloatIntoRhs doFloatFromRhs env lvl rec floats anf_lets rhs - | not float_enabled = Nothing - | not want_to_float = Nothing - | not can_float = Nothing - | otherwise = Just new_floats + | isNilOL fs, isNilOL anf_lets = Nothing -- Short cut only + | not float_enabled = Nothing + | not want_to_float = Nothing + | not can_float = Nothing + | otherwise = Just new_floats where !(SimplFloats { sfBinds = fs, sfJoins = jfs, sfInScope = in_scope }) = floats new_floats = assertPpr (isNilOL jfs) (ppr jfs) $ @@ -952,9 +950,6 @@ doFloatFromRhs env lvl rec floats anf_lets rhs FloatNestedOnly -> not (isTopLevel lvl) FloatEnabled -> True -emptyLetFloats :: LetFloats -emptyLetFloats = nilOL - emptyJoinFloats :: JoinFloats emptyJoinFloats = nilOL @@ -1023,11 +1018,11 @@ extendFloats floats@(SimplFloats { sfJoins = jfloats, sfInScope = in_scope }) bi | otherwise = floats `addLetFloat` bind -addLetFloats :: SimplFloats -> LetFloats -> SimplFloats +addLetFloats :: SimplFloats -> OrdList OutBind -> SimplFloats -- Add the let-bindings /inside/ the existing floats, -- and extend the in-scope set --- No need for addLetFloat's needsCaseBinding test: LetFloats satisfy the --- let-can-float invariant (see the declaration of LetFloats) +-- Precondition: the bindings satisfy the let-can-float invariant, +-- so there is no need for addLetFloat's needsCaseBinding test addLetFloats floats binds = foldlOL add floats binds where add fs bind = assertPpr (okLetFloat bind) (ppr bind) $ @@ -1091,7 +1086,7 @@ addJoinFlts = appOL mkRecFloats :: SimplFloats -> SimplFloats -- Flattens the floats into a single Rec group, --- They must either all be lifted LetFloats or all JoinFloats +-- They must either all be lifted let-floats or all JoinFloats mkRecFloats floats@(SimplFloats { sfBinds = bs , sfJoins = jbs , sfInScope = in_scope }) @@ -1125,7 +1120,7 @@ getTopFloatBinds floats@(SimplFloats { sfJoins = jbs }) letFloatBinds floats {-# INLINE mapLetFloats #-} -mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats +mapLetFloats :: OrdList OutBind -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> OrdList OutBind mapLetFloats binds fun = binds1 where ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -64,7 +64,7 @@ import GHC.Builtin.WiredIn.Ids( seqId ) import qualified GHC.Data.List.Infinite as Inf import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString -import GHC.Data.OrdList ( unitOL, isNilOL, appOL, snocOL ) +import GHC.Data.OrdList ( OrdList, nilOL, unitOL, isNilOL, appOL, snocOL ) import GHC.Unit.Module ( moduleName ) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -764,7 +764,7 @@ prepareRhs :: HasDebugCallStack => SimplEnvIS -> TopLevelFlag -> FastString -- Base for any new variables -> OutExpr - -> SimplM (LetFloats, OutExpr) + -> SimplM (OrdList OutBind, OutExpr) -- Transforms a RHS into a better RHS by ANF'ing args -- for expandable RHSs: constructors and PAPs -- e.g x = Just e @@ -773,7 +773,7 @@ prepareRhs :: HasDebugCallStack -- See Note [prepareRhs] prepareRhs env top_lvl occ rhs0 | is_expandable = anfise rhs0 - | otherwise = return (emptyLetFloats, rhs0) + | otherwise = return (nilOL, rhs0) where -- We can't use exprIsExpandable because the WHOLE POINT is that -- we want to treat (K <big>) as expandable, because we are just @@ -789,7 +789,7 @@ prepareRhs env top_lvl occ rhs0 go (Tick _ rhs) n_val_args = go rhs n_val_args go _ _ = False - anfise :: OutExpr -> SimplM (LetFloats, OutExpr) + anfise :: OutExpr -> SimplM (OrdList OutBind, OutExpr) anfise (Cast rhs co) = do { (floats, rhs') <- anfise rhs ; return (floats, Cast rhs' co) } @@ -801,7 +801,7 @@ prepareRhs env top_lvl occ rhs0 ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg ; return (floats1 `appOL` floats2, App fun' arg') } anfise (Var fun) - = return (emptyLetFloats, Var fun) + = return (nilOL, Var fun) anfise (Tick t rhs) -- We want to be able to float bindings past this tick. @@ -819,28 +819,28 @@ prepareRhs env top_lvl occ rhs0 floats' = mapLetFloats floats tickIt ; return (floats', Tick t rhs') } - anfise other = return (emptyLetFloats, other) + anfise other = return (nilOL, other) makeTrivialArg :: HasDebugCallStack => SimplEnvIS -> ArgSpec - -> SimplM (LetFloats, ArgSpec) + -> SimplM (OrdList OutBind, ArgSpec) makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e ; return (floats, arg { as_arg = e' }) } makeTrivialArg _ arg@(TyArg {}) - = return (emptyLetFloats, arg) + = return (nilOL, arg) makeTrivial :: HasDebugCallStack => SimplEnvIS -> TopLevelFlag -> Demand -> FastString -- ^ A "friendly name" to build the new binder from -> OutExpr - -> SimplM (LetFloats, OutExpr) + -> SimplM (OrdList OutBind, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] makeTrivial env top_lvl dmd occ_fs expr | exprIsTrivial expr -- Already trivial || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise -- See Note [Cannot trivialise] - = return (emptyLetFloats, expr) + = return (nilOL, expr) | Cast expr' co <- expr = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' @@ -889,7 +889,7 @@ into and thence, by floating, into z = f y x = Just z -so that x is bound to a value. It returns only let-bindings (LetFloats), so +so that x is bound to a value. It returns only let-bindings, so sometimes it cannot trivialise its argument, and must return it unchanged. (CT1) Nested bindings. Suppose that (f y) had type Int#, with a different data @@ -2015,7 +2015,13 @@ simpl_lam env bndr body cont ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs) ; body' <- simplExpr env' inner_body ; new_lam <- rebuildLam env' bndrs' body' cont - ; rebuild env' new_lam cont } + ; rebuild env new_lam cont } + -- Subtle point: rebuild with env, not env': the lambda binders are not in + -- scope outside the lambda, and should not end up in the in-scope set of the + -- floats we return. Why not? Because a too-large in-scope set can lead to + -- gratuitous renaming, and a non-empty substitution makes `substTy` do real + -- work. This happens, for example, if the function has a stable unfolding + -- that uses the same binders, and cost 9% in compile time in T14683. ------------- simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -74,6 +74,7 @@ import GHC.Types.InlinePragma import GHC.Types.Tickish import GHC.Types.Demand import GHC.Types.Var.Set +import GHC.Types.Var.Env ( extendInScopeSetList ) import GHC.Types.Basic import GHC.Types.Name.Env @@ -2518,7 +2519,8 @@ new binding is abstracted. Several points worth noting manifestly a literal string. -} -abstractFloats :: SimplEnv -> TopLevelFlag -> [OutTyVar] +abstractFloats :: SimplEnv -- Env outside the whole binding + -> TopLevelFlag -> [OutTyVar] -> SimplFloats -- Let-bindings only: postcondition of `prepareBinding` -> OutExpr -- The right-hand side of the binding -> SimplM (SimplFloats, OutExpr) @@ -2535,16 +2537,19 @@ abstractFloats env top_lvl main_tvs floats rhs ; return ( SimplFloats { sfBinds = foldr (consOL . FloatLet) nilOL poly_binds , sfJoins = emptyJoinFloats - , sfInScope = substInScopeSet subst } + , sfInScope = foldl' extendInScopeSetBind in_scope poly_binds } , GHC.Core.Subst.substExpr subst rhs) } - -- NB: the returned in-scope set includes `env` and all the + -- NB: the returned in-scope set is the outer `in_scope` and all the -- new floated bindings; but not main_tvs, nor the original floats - -- The caller will used the returned in-scope set to cover the body of the let, - -- and main_tvs and original floats are not in scope there + -- The caller will use the returned in-scope set to cover the body of the let, + -- and `main_tvs` and original floats are not in scope there -- That reduces unnecessary renaming (see !7777 and test T16577) where !(SimplFloats { sfBinds = float_binds, sfJoins = jfs }) = floats - empty_subst = GHC.Core.Subst.mkEmptySubst (seInScope env) + in_scope = seInScope env + empty_subst = GHC.Core.Subst.mkEmptySubst (in_scope `extendInScopeSetList` main_tvs) + -- main_tvs: the RHSs of the floats mention the main_tvs, so they must be + -- in scope for substExpr (the original float binders are in the substitution) is_top_lvl = isTopLevel top_lvl uf_opts = seUnfoldingOpts env ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -1712,8 +1712,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr subst_co (Right s) co = GHC.Core.Subst.substCo s co subst_expr (Left {}) e = e - subst_expr (Right s) e = -- pprTrace "subst_expr" (text "subst" <+> ppr s $$ text "expr" <+> ppr e) $ - substExpr s e + subst_expr (Right s) e = substExpr s e subst_bndrs subst bs = mapAccumL subst_bndr subst bs @@ -1723,8 +1722,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr subst_bndr (Right subst) bndr = subst_bndr1 subst bndr subst_bndr1 subst bndr - = -- pprTrace "subst_bndr1" (ppr bndr <+> ppr bndr' $$ ppr subst) $ - (Right subst', bndr') + = (Right subst', bndr') where (subst', bndr') = substBndr subst bndr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cb78c1aa05e6edf786113b0f3e52fa6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cb78c1aa05e6edf786113b0f3e52fa6... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help