diff options
author | Bartosz Nitka <niteria@gmail.com> | 2016-01-26 11:26:06 -0800 |
---|---|---|
committer | Bartosz Nitka <niteria@gmail.com> | 2016-01-26 11:29:15 -0800 |
commit | 144ddb414a8a4f40df1ad9ab27fcdf38f30db4d3 (patch) | |
tree | 9cbb9a06a085a3e77997dc19a86ac5eb519250ca /compiler | |
parent | 6817703b31840620cca8596ca62ed70633934972 (diff) | |
download | haskell-144ddb414a8a4f40df1ad9ab27fcdf38f30db4d3.tar.gz |
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
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/iface/BuildTyCl.hs | 2 | ||||
-rw-r--r-- | compiler/main/InteractiveEval.hs | 4 | ||||
-rw-r--r-- | compiler/typecheck/TcFlatten.hs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcMType.hs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.hs | 6 | ||||
-rw-r--r-- | compiler/types/FamInstEnv.hs | 2 | ||||
-rw-r--r-- | compiler/types/TyCoRep.hs | 15 | ||||
-rw-r--r-- | 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 d13d38e6ff..1b4017abdc 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 b7c2178fc3..f0df270044 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 612f8a691b..f87a302d5c 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 bb31005c01..a160d4ebfe 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 fe13226c60..ac7e1b707d 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 1167ac254c..4b4cc5d2f6 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 2f034d036a..a2477250f0 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 8b426f131a..c6d51f35f6 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! |