[Git][ghc/ghc][master] simplifier: Correct InScopeSet in rule matching

[Marge Bot (@marge-bot)]

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


Commits:
4f5538a8 by Matthew Pickering at 2023-07-21T23:25:39-04:00
simplifier: Correct InScopeSet in rule matching

The in-scope set passedto the `exprIsLambda_maybe` call lacked all the
in-scope binders. @simonpj suggests this fix where we augment the
in-scope set with the free variables of expression which fixes this
failure mode in quite a direct way.

Fixes #23630

- - - - -


3 changed files:

- compiler/GHC/Core/Rules.hs
- + testsuite/tests/simplCore/should_compile/T23630.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -888,9 +888,6 @@ So we must add the template vars to the in-scope set before starting;
 see `init_menv` in `matchN`.
 -}
 
-rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
-rvInScopeEnv renv = ISE (rnInScopeSet (rv_lcl renv)) (rv_unf renv)
-
 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
 --   variables passed into the match.
 --
@@ -1271,7 +1268,16 @@ match renv subst e1 (Let bind e2) mco
 
 ------------------------  Lambdas ---------------------
 match renv subst (Lam x1 e1) e2 mco
-  | Just (x2, e2', ts) <- exprIsLambda_maybe (rvInScopeEnv renv) (mkCastMCo e2 mco)
+  | let casted_e2 = mkCastMCo e2 mco
+        in_scope = extendInScopeSetSet (rnInScopeSet (rv_lcl renv))
+                                       (exprFreeVars casted_e2)
+        in_scope_env = ISE in_scope (rv_unf renv)
+        -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily
+        -- a superset of the free vars of e2; it is only guaranteed a superset of
+        -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe
+        -- wants an in-scope set that includes all the free vars of its argument.
+        -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630)
+  , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2
     -- See Note [Lambdas in the template]
   = let renv'  = rnMatchBndr2 renv x1 x2
         subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }


=====================================
testsuite/tests/simplCore/should_compile/T23630.hs
=====================================
@@ -0,0 +1,17 @@
+module T23630 where
+
+data HOLType = UTypeIn !HOLType deriving Eq
+
+tyVars :: HOLType -> [HOLType]
+tyVars (UTypeIn tv) = [undefined]
+
+union :: Eq a => [a] -> [a] -> [a]
+union l1 l2 = foldr insert l2 l1
+
+insert :: Eq a => a -> [a] -> [a]
+insert x l
+    | x `elem` l = l
+    | otherwise = x : l
+
+catTyVars :: [HOLType] -> [HOLType]
+catTyVars = foldr (union . tyVars) []


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -472,6 +472,7 @@ test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-agg
 test('T22802', normal, compile, ['-O'])
 test('T15205', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
 test('T22761', normal, multimod_compile, ['T22761', '-O2 -v0'])
+test('T23630', normal, compile, ['-O'])
 test('T23012', normal, compile, ['-O'])
 
 test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f5538a8e2a8b9bc490bcd098fa38f6f7e9f4d73

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f5538a8e2a8b9bc490bcd098fa38f6f7e9f4d73
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/20230721/31d21926/attachment-0001.html>