summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Core/Subst.hs34
-rw-r--r--testsuite/tests/simplCore/should_compile/T20200b.hs11
-rw-r--r--testsuite/tests/simplCore/should_compile/T20200b.stderr4
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T1
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'])