[Git][ghc/ghc][wip/T8095-spj] Free-var fixes
Simon Peyton Jones
gitlab at gitlab.haskell.org
Tue Aug 4 12:38:55 UTC 2020
Simon Peyton Jones pushed to branch wip/T8095-spj at Glasgow Haskell Compiler / GHC
Commits:
ce39b22b by Simon Peyton Jones at 2020-08-04T13:38:05+01:00
Free-var fixes
This should stop the perf regressions
- - - - -
3 changed files:
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Tc/Instance/Family.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Core.TyCo.FVs
-- Injective free vars
injectiveVarsOfType, injectiveVarsOfTypes,
- invisibleVarsOfType, invisibleVarsOfTypes,
+ invisibleVarsOfTypes,
-- No Free vars
noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo,
@@ -221,7 +221,7 @@ kind are free.
* *
********************************************************************* -}
-{- Note [Acumulating parameter free variables]
+{- Note [Accumulating parameter free variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can use foldType to build an accumulating-parameter version of a
free-var finder, thus:
@@ -271,7 +271,16 @@ emptyInScope = emptyVarSet
runTyCoVars :: TyCoFvFun a TyCoVarSet -> a -> TyCoVarSet
{-# INLINE runTyCoVars #-}
-runTyCoVars f x = appEndo (f emptyInScope x) emptyVarSet
+runTyCoVars f = \x -> appEndo (f emptyInScope x) emptyVarSet
+ -- It's very important that the \x is to the right of the '=', so
+ -- runTyCoVars has arity 1. It is often applied to just one arg e.g.
+ -- tyCoVarsOfType = runTyCoVars deep_ty
+ -- We want runTyCoVars to inline, so that deep_ty is applied to two args,
+ -- which in turn makes deep_ty eta-expand. Without that eta-expansion,
+ -- deep_ty is dreadfully inefficient.
+ --
+ -- If we put the \x to the left of the '=', runTyCoVars would only
+ -- inline when applied to /two/ arguments.
{- *********************************************************************
@@ -281,22 +290,20 @@ runTyCoVars f x = appEndo (f emptyInScope x) emptyVarSet
* *
********************************************************************* -}
-tyCoVarsOfType :: Type -> TyCoVarSet
-tyCoVarsOfType ty = runTyCoVars deep_ty ty
--- Alternative:
--- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty)
+-- See Note [Free variables of Coercions]
+tyCoVarsOfType :: Type -> TyCoVarSet
tyCoVarsOfTypes :: [Type] -> TyCoVarSet
-tyCoVarsOfTypes tys = runTyCoVars deep_tys tys
--- Alternative:
--- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys)
+tyCoVarsOfCo :: Coercion -> TyCoVarSet
+tyCoVarsOfCos :: [Coercion] -> TyCoVarSet
-tyCoVarsOfCo :: Coercion -> TyCoVarSet
--- See Note [Free variables of Coercions]
-tyCoVarsOfCo co = runTyCoVars deep_co co
+tyCoVarsOfType = runTyCoVars deep_ty
+tyCoVarsOfTypes = runTyCoVars deep_tys
+tyCoVarsOfCo = runTyCoVars deep_co
+tyCoVarsOfCos = runTyCoVars deep_cos
-tyCoVarsOfCos :: [Coercion] -> TyCoVarSet
-tyCoVarsOfCos cos = runTyCoVars deep_cos cos
+-- Alternative for tyCoVarsOfType
+-- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty)
deep_ty :: TyCoFvFun Type TyCoVarSet
deep_tys :: TyCoFvFun [Type] TyCoVarSet
@@ -866,26 +873,32 @@ injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under
-- * In a coercion
-- * In a Specified or Inferred argument to a function
-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep"
-invisibleVarsOfType :: Type -> FV
-invisibleVarsOfType = go
- where
- go ty | Just ty' <- coreView ty
- = go ty'
- go (TyVarTy v) = go (tyVarKind v)
- go (AppTy f a) = go f `unionFV` go a
- go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2
- go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV`
- invisibleVarsOfTypes visibles
- where (invisibles, visibles) = partitionInvisibleTypes tc tys
- go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty
- go LitTy{} = emptyFV
- go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty
- go (CoercionTy co) = tyCoFVsOfCo co
-
--- | Like 'invisibleVarsOfType', but for many types.
-invisibleVarsOfTypes :: [Type] -> FV
-invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType
-
+invisibleVarsOfTypes :: [Type] -> VarSet
+invisibleVarsOfTypes = runTyCoVars invis_tys
+
+invis_tys :: TyCoFvFun [Type] TyCoVarSet
+invis_tys _ [] = mempty
+invis_tys is (ty:tys) = invis_ty is ty `mappend` invis_tys is tys
+
+invis_ty :: TyCoFvFun Type TyCoVarSet
+invis_ty is ty | Just ty' <- coreView ty
+ = invis_ty is ty'
+
+invis_ty is (TyVarTy v)
+ | v `elemVarSet` is = mempty
+ | otherwise = deep_ty emptyVarSet (tyVarKind v)
+invis_ty is (AppTy f a) = invis_ty is f `mappend` invis_ty is a
+invis_ty is (FunTy _ w ty1 ty2) = invis_ty is w `mappend` invis_ty is ty1 `mappend` invis_ty is ty2
+invis_ty is (TyConApp tc tys) = deep_tys is invisibles `mappend`
+ invis_tys is visibles
+ where (invisibles, visibles) = partitionInvisibleTypes tc tys
+invis_ty is (ForAllTy tvb ty) = invis_ty is (tyVarKind tv) `mappend`
+ invis_ty (is `extendVarSet` tv) ty
+ where
+ tv = binderVar tvb
+invis_ty _ LitTy{} = mempty
+invis_ty is (CastTy ty co) = deep_co is co `mappend` invis_ty is ty
+invis_ty is (CoercionTy co) = deep_co is co
{- *********************************************************************
* *
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1962,12 +1962,14 @@ foldTyCo (TyCoFolder { tcf_view = view
where
env' = tycobinder env tv Inferred
- go_prov env (ZapCoProv cvs) = strictFoldDVarSet (mappend . covar env)
- mempty cvs
+ go_prov env (ZapCoProv cvs) = go_cvs env (dVarSetElems cvs)
go_prov env (PhantomProv co) = go_co env co
go_prov env (ProofIrrelProv co) = go_co env co
go_prov _ (PluginProv _) = mempty
+ go_cvs _ [] = mempty
+ go_cvs env (cv:cvs) = covar env cv `mappend` go_cvs env cvs
+
{- *********************************************************************
* *
typeSize, coercionSize
=====================================
compiler/GHC/Tc/Instance/Family.hs
=====================================
@@ -918,7 +918,7 @@ unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs
any_bad = not $ isEmptyVarSet bad_vars
- invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs]
+ invis_vars = invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs]
any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars)
suggest_undec = any_bad &&
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce39b22bdfeee800aa09394110213ad0487e6168
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce39b22bdfeee800aa09394110213ad0487e6168
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200804/c06df7f8/attachment-0001.html>
More information about the ghc-commits
mailing list