Get the in-scope set right during RULE matchingwip/T20200a

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.

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