diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-08-18 11:22:32 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-08-19 01:20:03 -0400 |
commit | 4ff4d434e9a90623afce00b43e2a5a1ccbdb4c05 (patch) | |
tree | 366f4c5c9263136083ca24bc47aaa0ebe2287d60 | |
parent | cad5a14122cae276a4964e17acd4d2cceb19f01e (diff) | |
download | haskell-4ff4d434e9a90623afce00b43e2a5a1ccbdb4c05.tar.gz |
Get the in-scope set right during RULE matching
There was a subtle error in the in-scope set during RULE matching,
which led to #20200 (not the original report, but the reports of
failures following an initial bug-fix commit).
This patch fixes the problem, and simplifies the code a bit.
In pariticular there was a very mysterious and ad-hoc in-scope set
extension in rnMatchBndr2, which is now moved to the right place,
namely in the Let case of match, where we do the floating.
I don't have a small repro case, alas.
-rw-r--r-- | compiler/GHC/Core/Opt/Arity.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Rules.hs | 37 | ||||
-rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Core/Subst.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Types/Var/Env.hs | 10 |
5 files changed, 28 insertions, 34 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index fcc35d76b5..f25d04e0ed 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -1763,7 +1763,7 @@ pushCoValArg co Pair tyL tyR = coercionKind co pushCoercionIntoLambda - :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) + :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) -- This implements the Push rule from the paper on coercions -- (\x. e) |> co -- ===> diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 139050a2b2..ff57df697f 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -705,7 +705,7 @@ rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the , rs_id_subst :: IdSubstEnv -- template variables , rs_binds :: BindWrapper -- Floated bindings - , rs_bndrs :: VarSet -- Variables bound by floated lets + , rs_bndrs :: [Var] -- Variables bound by floated lets } type BindWrapper = CoreExpr -> CoreExpr @@ -714,7 +714,7 @@ type BindWrapper = CoreExpr -> CoreExpr emptyRuleSubst :: RuleSubst emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv - , rs_binds = \e -> e, rs_bndrs = emptyVarSet } + , rs_binds = \e -> e, rs_bndrs = [] } -- At one stage I tried to match even if there are more -- template args than real args. @@ -777,16 +777,19 @@ match renv subst e1 (Let bind e2) | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ not (isJoinBind bind) -- can't float join point out of argument position , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] - = match (renv { rv_fltR = flt_subst' }) + = match (renv { rv_fltR = flt_subst' + , rv_lcl = rv_lcl renv `extendRnInScopeSetList` new_bndrs }) + -- We are floating the let-binding out, as if it had enclosed + -- the entire target from Day 1. So we must add its binders to + -- the in-scope set (#20200) (subst { rs_binds = rs_binds subst . Let bind' - , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) + , rs_bndrs = new_bndrs ++ rs_bndrs subst }) e1 e2 | otherwise = Nothing where - flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) - (flt_subst', bind') = substBind flt_subst bind - new_bndrs = bindersOf bind' + (flt_subst', bind') = substBind (rv_fltR renv) bind + new_bndrs = bindersOf bind' {- Disabled: see Note [Matching cases] below match renv (tv_subst, id_subst, binds) e1 @@ -813,15 +816,14 @@ match renv subst (App f1 a1) (App f2 a2) match renv subst (Lam x1 e1) e2 | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 - = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 - , rv_fltR = delBndr (rv_fltR renv) x2 } + = let renv' = rnMatchBndr2 renv x1 x2 subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } in match renv' subst' e1 e2 match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) = do { subst1 <- match_ty renv subst ty1 ty2 ; subst2 <- match renv subst1 e1 e2 - ; let renv' = rnMatchBndr2 renv subst x1 x2 + ; let renv' = rnMatchBndr2 renv x1 x2 ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted } @@ -883,14 +885,11 @@ match_cos _ subst [] [] = Just subst match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing ------------- -rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv -rnMatchBndr2 renv subst x1 x2 - = renv { rv_lcl = rnBndr2 rn_env x1 x2 +rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv +rnMatchBndr2 renv x1 x2 + = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 , rv_fltR = delBndr (rv_fltR renv) x2 } - where - rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) - -- Typically this is a no-op, but it may matter if - -- there are some floated let-bindings + ------------------------------------------ match_alts :: RuleMatchEnv @@ -906,7 +905,7 @@ match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) ; match_alts renv subst1 alts1 alts2 } where renv' = foldl' mb renv (vs1 `zip` vs2) - mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 + mb renv (v1,v2) = rnMatchBndr2 renv v1 v2 match_alts _ _ _ _ = Nothing @@ -988,7 +987,7 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) ; return (subst' { rs_id_subst = id_subst' }) } where -- e2' is the result of applying flt_env to e2 - e2' | isEmptyVarSet let_bndrs = e2 + e2' | null let_bndrs = e2 | otherwise = substExpr flt_env e2 id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 40e9f138b7..d741aa0351 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -1327,8 +1327,9 @@ Currently, it is used in GHC.Core.Rules.match, and is required to make "map coerce = coerce" match. -} -exprIsLambda_maybe :: InScopeEnv -> CoreExpr - -> Maybe (Var, CoreExpr,[CoreTickish]) +exprIsLambda_maybe :: HasDebugCallStack + => InScopeEnv -> CoreExpr + -> Maybe (Var, CoreExpr,[CoreTickish]) -- See Note [exprIsLambda_maybe] -- The simple case: It is a lambda already diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 2d4eac114c..ddb8e71f1f 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -24,7 +24,7 @@ module GHC.Core.Subst ( emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, - addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, + extendInScope, extendInScopeList, extendInScopeIds, isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, delBndr, delBndrs, @@ -292,12 +292,6 @@ mkOpenSubst in_scope pairs = Subst in_scope isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope --- | Add the 'Var' to the in-scope set, but do not remove --- any existing substitutions for it -addInScopeSet :: Subst -> VarSet -> Subst -addInScopeSet (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs - -- | Add the 'Var' to the in-scope set: as a side effect, -- and remove any existing substitutions for it extendInScope :: Subst -> Var -> Subst diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index ed58c413f4..ee9e2d399b 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -64,7 +64,7 @@ module GHC.Types.Var.Env ( rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, delBndrL, delBndrR, delBndrsL, delBndrsR, - addRnInScopeSet, + extendRnInScopeSetList, rnEtaL, rnEtaR, rnInScope, rnInScopeSet, lookupRnInScope, rnEnvL, rnEnvR, @@ -260,10 +260,10 @@ mkRnEnv2 vars = RV2 { envL = emptyVarEnv , envR = emptyVarEnv , in_scope = vars } -addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 -addRnInScopeSet env vs - | isEmptyVarSet vs = env - | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } +extendRnInScopeSetList :: RnEnv2 -> [Var] -> RnEnv2 +extendRnInScopeSetList env vs + | null vs = env + | otherwise = env { in_scope = extendInScopeSetList (in_scope env) vs } rnInScope :: Var -> RnEnv2 -> Bool rnInScope x env = x `elemInScopeSet` in_scope env |