[commit: ghc] ghc-8.0: Construct in_scope set in mkTopTCvSubst (c325baf)

git at git.haskell.org git at git.haskell.org
Wed Jan 27 12:05:40 UTC 2016


Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/c325bafe0525a7bf65656bacba85ef2a5c6f88d2/ghc

>---------------------------------------------------------------

commit c325bafe0525a7bf65656bacba85ef2a5c6f88d2
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
    
    (cherry picked from commit 144ddb414a8a4f40df1ad9ab27fcdf38f30db4d3)


>---------------------------------------------------------------

c325bafe0525a7bf65656bacba85ef2a5c6f88d2
 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 b7ed44f..6e3f77b 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -533,13 +533,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 ee92f06..1a0e280 100644
--- a/compiler/typecheck/TcFlatten.hs
+++ b/compiler/typecheck/TcFlatten.hs
@@ -960,7 +960,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 f9f057f..f772da5 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 7c7ebe5..59c5b43 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
@@ -1394,8 +1394,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 f26b113..6ed3547 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 ce3290a..b80ee06 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -1658,12 +1658,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 5e3a1f3..0d25045 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -300,7 +300,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