[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Fix in-scope set for CSE
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Dec 30 13:43:24 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job 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
- - - - -
f862aa07 by Krzysztof Gogolewski at 2024-12-30T08:43:08-05:00
Add tests for #23883
The issue has been fixed by commit f5d3e03c56ffc63.
Only T23883a is the actual regression test, the remaining ones are
tricky cases found during development of an independent fix !11313.
- - - - -
32d0b8ca by Sergey Vinokurov at 2024-12-30T08:43:12-05:00
Update changelog for CLC proposal #107 (NonEmpty laziness)
- - - - -
11 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/CSE.hs
- libraries/base/changelog.md
- + testsuite/tests/rep-poly/T23153b.hs
- + testsuite/tests/rep-poly/T23883a.hs
- + testsuite/tests/rep-poly/T23883a.stderr
- + testsuite/tests/rep-poly/T23883b.hs
- + testsuite/tests/rep-poly/T23883b.stderr
- + testsuite/tests/rep-poly/T23883c.hs
- + testsuite/tests/rep-poly/T23883c.stderr
- testsuite/tests/rep-poly/all.T
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 #-}
=====================================
libraries/base/changelog.md
=====================================
@@ -7,6 +7,7 @@
* Modify the implementation of `Control.Exception.throw` to avoid call-sites being inferred as diverging via precise exception.
([GHC #25066](https://gitlab.haskell.org/ghc/ghc/-/issues/25066), [CLC proposal #290](https://github.com/haskell/core-libraries-committee/issues/290))
* `Data.List.NonEmpty.{init,last,tails1}` are now defined using only total functions (rather than partial ones). ([CLC proposal #293](https://github.com/haskell/core-libraries-committee/issues/293))
+ * `Data.List.NonEmpty` functions now have the same laziness as their `Data.List` counterparts (i.e. make them more strict than they currently are) ([CLC proposal #107](https://github.com/haskell/core-libraries-committee/issues/107))
## 4.21.0.0 *TBA*
* Introduce `Data.Bounded` module exporting the `Bounded` typeclass (finishing [CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208))
=====================================
testsuite/tests/rep-poly/T23153b.hs
=====================================
@@ -0,0 +1,8 @@
+module T23153b where
+
+import GHC.Exts
+
+f :: forall r s (a :: TYPE (r s)). a -> a
+f = f
+
+g h = case f (h ()) of () -> ()
=====================================
testsuite/tests/rep-poly/T23883a.hs
=====================================
@@ -0,0 +1,6 @@
+module T23883a where
+
+import GHC.Exts
+
+setField :: forall a_rep (a :: TYPE a_rep). a -> Int
+setField x = undefined (\ _ -> x)
=====================================
testsuite/tests/rep-poly/T23883a.stderr
=====================================
@@ -0,0 +1,6 @@
+T23883a.hs:6:1: error: [GHC-55287]
+ The first pattern in the equation for ‘setField’
+ does not have a fixed runtime representation.
+ Its type is:
+ a :: TYPE a_rep
+
=====================================
testsuite/tests/rep-poly/T23883b.hs
=====================================
@@ -0,0 +1,6 @@
+module T23883b where
+
+import GHC.Exts
+
+setField :: forall a_rep (a :: TYPE a_rep). a -> ()
+setField x _ = ()
=====================================
testsuite/tests/rep-poly/T23883b.stderr
=====================================
@@ -0,0 +1,5 @@
+T23883b.hs:6:1: error: [GHC-83865]
+ • Couldn't match expected type ‘()’ with actual type ‘t0 -> ()’
+ • The equation for ‘setField’ has two visible arguments,
+ but its type ‘a -> ()’ has only one
+
=====================================
testsuite/tests/rep-poly/T23883c.hs
=====================================
@@ -0,0 +1,6 @@
+module T23883c where
+
+import GHC.Exts
+
+setField :: forall r s (a :: TYPE (r s)). a -> ()
+setField x _ = ()
=====================================
testsuite/tests/rep-poly/T23883c.stderr
=====================================
@@ -0,0 +1,5 @@
+T23883c.hs:6:1: error: [GHC-83865]
+ • Couldn't match expected type ‘()’ with actual type ‘t0 -> ()’
+ • The equation for ‘setField’ has two visible arguments,
+ but its type ‘a -> ()’ has only one
+
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -34,8 +34,12 @@ test('T22291', normal, compile, [''])
test('T22291b', normal, compile, [''])
test('T23051', normal, compile_fail, [''])
test('T23153', normal, compile_fail, [''])
+test('T23153b', normal, compile, [''])
test('T23154', normal, compile_fail, [''])
test('T23176', normal, compile_fail, ['-XPartialTypeSignatures -fdefer-out-of-scope-variables'])
+test('T23883a', normal, compile_fail, [''])
+test('T23883b', normal, compile_fail, [''])
+test('T23883c', normal, compile_fail, [''])
test('T23903', normal, compile_fail, [''])
test('EtaExpandDataCon', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/41ab76f72efdb269fa3febea8cd2cb719c82b950...32d0b8ca0f35f35b87403a4cdb1d9d836e46d715
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/41ab76f72efdb269fa3febea8cd2cb719c82b950...32d0b8ca0f35f35b87403a4cdb1d9d836e46d715
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/20241230/7ec2dad5/attachment-0001.html>
More information about the ghc-commits
mailing list