[Git][ghc/ghc][wip/T8095-spj] Simplify TyCoFolder
Simon Peyton Jones
gitlab at gitlab.haskell.org
Tue Aug 4 19:07:57 UTC 2020
Simon Peyton Jones pushed to branch wip/T8095-spj at Glasgow Haskell Compiler / GHC
Commits:
16ef62d4 by Simon Peyton Jones at 2020-08-04T20:06:59+01:00
Simplify TyCoFolder
This commit removes the 'env' part of TyCoFolder. A nice
simplification!
- - - - -
6 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Zonk.hs
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -2940,22 +2940,19 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
%************************************************************************
-}
-bad_co_hole_ty :: () -> Type -> Monoid.Any
-bad_co_hole_co :: () -> Coercion -> Monoid.Any
+bad_co_hole_ty :: Type -> Monoid.Any
+bad_co_hole_co :: Coercion -> Monoid.Any
(bad_co_hole_ty, _, bad_co_hole_co, _)
= foldTyCo folder
where
- folder :: TyCoFolder () Monoid.Any
+ folder :: TyCoFolder Monoid.Any
folder = TyCoFolder { tcf_view = const Nothing
- , tcf_tyvar = const2 (Monoid.Any False)
- , tcf_covar = const2 (Monoid.Any False)
- , tcf_hole = const hole
- , tcf_tycobinder = const2
+ , tcf_tyvar = const (Monoid.Any False)
+ , tcf_covar = const (Monoid.Any False)
+ , tcf_hole = hole
+ , tcf_tycobinder = \_ _ acc -> acc
}
- const2 :: a -> b -> c -> a
- const2 x _ _ = x
-
hole :: CoercionHole -> Monoid.Any
hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True
hole _ = Monoid.Any False
@@ -2963,9 +2960,9 @@ bad_co_hole_co :: () -> Coercion -> Monoid.Any
-- | Is there a blocking coercion hole in this type? See
-- "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds]
badCoercionHole :: Type -> Bool
-badCoercionHole = Monoid.getAny . bad_co_hole_ty ()
+badCoercionHole = Monoid.getAny . bad_co_hole_ty
-- | Is there a blocking coercion hole in this coercion? See
-- GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]
badCoercionHoleCo :: Coercion -> Bool
-badCoercionHoleCo = Monoid.getAny . bad_co_hole_co ()
+badCoercionHoleCo = Monoid.getAny . bad_co_hole_co
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, PatternSynonyms #-}
module GHC.Core.TyCo.FVs
( shallowTyCoVarsOfType, shallowTyCoVarsOfTypes,
@@ -39,7 +39,7 @@ module GHC.Core.TyCo.FVs
closeOverKinds,
-- * Raw materials
- Endo(..), TyCoFvFun, InScopeBndrs, emptyInScope, runTyCoVars
+ TyCoAcc(..), InScopeBndrs, emptyInScope, extendInScope, runTyCoVars
) where
#include "HsVersions.h"
@@ -48,7 +48,6 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes)
-import Data.Monoid as DM ( Endo(..), All(..) )
import GHC.Core.TyCo.Rep
import GHC.Core.TyCon
import GHC.Types.Var
@@ -59,7 +58,8 @@ import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Utils.Misc
import GHC.Utils.Panic
-
+import Data.Semigroup as Semigroup
+import GHC.Exts( oneShot )
{-
%************************************************************************
%* *
@@ -264,14 +264,54 @@ TL;DR: check this regularly!
-}
type InScopeBndrs = TyCoVarSet
-type TyCoFvFun a s = InScopeBndrs -> a -> Endo s
+newtype TyCoAcc acc = TCA' { runTCA :: InScopeBndrs -> acc -> acc }
+
+pattern TCA :: forall acc. (InScopeBndrs -> acc -> acc) -> TyCoAcc acc
+{-# COMPLETE TCA #-}
+pattern TCA f <- TCA' f
+ where
+ TCA f = TCA' (oneShot f)
+
+instance Semigroup (TyCoAcc acc) where
+ (TCA f1) <> (TCA f2) = TCA (\is acc -> f2 is (f1 is acc))
+ {-# INLINE (<>) #-}
+
+instance Monoid (TyCoAcc acc) where
+ mempty = TCA (\_ acc -> acc)
+ {-# INLINE mempty #-}
+ mappend = (Semigroup.<>)
+ {-# INLINE mappend #-}
emptyInScope :: InScopeBndrs
emptyInScope = emptyVarSet
-runTyCoVars :: TyCoFvFun a TyCoVarSet -> a -> TyCoVarSet
+addTyCoVar :: TyCoVar -> TyCoAcc TyCoVarSet -> TyCoAcc TyCoVarSet
+-- Add a variable tcv, and the extras, to the free vars unless
+-- tcv is in the in-scope
+-- or is already in the in-scope set-
+-- The 'extras' start from an empty in-scope set;
+-- see Note [Closing over free variable kinds]
+addTyCoVar tcv (TCA add_extras) = TCA add_it
+ where
+ add_it is acc
+ | tcv `elemVarSet` is = acc
+ | tcv `elemVarSet` acc = acc
+ | otherwise = add_extras emptyVarSet (acc `extendVarSet` tcv)
+
+extendInScope :: TyCoVar -> TyCoAcc acc -> TyCoAcc acc
+-- Gather the argument free vars in an empty in-scope set
+extendInScope tcv (TCA f) = TCA (\is acc -> f (is `extendVarSet` tcv) acc)
+
+whenNotInScope :: TyCoVar -> TyCoAcc acc -> TyCoAcc acc
+-- If tcv is not in the in-scope set, compute
+-- the 'extras' in an empty in-scope set
+whenNotInScope tcv (TCA f) = TCA (\is acc -> if tcv `elemVarSet` is
+ then acc
+ else f emptyInScope acc)
+
+runTyCoVars :: (a -> TyCoAcc TyCoVarSet) -> a -> TyCoVarSet
{-# INLINE runTyCoVars #-}
-runTyCoVars f = \x -> appEndo (f emptyInScope x) emptyVarSet
+runTyCoVars f = \x -> runTCA (f x) emptyInScope 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
@@ -292,9 +332,9 @@ runTyCoVars f = \x -> appEndo (f emptyInScope x) emptyVarSet
-- See Note [Free variables of Coercions]
-tyCoVarsOfType :: Type -> TyCoVarSet
-tyCoVarsOfTypes :: [Type] -> TyCoVarSet
-tyCoVarsOfCo :: Coercion -> TyCoVarSet
+tyCoVarsOfType :: Type -> TyCoVarSet
+tyCoVarsOfTypes :: [Type] -> TyCoVarSet
+tyCoVarsOfCo :: Coercion -> TyCoVarSet
tyCoVarsOfCos :: [Coercion] -> TyCoVarSet
tyCoVarsOfType = runTyCoVars deep_ty
@@ -305,27 +345,21 @@ tyCoVarsOfCos = runTyCoVars deep_cos
-- Alternative for tyCoVarsOfType
-- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty)
-deep_ty :: TyCoFvFun Type TyCoVarSet
-deep_tys :: TyCoFvFun [Type] TyCoVarSet
-deep_co :: TyCoFvFun Coercion TyCoVarSet
-deep_cos :: TyCoFvFun [Coercion] TyCoVarSet
+deep_ty :: Type -> TyCoAcc TyCoVarSet
+deep_tys :: [Type] -> TyCoAcc TyCoVarSet
+deep_co :: Coercion -> TyCoAcc TyCoVarSet
+deep_cos :: [Coercion] -> TyCoAcc TyCoVarSet
(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder
-deepTcvFolder :: TyCoFolder InScopeBndrs (Endo TyCoVarSet)
+deepTcvFolder :: TyCoFolder (TyCoAcc TyCoVarSet)
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
- where
- do_it acc | v `elemVarSet` is = acc
- | v `elemVarSet` acc = acc
- | otherwise = appEndo (deep_ty emptyInScope (varType v)) $
- acc `extendVarSet` v
- -- emptyInScope: see Note [Closing over free variable kinds]
-
- do_bndr is tcv _ = extendVarSet is tcv
- do_hole is hole = do_tcv is (coHoleCoVar hole)
+ do_tcv v = addTyCoVar v (deep_ty (varType v))
+
+ do_bndr tcv _vis fvs = extendInScope tcv fvs
+ do_hole hole = do_tcv (coHoleCoVar hole)
-- See Note [CoercionHoles and coercion free variables]
-- in GHC.Core.TyCo.Rep
@@ -337,18 +371,16 @@ deepTcvFolder = TyCoFolder { tcf_view = noView
********************************************************************* -}
-shallowTyCoVarsOfType :: Type -> TyCoVarSet
-- See Note [Free variables of types]
-shallowTyCoVarsOfType = runTyCoVars shallow_ty
+shallowTyCoVarsOfType :: Type -> TyCoVarSet
+shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet
+shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet
+shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet
-shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet
+shallowTyCoVarsOfType = runTyCoVars shallow_ty
shallowTyCoVarsOfTypes = runTyCoVars shallow_tys
-
-shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet
-shallowTyCoVarsOfCo = runTyCoVars shallow_co
-
-shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet
-shallowTyCoVarsOfCos = runTyCoVars shallow_cos
+shallowTyCoVarsOfCo = runTyCoVars shallow_co
+shallowTyCoVarsOfCos = runTyCoVars shallow_cos
-- | Returns free variables of types, including kind variables as
-- a non-deterministic set. For type synonyms it does /not/ expand the
@@ -364,25 +396,21 @@ shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos)
-- It's OK to use nonDetEltsUFM here because we immediately
-- forget the ordering by returning a set
-shallow_ty :: TyCoFvFun Type TyCoVarSet
-shallow_tys :: TyCoFvFun [Type] TyCoVarSet
-shallow_co :: TyCoFvFun Coercion TyCoVarSet
-shallow_cos :: TyCoFvFun [Coercion] TyCoVarSet
+shallow_ty :: Type -> TyCoAcc TyCoVarSet
+shallow_tys :: [Type] -> TyCoAcc TyCoVarSet
+shallow_co :: Coercion -> TyCoAcc TyCoVarSet
+shallow_cos :: [Coercion] -> TyCoAcc TyCoVarSet
+
(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder
-shallowTcvFolder :: TyCoFolder InScopeBndrs (Endo TyCoVarSet)
+shallowTcvFolder :: TyCoFolder (TyCoAcc TyCoVarSet)
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
- where
- do_it acc | v `elemVarSet` is = acc
- | v `elemVarSet` acc = acc
- | otherwise = acc `extendVarSet` v
-
- do_bndr is tcv _ = extendVarSet is tcv
- do_hole _ _ = mempty -- Ignore coercion holes
+ do_hole _ = mempty -- Ignore coercion holes
+ do_tcv v = addTyCoVar v mempty
+ do_bndr tcv _vis fvs = extendInScope tcv fvs
{- *********************************************************************
@@ -412,61 +440,63 @@ coVarsOfTypes = runTyCoVars deep_cv_tys
coVarsOfCo = runTyCoVars deep_cv_co
coVarsOfCos = runTyCoVars deep_cv_cos
-deep_cv_ty :: TyCoFvFun Type TyCoVarSet
-deep_cv_tys :: TyCoFvFun [Type] TyCoVarSet
-deep_cv_co :: TyCoFvFun Coercion TyCoVarSet
-deep_cv_cos :: TyCoFvFun [Coercion] TyCoVarSet
+deep_cv_ty :: Type -> TyCoAcc TyCoVarSet
+deep_cv_tys :: [Type] -> TyCoAcc TyCoVarSet
+deep_cv_co :: Coercion -> TyCoAcc TyCoVarSet
+deep_cv_cos :: [Coercion] -> TyCoAcc TyCoVarSet
(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder
-deepCoVarFolder :: TyCoFolder InScopeBndrs (Endo CoVarSet)
+deepCoVarFolder :: TyCoFolder (TyCoAcc TyCoVarSet)
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
+ do_tyvar _ = mempty
-- This do_tyvar means we won't see any CoVars in this
-- TyVar's kind. This may be wrong; but it's the way it's
-- always been. And its awkward to change, because
-- the tyvar won't end up in the accumulator, so
-- we'd look repeatedly. Blargh.
- do_covar is v = Endo do_it
- where
- do_it acc | v `elemVarSet` is = acc
- | v `elemVarSet` acc = acc
- | otherwise = appEndo (deep_cv_ty emptyInScope (varType v)) $
- acc `extendVarSet` v
- -- emptyInScope: see Note [Closing over free variable kinds]
-
- do_bndr is tcv _ = extendVarSet is tcv
- do_hole is hole = do_covar is (coHoleCoVar hole)
+ do_covar cv = addTyCoVar cv (deep_ty (varType cv))
+
+ do_bndr tcv _vis fvs = extendInScope tcv fvs
+ do_hole hole = do_covar (coHoleCoVar hole)
-- See Note [CoercionHoles and coercion free variables]
-- in GHC.Core.TyCo.Rep
------- Same again, but for DCoVarSet ----------
coVarsOfCoDSet :: Coercion -> DCoVarSet
-coVarsOfCoDSet co = appEndo (deep_dcv_co emptyInScope co) emptyDVarSet
+coVarsOfCoDSet co = runTCA (deep_dcv_co co) emptyVarSet emptyDVarSet
-deep_dcv_ty :: TyCoFvFun Type DCoVarSet
-deep_dcv_co :: TyCoFvFun Coercion DCoVarSet
+deep_dcv_ty :: Type -> TyCoAcc DCoVarSet
+deep_dcv_co :: Coercion -> TyCoAcc DCoVarSet
(deep_dcv_ty, _, deep_dcv_co, _) = foldTyCo deepCoVarDSetFolder
-deepCoVarDSetFolder :: TyCoFolder InScopeBndrs (Endo DCoVarSet)
+deepCoVarDSetFolder :: TyCoFolder (TyCoAcc DCoVarSet)
deepCoVarDSetFolder = TyCoFolder { tcf_view = noView
, tcf_tyvar = do_tyvar, tcf_covar = do_covar
, tcf_hole = do_hole, tcf_tycobinder = do_bndr }
where
- do_tyvar _ _ = mempty
- do_covar is v = Endo do_it
- where
- do_it :: DCoVarSet -> DCoVarSet
- do_it acc | v `elemVarSet` is = acc
- | v `elemDVarSet` acc = acc
- | otherwise = appEndo (deep_dcv_ty emptyInScope (varType v)) $
- acc `extendDVarSet` v
- do_bndr is tcv _ = extendVarSet is tcv
- do_hole is hole = do_covar is (coHoleCoVar hole)
+ do_tyvar _ = mempty
+ do_covar cv = addCoVarDSet cv (deep_dcv_ty (varType cv))
+
+
+ do_bndr tcv _vis fvs = extendInScope tcv fvs
+ do_hole hole = do_covar (coHoleCoVar hole)
+
+addCoVarDSet :: CoVar -> TyCoAcc DCoVarSet -> TyCoAcc DCoVarSet
+-- Add a variable to the free vars unless it is in the in-scope
+-- or is already in the in-scope set-
+addCoVarDSet cv (TCA add_extras) = TCA add_it
+ where
+ add_it is acc | cv `elemVarSet` is = acc
+ | cv `elemDVarSet` acc = acc
+ | otherwise = add_extras emptyInScope $
+ acc `extendDVarSet` cv
+ -- emptyInScopeSet: see Note [Closing over free variable kinds]
+
{- *********************************************************************
* *
@@ -481,7 +511,7 @@ closeOverKinds :: TyCoVarSet -> TyCoVarSet
-- add the deep free variables of its kind
closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs
where
- do_one v acc = appEndo (deep_ty emptyVarSet (varType v)) acc
+ do_one v acc = runTCA (deep_ty (varType v)) emptyInScope acc
{- --------------- Alternative version 1 (using FV) ------------
closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet
@@ -876,29 +906,27 @@ injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under
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
+invis_tys :: [Type] -> TyCoAcc TyCoVarSet
+invis_tys [] = mempty
+invis_tys (ty:tys) = invis_ty ty `mappend` invis_tys tys
+
+invis_ty :: Type -> TyCoAcc TyCoVarSet
+invis_ty ty | Just ty' <- coreView ty
+ = invis_ty ty'
+
+invis_ty (TyVarTy v) = whenNotInScope v $
+ deep_ty (tyVarKind v)
+invis_ty (AppTy f a) = invis_ty f `mappend` invis_ty a
+invis_ty (FunTy _ w ty1 ty2) = invis_ty w `mappend` invis_ty ty1 `mappend` invis_ty ty2
+invis_ty (TyConApp tc tys) = deep_tys invisibles `mappend`
+ invis_tys 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
+invis_ty (ForAllTy (Bndr tv _) ty) = invis_ty (tyVarKind tv) `mappend`
+ extendInScope tv (invis_ty ty)
+invis_ty (LitTy {}) = mempty
+invis_ty (CastTy ty co) = deep_co co `mappend` invis_ty ty
+invis_ty (CoercionTy co) = deep_co co
+
{- *********************************************************************
* *
@@ -906,28 +934,31 @@ invis_ty is (CoercionTy co) = deep_co is co
* *
********************************************************************* -}
-nfvFolder :: TyCoFolder InScopeBndrs DM.All
+nfvFolder :: TyCoFolder (TyCoAcc Bool)
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)
- do_hole _ _ = All True -- I'm unsure; probably never happens
- do_bndr is tv _ = is `extendVarSet` tv
+ do_tcv tv = TCA (\is acc -> acc && tv `elemVarSet` is)
+ do_hole _ = mempty -- I'm unsure; probably never happens
+ do_bndr tv _vis fvs = extendInScope tv fvs
-nfv_ty :: InScopeBndrs -> Type -> DM.All
-nfv_tys :: InScopeBndrs -> [Type] -> DM.All
-nfv_co :: InScopeBndrs -> Coercion -> DM.All
+nfv_ty :: Type -> TyCoAcc Bool
+nfv_tys :: [Type] -> TyCoAcc Bool
+nfv_co :: Coercion -> TyCoAcc Bool
(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder
-noFreeVarsOfType :: Type -> Bool
-noFreeVarsOfType ty = DM.getAll (nfv_ty emptyInScope ty)
+runAll :: TyCoAcc Bool -> Bool
+runAll (TCA f) = f emptyInScope True
+noFreeVarsOfType :: Type -> Bool
noFreeVarsOfTypes :: [Type] -> Bool
-noFreeVarsOfTypes tys = DM.getAll (nfv_tys emptyInScope tys)
+noFreeVarsOfCo :: Coercion -> Bool
+
+noFreeVarsOfType ty = runAll (nfv_ty ty)
+noFreeVarsOfTypes tys = runAll (nfv_tys tys)
+noFreeVarsOfCo co = runAll (nfv_co co)
-noFreeVarsOfCo :: Coercion -> Bool
-noFreeVarsOfCo co = DM.getAll (nfv_co emptyInScope co)
{- *********************************************************************
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1883,18 +1883,17 @@ TyCoFolder data constructor for deep_tcf as a loop breaker, so the
record selections still cancel. And eta expansion still happens too.
-}
-data TyCoFolder env a
+data TyCoFolder a
= TyCoFolder
{ 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
+ , tcf_tyvar :: TyVar -> a
+ , tcf_covar :: CoVar -> a
+ , tcf_hole :: CoercionHole -> a
-- ^ What to do with coercion holes.
-- See Note [Coercion holes] in "GHC.Core.TyCo.Rep".
- , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env
- -- ^ The returned env is used in the extended scope
+ , tcf_tycobinder :: TyCoVar -> ArgFlag -> a -> a
}
noView :: Type -> Maybe Type -- Simplest form of tcf_view
@@ -1902,11 +1901,11 @@ noView :: Type -> Maybe Type -- Simplest form of tcf_view
noView _ = Nothing
{-# INLINE foldTyCo #-} -- See Note [Specialising foldType]
-foldTyCo :: Monoid a => TyCoFolder env a
- -> ( env -> Type -> a
- , env -> [Type] -> a
- , env -> Coercion -> a
- , env -> [Coercion] -> a )
+foldTyCo :: Monoid a => TyCoFolder a
+ -> ( Type -> a
+ , [Type] -> a
+ , Coercion -> a
+ , [Coercion] -> a )
foldTyCo (TyCoFolder { tcf_view = view
, tcf_tyvar = tyvar
, tcf_tycobinder = tycobinder
@@ -1914,61 +1913,58 @@ foldTyCo (TyCoFolder { tcf_view = view
, tcf_hole = cohole })
= (go_ty, go_tys, go_co, go_cos)
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
- go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co
- go_ty env (CoercionTy co) = go_co env co
- go_ty env (FunTy _ w arg res) = go_ty env w `mappend` 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 -- Avoid building a thunk here
- in go_ty env (varType tv) `mappend` go_ty env' inner
+ go_ty ty | Just ty' <- view ty = go_ty ty'
+ go_ty (TyVarTy tv) = tyvar tv
+ go_ty (AppTy t1 t2) = go_ty t1 `mappend` go_ty t2
+ go_ty (LitTy {}) = mempty
+ go_ty (CastTy ty co) = go_ty ty `mappend` go_co co
+ go_ty (CoercionTy co) = go_co co
+ go_ty (FunTy _ w arg res) = go_ty w `mappend` go_ty arg `mappend` go_ty res
+ go_ty (TyConApp _ tys) = go_tys tys
+ go_ty (ForAllTy (Bndr tv vis) inner)
+ = go_ty (varType tv) `mappend` tycobinder tv vis (go_ty inner)
-- Explicit recursion becuase using foldr builds a local
- -- loop (with env free) and I'm not confident it'll be
+ -- loop (with free) and I'm not confident it'll be
-- lambda lifted in the end
- go_tys _ [] = mempty
- go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts
-
- go_cos _ [] = mempty
- go_cos env (c:cs) = go_co env c `mappend` go_cos env cs
-
- go_co env (Refl ty) = go_ty env ty
- go_co env (GRefl _ ty MRefl) = go_ty env ty
- go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co
- go_co env (TyConAppCo _ _ args) = go_cos env args
- go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2
- go_co env (FunCo _ cw c1 c2) = go_co env cw `mappend`
- go_co env c1 `mappend`
- go_co env c2
- go_co env (CoVarCo cv) = covar env cv
- go_co env (AxiomInstCo _ _ args) = go_cos env args
- go_co env (HoleCo hole) = cohole env hole
- go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1
- `mappend` go_ty env t2
- go_co env (SymCo co) = go_co env co
- go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2
- go_co env (AxiomRuleCo _ cos) = go_cos env cos
- go_co env (NthCo _ _ co) = go_co env co
- go_co env (LRCo _ co) = go_co env co
- go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg
- go_co env (KindCo co) = go_co env co
- go_co env (SubCo co) = go_co env co
- go_co env (ForAllCo tv kind_co co)
- = go_co env kind_co `mappend` go_ty env (varType tv)
- `mappend` go_co env' co
- where
- env' = tycobinder env tv Inferred
-
- 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
+ go_tys [] = mempty
+ go_tys (t:ts) = go_ty t `mappend` go_tys ts
+
+ go_cos [] = mempty
+ go_cos (c:cs) = go_co c `mappend` go_cos cs
+
+ go_co (Refl ty) = go_ty ty
+ go_co (GRefl _ ty MRefl) = go_ty ty
+ go_co (GRefl _ ty (MCo co)) = go_ty ty `mappend` go_co co
+ go_co (TyConAppCo _ _ args) = go_cos args
+ go_co (AppCo c1 c2) = go_co c1 `mappend` go_co c2
+ go_co (FunCo _ cw c1 c2) = go_co cw `mappend`
+ go_co c1 `mappend`
+ go_co c2
+ go_co (CoVarCo cv) = covar cv
+ go_co (AxiomInstCo _ _ args) = go_cos args
+ go_co (HoleCo hole) = cohole hole
+ go_co (UnivCo p _ t1 t2) = go_prov p `mappend` go_ty t1
+ `mappend` go_ty t2
+ go_co (SymCo co) = go_co co
+ go_co (TransCo c1 c2) = go_co c1 `mappend` go_co c2
+ go_co (AxiomRuleCo _ cos) = go_cos cos
+ go_co (NthCo _ _ co) = go_co co
+ go_co (LRCo _ co) = go_co co
+ go_co (InstCo co arg) = go_co co `mappend` go_co arg
+ go_co (KindCo co) = go_co co
+ go_co (SubCo co) = go_co co
+ go_co (ForAllCo tv kind_co co)
+ = go_co kind_co `mappend` go_ty (varType tv)
+ `mappend` tycobinder tv Inferred (go_co co)
+
+ go_prov (ZapCoProv cvs) = go_cvs (dVarSetElems cvs)
+ go_prov (PhantomProv co) = go_co co
+ go_prov (ProofIrrelProv co) = go_co co
+ go_prov (PluginProv _) = mempty
+
+ go_cvs [] = mempty
+ go_cvs (cv:cvs) = covar cv `mappend` go_cvs cvs
{- *********************************************************************
* *
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1316,6 +1316,7 @@ newtype UM a
pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a
-- See Note [The one-shot state monad trick]
+{-# COMPLETE UM #-}
pattern UM m <- UM' m
where
UM m = UM' (oneShot m)
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -937,11 +937,11 @@ exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet
exactTyCoVarsOfType = runTyCoVars exact_ty
exactTyCoVarsOfTypes = runTyCoVars exact_tys
-exact_ty :: TyCoFvFun Type TyCoVarSet
-exact_tys :: TyCoFvFun [Type] TyCoVarSet
+exact_ty :: Type -> TyCoAcc TyCoVarSet
+exact_tys :: [Type] -> TyCoAcc TyCoVarSet
(exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder
-exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)
+exactTcvFolder :: TyCoFolder (TyCoAcc TyCoVarSet)
exactTcvFolder = deepTcvFolder { tcf_view = tcView }
-- This is the key line
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -4,7 +4,7 @@
-}
-{-# LANGUAGE CPP, TupleSections #-}
+{-# LANGUAGE CPP, TupleSections, PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
@@ -94,6 +94,7 @@ import Control.Monad
import Data.Semigroup as Semigroup
import Data.List ( partition )
import Control.Arrow ( second )
+import GHC.Exts ( oneShot )
{-
************************************************************************
@@ -1920,54 +1921,63 @@ zapCoercion ze co = do { t1 <- zonkTcTypeToTypeX ze t1
coVarsOfCoM :: TcCoercion -> TcM DCoVarSet
-- Find the free CoVars of an un-zonked TcCoercion -- but without
-- zonking it and returning a perhaps large new coercion
-coVarsOfCoM co = runEndoM (co_vars_of_co FVs.emptyInScope co) emptyDVarSet
+coVarsOfCoM co = runTCAM (co_vars_of_co co) FVs.emptyInScope emptyDVarSet
-co_vars_of_co :: FVs.InScopeBndrs -> TcCoercion -> EndoM TcM DCoVarSet
-co_vars_of_ty :: FVs.InScopeBndrs -> TcType -> EndoM TcM DCoVarSet
+co_vars_of_co :: TcCoercion -> TyCoAccM TcM DCoVarSet
+co_vars_of_ty :: TcType -> TyCoAccM TcM DCoVarSet
(co_vars_of_ty, _, co_vars_of_co, _) = foldTyCo co_vars_folder
-co_vars_folder :: TyCoFolder FVs.InScopeBndrs (EndoM TcM DCoVarSet)
+co_vars_folder :: TyCoFolder (TyCoAccM TcM DCoVarSet)
co_vars_folder = TyCoFolder { tcf_view = noView
, tcf_tyvar = do_tyvar, tcf_covar = do_covar
, tcf_hole = do_hole, tcf_tycobinder = do_bndr }
where
- do_tyvar _ _ = mempty
- do_covar is v = EndoM do_it
+ do_tyvar _ = mempty
+ do_covar v = TCAM do_it
where
- do_it :: DCoVarSet -> TcM DCoVarSet
- do_it acc | v `elemVarSet` is = return acc
- | v `elemDVarSet` acc = return acc
- | otherwise = runEndoM (co_vars_of_ty is (varType v)) $
- acc `extendDVarSet` v
- do_bndr is tcv _ = extendVarSet is tcv
-
- do_hole :: FVs.InScopeBndrs -> CoercionHole -> EndoM TcM DCoVarSet
- do_hole is hole@(CoercionHole { ch_ref = ref })
- = EndoM $ \ acc ->
+ do_it :: InScopeBndrs -> DCoVarSet -> TcM DCoVarSet
+ do_it is acc | v `elemVarSet` is = return acc
+ | v `elemDVarSet` acc = return acc
+ | otherwise = runTCAM (co_vars_of_ty (varType v)) emptyInScope $
+ acc `extendDVarSet` v
+ do_bndr tcv _vis fvs = extendInScopeM tcv fvs
+
+ do_hole :: CoercionHole -> TyCoAccM TcM DCoVarSet
+ do_hole hole@(CoercionHole { ch_ref = ref })
+ = TCAM $ \ is acc ->
do { contents <- readTcRef ref
; case contents of
- Just co -> runEndoM (co_vars_of_co is co) acc
+ Just co -> runTCAM (co_vars_of_co co) is acc
Nothing -> do { traceTc "Zonking unfilled coercion hole (zap)" (ppr hole)
; return acc } }
--------------------------------------
--- EndoM is copied from package 'foldl', but I don't want
--- to add a new dependency to GHC for 6 lines of code
-newtype EndoM m a = EndoM { runEndoM :: a -> m a }
+-- Based on EndoM in package 'foldl', but with added InScopeBndrs
+-- c.f. TyCoAcc in GHC.Core.TyCo.FVs
+newtype TyCoAccM m acc = TCAM' { runTCAM :: FVs.InScopeBndrs -> acc -> m acc }
-instance Monad m => Semigroup (EndoM m a) where
- (EndoM f) <> (EndoM g) = EndoM (f <=< g)
+pattern TCAM :: forall m acc. (InScopeBndrs -> acc -> m acc) -> TyCoAccM m acc
+{-# COMPLETE TCAM #-}
+pattern TCAM f <- TCAM' f
+ where
+ TCAM f = TCAM' (oneShot f)
+
+extendInScopeM :: TyCoVar -> TyCoAccM m acc -> TyCoAccM m acc
+-- Gather the argument free vars in an empty in-scope set
+extendInScopeM tcv (TCAM f) = TCAM (\is acc -> f (is `extendVarSet` tcv) acc)
+
+instance Monad m => Semigroup (TyCoAccM m a) where
+ (TCAM f) <> (TCAM g) = TCAM (\is acc -> do { acc <- f is acc
+ ; g is acc })
{-# INLINE (<>) #-}
-instance Monad m => Monoid (EndoM m a) where
- mempty = EndoM return
+instance Monad m => Monoid (TyCoAccM m a) where
+ mempty = TCAM (\_ acc -> return acc)
{-# INLINE mempty #-}
mappend = (Semigroup.<>)
{-# INLINE mappend #-}
--- End of copy
---------------------------------------
-
+--------------------------------------
zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/16ef62d4e72205a79fcdf33726f920e27ed490e2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/16ef62d4e72205a79fcdf33726f920e27ed490e2
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/61261ba7/attachment-0001.html>
More information about the ghc-commits
mailing list