Fix GHC.Core.Subst.substDVarSet

substDVarSet looked up coercion variables in the wrong environment!

The fix is easy.  It is still a pretty strange looking function, but
the bug is gone.  This fixes another manifestation of #20200.

4 files changed, 33 insertions, 17 deletions

diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs
index 1544e5b192..83e91ad21a 100644
--- a/compiler/GHC/Core/Subst.hs
+++ b/compiler/GHC/Core/Subst.hs
@@ -17,7 +17,7 @@ module GHC.Core.Subst (
         deShadowBinds, substRuleInfo, substRulesForImportedIds,
         substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
         substUnfolding, substUnfoldingSC,
-        lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc,
+        lookupIdSubst, substIdType, substIdOcc,
         substTickish, substDVarSet, substIdInfo,
 
         -- ** Operations on substitutions
@@ -251,24 +251,16 @@ extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var r
 
 -- | Find the substitution for an 'Id' in the 'Subst'
 lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr
-lookupIdSubst (Subst in_scope ids _ _) v
+lookupIdSubst s@(Subst in_scope ids _ _) v
   | not (isLocalId v) = Var v
   | Just e  <- lookupVarEnv ids       v = e
   | Just v' <- lookupInScope in_scope v = Var v'
         -- Vital! See Note [Extending the Subst]
         -- See #20200
   | otherwise = warnPprTrace True (text "GHC.Core.Subst.lookupIdSubst" <+> ppr v
-                            $$ ppr in_scope) $
+                            $$ ppr s) $
                 Var v
 
--- | Find the substitution for a 'TyVar' in the 'Subst'
-lookupTCvSubst :: Subst -> TyVar -> Type
-lookupTCvSubst (Subst _ _ tvs cvs) v
-  | isTyVar v
-  = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
-  | otherwise
-  = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v
-
 delBndr :: Subst -> Var -> Subst
 delBndr (Subst in_scope ids tvs cvs) v
   | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
@@ -703,13 +695,21 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
     (subst', bndrs') = substBndrs subst bndrs
 
 ------------------
-substDVarSet :: Subst -> DVarSet -> DVarSet
-substDVarSet subst fvs
-  = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs
+substDVarSet :: HasDebugCallStack => Subst -> DVarSet -> DVarSet
+substDVarSet subst@(Subst _ _ tv_env cv_env) fvs
+  = mkDVarSet $ fst $ foldr subst_fv ([], emptyVarSet) $ dVarSetElems fvs
   where
-  subst_fv subst fv acc
-     | isId fv = expr_fvs (lookupIdSubst subst fv) isLocalVar emptyVarSet $! acc
-     | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc
+  subst_fv :: Var -> ([Var], VarSet) -> ([Var], VarSet)
+  subst_fv fv acc
+     | isTyVar fv
+     , let fv_ty = lookupVarEnv tv_env fv `orElse` mkTyVarTy fv
+     = tyCoFVsOfType fv_ty (const True) emptyVarSet $! acc
+     | isCoVar fv
+     , let fv_co = lookupVarEnv cv_env fv `orElse` mkCoVarCo fv
+     = tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc
+     | otherwise
+     , let fv_expr = lookupIdSubst subst fv
+     = expr_fvs fv_expr isLocalVar emptyVarSet $! acc
 
 ------------------
 substTickish :: Subst -> CoreTickish -> CoreTickish
diff --git a/testsuite/tests/simplCore/should_compile/T20200b.hs b/testsuite/tests/simplCore/should_compile/T20200b.hs
new file mode 100644
index 0000000000..8826e66db5
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T20200b.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE DataKinds              #-}
+module T20200b where
+
+import Data.Kind
+
+xrecTuple :: Rec [Bool, Char] -> (Bool, Char)
+xrecTuple (a :& (b :& _)) = (a, b)
+
+data Rec :: [Type] -> Type where
+  (:&) :: r -> !(Rec rs) -> Rec (r ': rs)
diff --git a/testsuite/tests/simplCore/should_compile/T20200b.stderr b/testsuite/tests/simplCore/should_compile/T20200b.stderr
new file mode 100644
index 0000000000..1db18a40f6
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T20200b.stderr
@@ -0,0 +1,4 @@
+
+T20200b.hs:8:1: warning: [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match has inaccessible right hand side
+    In an equation for ‘xrecTuple’: xrecTuple (a :& (b :& _)) = ...
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 03039e8f8c..7db92e561c 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -374,3 +374,4 @@ test('T16373', normal, compile, [''])
 test('T20112',  normal, multimod_compile, ['T20112', '-O -v0 -g1'])
 test('T20200', normal, compile, [''])
 test('T20200a', normal, compile, ['-O2'])
+test('T20200b', normal, compile, ['-O2'])