[commit: ghc] master: Construct in_scope set in mkTopTCvSubst (144ddb4)
git at git.haskell.org
git at git.haskell.org
Tue Jan 26 19:28:25 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/144ddb414a8a4f40df1ad9ab27fcdf38f30db4d3/ghc
>---------------------------------------------------------------
commit 144ddb414a8a4f40df1ad9ab27fcdf38f30db4d3
Author: Bartosz Nitka <niteria at gmail.com>
Date: Tue Jan 26 11:26:06 2016 -0800
Construct in_scope set in mkTopTCvSubst
The pre-condition on `mkTopTCvSubst` turned out to be wrong and
not satisfied by any of the callers. I've fixed it, so that it
constructs the in_scope set from the range of the substitution.
`mkTopTCvSubst` was also unnecessarily general it is never called
with `CoVars`, so I changed the type signature and added an assertion.
Test Plan: ./validate --slow
Reviewers: goldfire, simonpj, bgamari, austin
Reviewed By: simonpj
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1801
GHC Trac Issues: #11371
>---------------------------------------------------------------
144ddb414a8a4f40df1ad9ab27fcdf38f30db4d3
compiler/iface/BuildTyCl.hs | 2 +-
compiler/main/InteractiveEval.hs | 4 ++--
compiler/typecheck/TcFlatten.hs | 2 +-
compiler/typecheck/TcMType.hs | 2 +-
compiler/typecheck/TcSplice.hs | 6 +++---
compiler/types/FamInstEnv.hs | 2 +-
compiler/types/TyCoRep.hs | 15 +++++++++------
compiler/types/Type.hs | 6 +++++-
8 files changed, 23 insertions(+), 16 deletions(-)
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index d13d38e..1b4017a 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -184,7 +184,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
-- compatible with the pattern synonym
ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
, ex_tvs `equalLength` ex_tvs1
- , pat_ty `eqType` substTyUnchecked subst pat_ty1
+ , pat_ty `eqType` substTy subst pat_ty1
, prov_theta `eqTypes` substTys subst prov_theta1
, req_theta `eqTypes` substTys subst req_theta1
, arg_tys `eqTypes` substTys subst arg_tys1
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index b7c2178..f0df270 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -543,13 +543,13 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
let tv_subst = newTyVars us free_tvs
filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
(_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
- map (substTyUnchecked tv_subst . idType) filtered_ids
+ map (substTy tv_subst . idType) filtered_ids
new_ids <- zipWith3M mkNewId occs tidy_tys filtered_ids
result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
let result_id = Id.mkVanillaGlobal result_name
- (substTyUnchecked tv_subst result_ty)
+ (substTy tv_subst result_ty)
result_ok = isPointer result_id
final_ids | result_ok = result_id : new_ids
diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
index 612f8a6..f87a302 100644
--- a/compiler/typecheck/TcFlatten.hs
+++ b/compiler/typecheck/TcFlatten.hs
@@ -956,7 +956,7 @@ flatten_one (TyConApp tc tys)
-- Expand type synonyms that mention type families
-- on the RHS; see Note [Flattening synonyms]
| Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
- , let expanded_ty = mkAppTys (substTyUnchecked (mkTopTCvSubst tenv) rhs) tys'
+ , let expanded_ty = mkAppTys (substTy (mkTopTCvSubst tenv) rhs) tys'
= do { mode <- getMode
; let used_tcs = tyConsOfType rhs
; case mode of
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index bb31005..a160d4e 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -307,7 +307,7 @@ tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])
-- Moreover, make them "super skolems"; see comments with superSkolemTv
-- see Note [Kind substitution when instantiating]
-- Precondition: tyvars should be ordered by scoping
-tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar (mkTopTCvSubst [])
+tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst
tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)
tcSuperSkolTyVar subst tv
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index fe13226..ac7e1b7 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -99,7 +99,7 @@ import GHC.Serialized
import ErrUtils
import Util
import Unique
-import VarSet ( isEmptyVarSet, filterVarSet )
+import VarSet ( isEmptyVarSet, filterVarSet, mkVarSet, elemVarSet )
import Data.List ( find )
import Data.Maybe
import FastString
@@ -1395,8 +1395,8 @@ reifyDataCon isGadtDataCon tys dc
name = reifyName dc
-- Universal tvs present in eq_spec need to be filtered out, as
-- they will not appear anywhere in the type.
- subst = mkTopTCvSubst (map eqSpecPair g_eq_spec)
- g_unsbst_univ_tvs = filter (`notElemTCvSubst` subst) g_univ_tvs
+ eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
+ g_unsbst_univ_tvs = filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs
index 1167ac2..4b4cc5d 100644
--- a/compiler/types/FamInstEnv.hs
+++ b/compiler/types/FamInstEnv.hs
@@ -1237,7 +1237,7 @@ normalise_tc_app tc tys
; case expandSynTyCon_maybe tc ntys of
{ Just (tenv, rhs, ntys') ->
do { (co2, ninst_rhs)
- <- normalise_type (substTyUnchecked (mkTopTCvSubst tenv) rhs)
+ <- normalise_type (substTy (mkTopTCvSubst tenv) rhs)
; return $
if isReflCo co2
then (args_co, mkTyConApp tc ntys)
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 2f034d0..a247725 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -1686,12 +1686,15 @@ zipOpenTCvSubstBinders bndrs tys
is = mkInScopeSet (tyCoVarsOfTypes tys)
tenv = mkVarEnv [ (tv, ty) | (Named tv _, ty) <- zip bndrs tys ]
--- | Called when doing top-level substitutions. Here we expect that the
--- free vars of the range of the substitution will be empty.
-mkTopTCvSubst :: [(TyCoVar, Type)] -> TCvSubst
-mkTopTCvSubst prs = TCvSubst emptyInScopeSet tenv cenv
- where (tenv, cenv) = foldl extend (emptyTvSubstEnv, emptyCvSubstEnv) prs
- extend envs (v, ty) = extendSubstEnvs envs v ty
+-- | Called when doing top-level substitutions. No CoVars, please!
+mkTopTCvSubst :: [(TyVar, Type)] -> TCvSubst
+mkTopTCvSubst prs =
+ ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )
+ mkOpenTCvSubst tenv emptyCvSubstEnv
+ where tenv = mkVarEnv prs
+ onlyTyVarsAndNoCoercionTy =
+ and [ isTyVar tv && not (isCoercionTy ty)
+ | (tv, ty) <- prs ]
zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv tyvars tys
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 8b426f1..c6d51f3 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -294,7 +294,11 @@ coreView :: Type -> Maybe Type
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
- = Just (mkAppTys (substTyUnchecked (mkTopTCvSubst tenv) rhs) tys')
+ = Just (mkAppTys (substTy (mkTopTCvSubst tenv) rhs) tys')
+ -- The free vars of 'rhs' should all be bound by 'tenv', so it's
+ -- ok to use 'substTy' here.
+ -- See also Note [Generating the in-scope set for a substitution]
+ -- in TyCoRep.
-- Its important to use mkAppTys, rather than (foldl AppTy),
-- because the function part might well return a
-- partially-applied type constructor; indeed, usually will!
More information about the ghc-commits
mailing list