diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2021-08-03 19:13:56 +0200 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2022-02-23 13:40:34 -0500 |
commit | 0e5236add8dc83ec5f66a5e7bcb7f31d6636fcf0 (patch) | |
tree | 588433e3852c920ec7abac87687c3509f7f1ed46 | |
parent | 2196c994c91126072d001b760a69fa05fe936a47 (diff) | |
download | haskell-0e5236add8dc83ec5f66a5e7bcb7f31d6636fcf0.tar.gz |
Fix lookupIdSubst call during RULE matching
As #20200 showed, there was a call to lookupIdSubst during RULE
matching, where the variable being looked up wasn't in the InScopeSet.
This patch fixes the problem at source, by dealing separately with
nested and non-nested binders.
As a result we can change the trace call in lookupIdSubst to a
proper panic -- if it happens, we really want to know.
(cherry picked from commit 149bce42fc324863c5da8c98b4991358b5ec4617)
-rw-r--r-- | compiler/GHC/Core/Rules.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/Core/Subst.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T20200.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
4 files changed, 27 insertions, 13 deletions
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 41cab2d201..56f2f0dad8 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -777,6 +777,8 @@ match renv subst e1 (Let bind e2) (subst { rs_binds = rs_binds subst . Let bind' , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) e1 e2 + | otherwise + = Nothing where flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) (flt_subst', bind') = substBind flt_subst bind @@ -926,12 +928,19 @@ match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) | otherwise -- v1' is not a template variable; check for an exact match with e2 = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR - Var v2 | v1' == rnOccR rn_env v2 - -> Just subst - + Var v2 | Just v2' <- rnOccR_maybe rn_env v2 + -> -- v2 was bound by a nested lambda or case + if v1' == v2' then Just subst + else Nothing + + -- v2 is not bound nestedly; it is free + -- in the whole expression being matched + -- So it will be in the InScopeSet for flt_env (#20200) | Var v2' <- lookupIdSubst flt_env v2 , v1' == v2' -> Just subst + | otherwise + -> Nothing _ -> Nothing @@ -1081,14 +1090,14 @@ There are a couple of tricky points. Our cunning plan is this: * Along with the growing substitution for template variables we maintain a growing set of floated let-bindings (rs_binds) - plus the set of variables thus bound. + plus the set of variables thus bound (rs_bndrs). * The RnEnv2 in the MatchEnv binds only the local binders - in the term (lambdas, case) + in the term (lambdas, case), not the floated let-bndrs. - * When we encounter a let in the term to be matched, we - check that does not mention any locally bound (lambda, case) - variables. If so we fail + * When we encounter a let in the term to be matched, we use + okToFloat check that does not mention any locally bound (lambda, + case) variables. If so we fail. * We use GHC.Core.Subst.substBind to freshen the binding, using an in-scope set that is the original in-scope variables plus the diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 5f1235501b..3cb283c4ba 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -39,8 +39,6 @@ module GHC.Core.Subst ( import GHC.Prelude -import GHC.Driver.Ppr - import GHC.Core import GHC.Core.FVs import GHC.Core.Seq @@ -256,9 +254,9 @@ lookupIdSubst (Subst in_scope ids _ _) v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v - $$ ppr in_scope) - Var v + -- If v isn't in the InScopeSet, we panic, because + -- it's a bad bug and we reallly want to know + | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope) -- | Find the substitution for a 'TyVar' in the 'Subst' lookupTCvSubst :: Subst -> TyVar -> Type diff --git a/testsuite/tests/simplCore/should_compile/T20200.hs b/testsuite/tests/simplCore/should_compile/T20200.hs new file mode 100644 index 0000000000..0695b86ff4 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T20200.hs @@ -0,0 +1,6 @@ +module T20200 where + +import qualified Data.Map as Map + +cleanTempDirs :: ([String] -> a) -> Map.Map String String -> a +cleanTempDirs logger ds = logger (Map.elems ds) diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index cdffaea2ea..ce559309d7 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -357,3 +357,4 @@ test('T19586', normal, compile, ['']) test('T20639', normal, compile, ['-O2']) test('T20894', normal, compile, ['-dcore-lint -O1 -ddebug-output']) +test('T20200', normal, compile, ['']) |