diff options
| -rw-r--r-- | compiler/typecheck/TcType.hs | 36 | ||||
| -rw-r--r-- | compiler/types/TyCoFVs.hs | 105 | ||||
| -rw-r--r-- | compiler/types/TyCoRep.hs | 16 |
3 files changed, 70 insertions, 87 deletions
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 9faa4bb44e..4cec96a847 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -898,6 +898,42 @@ would re-occur and we end up with an infinite loop in which each kicks out the other (#14363). -} +{- ********************************************************************* +* * + The "exact" free variables of a type +* * +********************************************************************* -} + +{- Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! + +exactTyCoVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It only matters +occasionally -- see the calls to exactTyCoVarsOfType. + +We place this function here in TcType, note in TyCoFVs, +because we want to "see" tcView (efficiency issue only). +-} + +exactTyCoVarsOfType :: Type -> TyCoVarSet +exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. + +exactTyCoVarsOfType ty = runTyCoVars (exact_ty ty) +exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys) + +exact_ty :: Type -> Endo TyCoVarSet +exact_tys :: [Type] -> Endo TyCoVarSet +(exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet + +exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +exactTcvFolder = deepTcvFolder { tcf_view = tcView } + -- This is the key line + {- ************************************************************************ * * diff --git a/compiler/types/TyCoFVs.hs b/compiler/types/TyCoFVs.hs index fa4d55c5e8..9b8b5d91a2 100644 --- a/compiler/types/TyCoFVs.hs +++ b/compiler/types/TyCoFVs.hs @@ -8,6 +8,7 @@ module TyCoFVs tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, tyCoFVsOfType, tyCoVarsOfTypeList, tyCoFVsOfTypes, tyCoVarsOfTypesList, + deepTcvFolder, shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv, @@ -25,9 +26,6 @@ module TyCoFVs injectiveVarsOfType, injectiveVarsOfTypes, invisibleVarsOfType, invisibleVarsOfTypes, - -- Exact free vars - exactTyCoVarsOfType, exactTyCoVarsOfTypes, - -- No Free vars noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, @@ -39,13 +37,15 @@ module TyCoFVs closeOverKindsDSet, closeOverKindsList, closeOverKinds, + -- * Raw materials + Endo(..), runTyCoVars ) where #include "HsVersions.h" import GhcPrelude -import {-# SOURCE #-} Type (coreView, tcView, partitionInvisibleTypes) +import {-# SOURCE #-} Type (coreView, partitionInvisibleTypes) import Data.Monoid as DM ( Endo(..), All(..) ) import TyCoRep @@ -215,8 +215,9 @@ Recall that So `mappend` for Endos is just function composition. -It's very important that, after optimisation, we end up -with an arity-three function, something like this: +It's very important that, after optimisation, we end up with +* an arity-three function +* that is strict in the accumulator fvs env (TyVarTy v) acc | v `elemVarSet` env = acc @@ -225,16 +226,23 @@ with an arity-three function, something like this: fvs env (AppTy t1 t2) = fvs env t1 (fvs env t2 acc) ... -The optimiser does do this, but not very robustly. It depends +The "strict in the accumulator" part is to ensure that in the +AppTy equation we don't build a thunk for (fvs env t2 acc). + +The optimiser does do all this, but not very robustly. It depends critially on the basic arity-2 function not being exported, so that all its calls are visibly to three arguments. This analysis is done by the Call Arity pass. + +TL;DR: check this regularly! -} runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet {-# INLINE runTyCoVars #-} runTyCoVars f = appEndo f emptyVarSet +noView :: Type -> Maybe Type +noView _ = Nothing {- ********************************************************************* * * @@ -266,7 +274,8 @@ deep_cos :: [Coercion] -> Endo TyCoVarSet (deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -deepTcvFolder = TyCoFolder { tcf_tyvar = do_tcv, tcf_covar = do_tcv +deepTcvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where do_tcv is v = Endo do_it @@ -321,7 +330,8 @@ shallow_cos :: [Coercion] -> Endo TyCoVarSet (shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -shallowTcvFolder = TyCoFolder { tcf_tyvar = do_tcv, tcf_covar = do_tcv +shallowTcvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where do_tcv is v = Endo do_it @@ -368,8 +378,9 @@ deep_cv_cos :: [Coercion] -> Endo CoVarSet (deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet) -deepCoVarFolder = TyCoFolder { tcf_tyvar = do_tyvar, tcf_covar = do_covar - , tcf_hole = do_hole, tcf_tycobinder = do_bndr } +deepCoVarFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tyvar, tcf_covar = do_covar + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where do_tyvar _ _ = mempty -- This do_tyvar means we won't see any CoVars in this @@ -708,75 +719,6 @@ almost_devoid_co_var_of_types (ty:tys) cv {- ********************************************************************* * * - The "exact" free variables of a type -* * -********************************************************************* -} - -{- Note [Silly type synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type T a = Int -What are the free tyvars of (T x)? Empty, of course! - -exactTyCoVarsOfType is used by the type checker to figure out exactly -which type variables are mentioned in a type. It only matters -occasionally -- see the calls to exactTyCoVarsOfType. --} - -exactTyCoVarsOfType :: Type -> TyCoVarSet --- Find the free type variables (of any kind) --- but *expand* type synonyms. See Note [Silly type synonym] above. -exactTyCoVarsOfType ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' -- This is the key line - go (TyVarTy tv) = goVar tv - go (TyConApp _ tys) = exactTyCoVarsOfTypes tys - go (LitTy {}) = emptyVarSet - go (AppTy fun arg) = go fun `unionVarSet` go arg - go (FunTy _ arg res) = go arg `unionVarSet` go res - go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) - go (CastTy ty co) = go ty `unionVarSet` goCo co - go (CoercionTy co) = goCo co - - goMCo MRefl = emptyVarSet - goMCo (MCo co) = goCo co - - goCo (Refl ty) = go ty - goCo (GRefl _ ty mco) = go ty `unionVarSet` goMCo mco - goCo (TyConAppCo _ _ args)= goCos args - goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg - goCo (ForAllCo tv k_co co) - = goCo co `delVarSet` tv `unionVarSet` goCo k_co - goCo (FunCo _ co1 co2) = goCo co1 `unionVarSet` goCo co2 - goCo (CoVarCo v) = goVar v - goCo (HoleCo h) = goVar (coHoleCoVar h) - goCo (AxiomInstCo _ _ args) = goCos args - goCo (UnivCo p _ t1 t2) = goProv p `unionVarSet` go t1 `unionVarSet` go t2 - goCo (SymCo co) = goCo co - goCo (TransCo co1 co2) = goCo co1 `unionVarSet` goCo co2 - goCo (NthCo _ _ co) = goCo co - goCo (LRCo _ co) = goCo co - goCo (InstCo co arg) = goCo co `unionVarSet` goCo arg - goCo (KindCo co) = goCo co - goCo (SubCo co) = goCo co - goCo (AxiomRuleCo _ c) = goCos c - - goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos - - goProv UnsafeCoerceProv = emptyVarSet - goProv (PhantomProv kco) = goCo kco - goProv (ProofIrrelProv kco) = goCo kco - goProv (PluginProv _) = emptyVarSet - - goVar v = unitVarSet v `unionVarSet` go (varType v) - -exactTyCoVarsOfTypes :: [Type] -> TyVarSet -exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys - - -{- ********************************************************************* -* * Injective free vars * * ********************************************************************* -} @@ -890,7 +832,8 @@ invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType ********************************************************************* -} nfvFolder :: TyCoFolder TyCoVarSet DM.All -nfvFolder = TyCoFolder { tcf_tyvar = do_tcv, tcf_covar = do_tcv +nfvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where do_tcv is tv = All (tv `elemVarSet` is) diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 59ccc8f884..23571d3cb2 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -1726,7 +1726,9 @@ record selections still cancel. And eta expansion still happens too. data TyCoFolder env a = TyCoFolder - { tcf_tyvar :: env -> TyVar -> a + { tcf_view :: Type -> Maybe Type -- Optional "view" function + -- E.g. expand synonyms + , tcf_tyvar :: env -> TyVar -> a , tcf_covar :: env -> CoVar -> a , tcf_hole :: env -> CoercionHole -> a -- ^ What to do with coercion holes. @@ -1739,12 +1741,14 @@ data TyCoFolder env a {-# INLINE foldTyCo #-} -- See Note [Specialising foldType] foldTyCo :: Monoid a => TyCoFolder env a -> env -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a) -foldTyCo (TyCoFolder { tcf_tyvar = tyvar - , tcf_tycobinder = tycobinder - , tcf_covar = covar - , tcf_hole = cohole }) env +foldTyCo (TyCoFolder { tcf_view = view + , tcf_tyvar = tyvar + , tcf_tycobinder = tycobinder + , tcf_covar = covar + , tcf_hole = cohole }) env = (go_ty env, go_tys env, go_co env, go_cos env) where + go_ty env ty | Just ty' <- view ty = go_ty env ty' go_ty env (TyVarTy tv) = tyvar env tv go_ty env (AppTy t1 t2) = go_ty env t1 `mappend` go_ty env t2 go_ty _ (LitTy {}) = mempty @@ -1753,7 +1757,7 @@ foldTyCo (TyCoFolder { tcf_tyvar = tyvar go_ty env (FunTy _ arg res) = go_ty env arg `mappend` go_ty env res go_ty env (TyConApp _ tys) = go_tys env tys go_ty env (ForAllTy (Bndr tv vis) inner) - = let env' = tycobinder env tv vis + = let !env' = tycobinder env tv vis -- Avoid building a thunk here in go_ty env (varType tv) `mappend` go_ty env' inner -- Explicit recursion becuase using foldr builds a local |