[Git][ghc/ghc][wip/T21623] Really add mkWpEta
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Aug 16 16:48:08 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
c38e4d35 by Simon Peyton Jones at 2022-08-16T17:49:04+01:00
Really add mkWpEta
- - - - -
5 changed files:
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Unify.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -949,7 +949,7 @@ tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc })
; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
; let poly_wrap = wrap
<.> mkWpTyLams qtvs
- <.> mkWpLams givens
+ <.> mkWpEvLams givens
<.> mkWpLet ev_binds
; return (mkLHsWrap poly_wrap expr', my_sigma) }
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -1785,7 +1785,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
meth_tau = classMethodInstTy sel_id inst_tys
error_string dflags = showSDoc dflags
(hcat [ppr inst_loc, vbar, ppr sel_id ])
- lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
+ lam_wrapper = mkWpTyLams tyvars <.> mkWpEvLams dfun_ev_vars
----------------------
-- Check if one of the minimal complete definitions is satisfied
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -8,7 +8,7 @@ module GHC.Tc.Types.Evidence (
-- * HsWrapper
HsWrapper(..),
(<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,
- mkWpLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR,
+ mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta,
collectHsWrapBinders,
idHsWrapper, isIdHsWrapper,
pprHsWrapper, hsWrapDictBinders,
@@ -68,6 +68,7 @@ import GHC.Prelude
import GHC.Types.Unique.DFM
import GHC.Types.Unique.FM
import GHC.Types.Var
+import GHC.Types.Id( idScaledType )
import GHC.Core.Coercion.Axiom
import GHC.Core.Coercion
import GHC.Core.Ppr () -- Instance OutputableBndr TyVar
@@ -239,7 +240,8 @@ data HsWrapper
-- then WpFun wrap1 wrap2 : (act_arg -> arg_res) ~> (exp_arg -> exp_res)
-- This isn't the same as for mkFunCo, but it has to be this way
-- because we can't use 'sym' to flip around these HsWrappers
- -- The TcType is the "from" type of the first wrapper
+ -- The TcType is the "from" type of the first wrapper;
+ -- it always a Type, not a Constraint
--
-- NB: a WpFun is always for a VisArg, with (->) function arrow
--
@@ -251,8 +253,11 @@ data HsWrapper
-- Evidence abstraction and application
-- (both dictionaries and coercions)
+ -- Both WpEvLam and WpEvApp abstract and apply values
+ -- of kind Constraint or Constraint#
| WpEvLam EvVar -- \d. [] the 'd' is an evidence variable
| WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint
+
-- Kind and Type abstraction and application
| WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var)
| WpTyApp KindOrType -- [] t the 't' is a type (not coercion)
@@ -297,8 +302,8 @@ c1 <.> c2 = c1 `WpCompose` c2
mkWpFun :: HsWrapper -> HsWrapper
-> Scaled TcTypeFRR -- ^ the "from" type of the first wrapper
-- MUST have a fixed RuntimeRep
- -> TcType -- ^ either type of the second wrapper (used only when the
- -- second wrapper is the identity)
+ -> TcType -- ^ Either "from" type or "to" type of the second wrapper
+ -- (used only when the second wrapper is the identity)
-> HsWrapper
-- NB: we can't check that the argument type has a fixed RuntimeRep with an assertion,
-- because of [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep]
@@ -309,6 +314,14 @@ mkWpFun (WpCast co1) WpHole (Scaled w _) t2 = WpCast (mk_fun_co w (mkTcSy
mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ = WpCast (mk_fun_co w (mkTcSymCo co1) co2)
mkWpFun co1 co2 t1 _ = WpFun co1 co2 t1
+mkWpEta :: [Id] -> HsWrapper -> HsWrapper
+-- (mkWpEta [x1, x2] wrap) [e]
+-- = \x1. \x2. wrap[e x1 x2]
+-- Just generates a bunch of WpFuns
+mkWpEta xs wrap = foldr eta_one wrap xs
+ where
+ eta_one x wrap = WpFun idHsWrapper wrap (idScaledType x)
+
mk_fun_co :: Mult -> TcCoercionR -> TcCoercionR -> TcCoercionR
mk_fun_co mult arg_co res_co
= mkTcFunCo Representational (multToCo mult) arg_co res_co
@@ -338,8 +351,8 @@ mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs)
mkWpTyLams :: [TyVar] -> HsWrapper
mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
-mkWpLams :: [Var] -> HsWrapper
-mkWpLams ids = mk_co_lam_fn WpEvLam ids
+mkWpEvLams :: [Var] -> HsWrapper
+mkWpEvLams ids = mk_co_lam_fn WpEvLam ids
mkWpLet :: TcEvBinds -> HsWrapper
-- This no-op is a quite a common case
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -187,7 +187,7 @@ topSkolemise skolem_info ty
= do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs
; ev_vars1 <- newEvVars (substTheta subst' theta)
; go subst'
- (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1)
+ (wrap <.> mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1)
(tv_prs ++ (map tyVarName tvs `zip` tvs1))
(ev_vars ++ ev_vars1)
inner_ty }
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -1381,11 +1381,9 @@ deeplySkolemise skol_info ty
; ev_vars1 <- newEvVars (substTheta subst' theta)
; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
; let tv_prs1 = map tyVarName tvs `zip` tvs1
- ; return ( mkWpLams ids1
- <.> mkWpTyLams tvs1
- <.> mkWpLams ev_vars1
- <.> wrap
- <.> mkWpEvVarApps ids1
+ ; return ( mkWpEta ids1 (mkWpTyLams tvs1
+ <.> mkWpEvLams ev_vars1
+ <.> wrap)
, tv_prs1 ++ tvs_prs2
, ev_vars1 ++ ev_vars2
, mkScaledFunTys arg_tys' rho ) }
@@ -1408,10 +1406,7 @@ deeplyInstantiate orig ty
; ids1 <- newSysLocalIds (fsLit "di") arg_tys'
; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
; (wrap2, rho2) <- go subst' rho
- ; return (mkWpLams ids1
- <.> wrap2
- <.> wrap1
- <.> mkWpEvVarApps ids1,
+ ; return (mkWpEta ids1 (wrap2 <.> wrap1),
mkScaledFunTys arg_tys' rho2) }
| otherwise
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c38e4d35b842d4d9c7e9fa448703570eab965e18
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c38e4d35b842d4d9c7e9fa448703570eab965e18
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/20220816/0fd303de/attachment-0001.html>
More information about the ghc-commits
mailing list