[Git][ghc/ghc][wip/T25468] Fix in-scope set for CSE
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sun Dec 29 16:52:35 UTC 2024
Simon Peyton Jones pushed to branch wip/T25468 at Glasgow Haskell Compiler / GHC
Commits:
6eedbd71 by Simon Peyton Jones at 2024-12-29T16:51:26+00:00
Fix in-scope set for CSE
Ticket #25468 showed an assertion failure in CSE because a top-level
Id was being used before it was defined. Reason: Note [Glomming] in
GHC.Core.Opt.OccurAnal.
Solution (used in many places): just put all the top-level bindings in
scope at the beginning of CSE.
Compile-time allocation wobbles up and down a tiny bit; geo mean is
zero. But MultiLayerModulesTH_OneShot and hard_hole_fits increase (on
some architectures only) by a bit oever 2% . I think these are just a
random fluctuations.
Metric Increase:
MultiLayerModulesTH_OneShot
hard_hole_fits
- - - - -
2 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/CSE.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -466,8 +466,15 @@ lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs
lintCoreBindings' cfg binds
= initL cfg $
addLoc TopLevelBindings $
- do { checkL (null dups) (dupVars dups)
+ do { -- Check that all top-level binders are distinct
+ -- We do not allow [NonRec x=1, NonRec y=x, NonRec x=2]
+ -- because of glomming; see Note [Glomming] in GHC.Core.Opt.OccurAnal
+ checkL (null dups) (dupVars dups)
+
+ -- Check for External top level binders with the same M.n name
; checkL (null ext_dups) (dupExtVars ext_dups)
+
+ -- Typecheck the bindings
; lintRecBindings TopLevel all_pairs $ \_ ->
return () }
where
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -9,7 +9,7 @@ module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where
import GHC.Prelude
import GHC.Core.Subst
-import GHC.Types.Var.Env ( mkInScopeSet )
+import GHC.Types.Var.Env ( mkInScopeSet, mkInScopeSetList )
import GHC.Types.Id
import GHC.Core.Utils ( mkAltExpr
, exprIsTickedString
@@ -379,14 +379,21 @@ body/rest of the module.
-}
cseProgram :: CoreProgram -> CoreProgram
-cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)
+cseProgram binds
+ = snd (mapAccumL (cseBind TopLevel) init_env binds)
+ where
+ init_env = emptyCSEnv $
+ mkInScopeSetList (bindersOfBinds binds)
+ -- Put all top-level binders into scope; it is possible to have
+ -- forward references. See Note [Glomming] in GHC.Core.Opt.OccurAnal
+ -- Missing this caused #25468
cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)
cseBind toplevel env (NonRec b e)
= (env2, NonRec b2 e2)
where
-- See Note [Separate envs for let rhs and body]
- (env1, b1) = addBinder env b
+ (env1, b1) = addNonRecBinder toplevel env b
(env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1
cseBind toplevel env (Rec [(in_id, rhs)])
@@ -404,7 +411,7 @@ cseBind toplevel env (Rec [(in_id, rhs)])
= (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])
where
- (env1, Identity out_id) = addRecBinders env (Identity in_id)
+ (env1, Identity out_id) = addRecBinders toplevel env (Identity in_id)
rhs' = cseExpr env1 rhs
rhs'' = stripTicksE tickishFloatable rhs'
ticks = stripTicksT tickishFloatable rhs'
@@ -414,7 +421,7 @@ cseBind toplevel env (Rec [(in_id, rhs)])
cseBind toplevel env (Rec pairs)
= (env2, Rec pairs')
where
- (env1, bndrs1) = addRecBinders env (map fst pairs)
+ (env1, bndrs1) = addRecBinders toplevel env (map fst pairs)
(env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)
do_one env (pr, b1) = cse_bind toplevel env env pr b1
@@ -692,7 +699,8 @@ try_for_cse env expr
-- as a convenient entry point for users of the GHC API.
cseOneExpr :: InExpr -> OutExpr
cseOneExpr e = cseExpr env e
- where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }
+ where
+ env = emptyCSEnv (mkInScopeSet (exprFreeVars e))
cseExpr :: CSEnv -> InExpr -> OutExpr
cseExpr env (Type t) = Type (substTyUnchecked (csEnvSubst env) t)
@@ -858,9 +866,11 @@ data CSEnv
-- See Note [CSE for recursive bindings]
}
-emptyCSEnv :: CSEnv
-emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap
- , cs_subst = emptySubst }
+emptyCSEnv :: InScopeSet -> CSEnv
+emptyCSEnv in_scope
+ = CS { cs_map = emptyCoreMap
+ , cs_rec_map = emptyCoreMap
+ , cs_subst = mkEmptySubst in_scope }
lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
lookupCSEnv (CS { cs_map = csmap }) expr
@@ -905,8 +915,19 @@ addBinders cse vs = (cse { cs_subst = sub' }, vs')
where
(sub', vs') = substBndrs (cs_subst cse) vs
-addRecBinders :: Traversable f => CSEnv -> f Id -> (CSEnv, f Id)
-addRecBinders = \ cse vs ->
- let (sub', vs') = substRecBndrs (cs_subst cse) vs
- in (cse { cs_subst = sub' }, vs')
+addNonRecBinder :: TopLevelFlag -> CSEnv -> Var -> (CSEnv, Var)
+-- Don't clone at top level
+addNonRecBinder top_lvl cse v
+ | isTopLevel top_lvl = (cse, v)
+ | otherwise = (cse { cs_subst = sub' }, v')
+ where
+ (sub', v') = substBndr (cs_subst cse) v
+
+addRecBinders :: Traversable f => TopLevelFlag -> CSEnv -> f Id -> (CSEnv, f Id)
+-- Don't clone at top level
+addRecBinders top_lvl cse vs
+ | isTopLevel top_lvl = (cse, vs)
+ | otherwise = (cse { cs_subst = sub' }, vs')
+ where
+ (sub', vs') = substRecBndrs (cs_subst cse) vs
{-# INLINE addRecBinders #-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eedbd71b56c18fd3724868d17271afaac44e75a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eedbd71b56c18fd3724868d17271afaac44e75a
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/20241229/81acf85f/attachment-0001.html>
More information about the ghc-commits
mailing list