[Git][ghc/ghc][master] Fix in-scope set for CSE

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sun Dec 29 22:04:59 UTC 2024



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
c02b1e46 by Simon Peyton Jones at 2024-12-29T17:04:30-05: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/c02b1e4620493eee1f6d6d71bead4af9d7246845

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c02b1e4620493eee1f6d6d71bead4af9d7246845
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/ef490179/attachment-0001.html>


More information about the ghc-commits mailing list