summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/typecheck/TcType.hs36
-rw-r--r--compiler/types/TyCoFVs.hs105
-rw-r--r--compiler/types/TyCoRep.hs16
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