[Git][ghc/ghc][wip/T17775] Wibbles
Simon Peyton Jones
gitlab at gitlab.haskell.org
Wed Apr 29 18:47:55 UTC 2020
Simon Peyton Jones pushed to branch wip/T17775 at Glasgow Haskell Compiler / GHC
Commits:
d6553dc5 by Simon Peyton Jones at 2020-04-29T19:47:04+01:00
Wibbles
Especially make major improvement to hsWrapDictBinders
- - - - -
4 changed files:
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Unify.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -365,7 +365,7 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty
; let doc = text "The first argument of ($) takes"
orig1 = lexprCtOrigin arg1
; (wrap_arg1, [arg2_sigma], op_res_ty) <-
- matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty
+ matchActualFunTysRho doc orig1 (Just (unLoc arg1)) 1 arg1_ty
-- We have (arg1 $ arg2)
-- So: arg1_ty = arg2_ty -> op_res_ty
@@ -381,7 +381,7 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty
(tcTypeKind arg2_sigma) liftedTypeKind
-- Ignore the evidence. arg2_sigma must have type * or #,
-- because we know (arg2_sigma -> op_res_ty) is well-kinded
- -- (because otherwise matchActualFunTys would fail)
+ -- (because otherwise matchActualFunTysRho would fail)
-- So this 'unifyKind' will either succeed with Refl, or will
-- produce an insoluble constraint * ~ #, which we'll report later.
@@ -415,7 +415,8 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty
; (op', op_ty) <- tcInferRhoNC op
; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
- <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty
+ <- matchActualFunTysRho (mk_op_msg op) fn_orig
+ (Just (unLoc op)) 2 op_ty
-- You might think we should use tcInferApp here, but there is
-- too much impedance-matching, because tcApp may return wrappers as
-- well as type-checked arguments.
@@ -435,7 +436,8 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty
tcExpr expr@(SectionR x op arg2) res_ty
= do { (op', op_ty) <- tcInferRhoNC op
; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
- <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty
+ <- matchActualFunTysRho (mk_op_msg op) fn_orig
+ (Just (unLoc op)) 2 op_ty
; arg2' <- tcArg (unLoc op) arg2 arg2_ty 2
; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2'
act_res_ty = mkVisFunTy arg1_ty op_res_ty
@@ -454,8 +456,8 @@ tcExpr expr@(SectionL x arg1 op) res_ty
| otherwise = 2
; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
- <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op))
- n_reqd_args op_ty
+ <- matchActualFunTysRho (mk_op_msg op) fn_orig
+ (Just (unLoc op)) n_reqd_args op_ty
; arg1' <- tcArg (unLoc op) arg1 arg1_ty 1
; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op')
act_res_ty = mkVisFunTys arg_tys op_res_ty
@@ -1401,8 +1403,8 @@ tcArgs fun orig_fun_ty orig_args
go n so_far fun_ty (HsEValArg loc arg : args)
= do { (wrap, arg_ty, res_ty)
- <- matchActualFunTy herald fun_orig (Just fun)
- (n_val_args, so_far) fun_ty
+ <- matchActualFunTySigma herald fun_orig (Just fun)
+ (n_val_args, so_far) fun_ty
; arg' <- tcArg fun arg arg_ty n
; (args', inner_res_ty) <- go (n+1) (arg_ty:so_far) res_ty args
; return ( addArgWrap wrap $ HsEValArg loc arg' : args'
@@ -1640,7 +1642,8 @@ tcSynArgA :: CtOrigin
-- and a wrapper to be applied to the overall expression
tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
= do { (match_wrapper, arg_tys, res_ty)
- <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty
+ <- matchActualFunTysRho herald orig Nothing
+ (length arg_shapes) sigma_ty
-- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -413,7 +413,7 @@ tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
; let expr_orig = lexprCtOrigin expr
herald = text "A view pattern expression expects"
; (expr_wrap1, [inf_arg_ty], inf_res_ty)
- <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr_ty
+ <- matchActualFunTysRho herald expr_orig (Just (unLoc expr)) 1 expr_ty
-- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_ty)
-- Check that overall pattern is more polymorphic than arg type
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -383,11 +383,7 @@ hsWrapDictBinders wrap = go wrap emptyBag
go (WpEvApp {}) acc = acc
go (WpTyLam {}) acc = acc
go (WpTyApp {}) acc = acc
- go (WpLet binds) acc = go_binds binds `unionBags` acc
-
- go_binds (EvBinds bs) = mapBag eb_lhs bs
- go_binds (TcEvBinds ebv) = pprPanic "hsWrapperDictBinds" (ppr ebv)
- -- Should only be applied post zonking
+ go (WpLet _) acc = acc
collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper)
-- Collect the outer lambda binders of a HsWrapper,
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -31,7 +31,7 @@ module GHC.Tc.Utils.Unify (
matchExpectedTyConApp,
matchExpectedAppTy,
matchExpectedFunTys,
- matchActualFunTys, matchActualFunTy,
+ matchActualFunTysRho, matchActualFunTySigma,
matchExpectedFunKind,
metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..)
@@ -232,26 +232,27 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside
-- Like 'matchExpectedFunTys', but used when you have an "actual" type,
-- for example in function application
--- This function instantiates at each polytype.
-matchActualFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys]
- -> CtOrigin
- -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType
- -> Arity
- -> TcSigmaType
- -> TcM (HsWrapper, [TcSigmaType], TcRhoType)
--- If matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty)
+matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys]
+ -> CtOrigin
+ -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType
+ -> Arity
+ -> TcSigmaType
+ -> TcM (HsWrapper, [TcSigmaType], TcRhoType)
+-- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty)
-- then wrap : ty ~> (t1 -> ... -> tn -> res_ty)
-- and res_ty is a RhoType
-matchActualFunTys herald ct_orig mb_thing n_val_args_wanted fun_ty
+-- NB: the returned type is top-instantiated; it's a RhoType
+matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty
= go n_val_args_wanted [] fun_ty
where
go 0 _ fun_ty
= do { (wrap, rho) <- topInstantiate ct_orig fun_ty
; return (wrap, [], rho) }
go n so_far fun_ty
- = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy herald ct_orig mb_thing
- (n_val_args_wanted, so_far)
- fun_ty
+ = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma
+ herald ct_orig mb_thing
+ (n_val_args_wanted, so_far)
+ fun_ty
; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty doc
; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }
@@ -259,9 +260,9 @@ matchActualFunTys herald ct_orig mb_thing n_val_args_wanted fun_ty
doc = text "When inferring the argument type of a function with type" <+>
quotes (ppr fun_ty)
--- | Variant of 'matchActualFunTys' that works when supplied only part
--- (that is, to the right of some arrows) of the full function type
-matchActualFunTy
+-- | matchActualFunTySigm does looks for just one function arrow
+-- returning an uninstantiated sigma-type
+matchActualFunTySigma
:: SDoc -- See Note [Herald for matchExpectedFunTys]
-> CtOrigin
-> Maybe (HsExpr GhcRn) -- The thing with type TcSigmaType
@@ -269,13 +270,15 @@ matchActualFunTy
-- types of values args to which function has
-- been applied already (reversed)
-- Both are used only for error messages)
- -> TcSigmaType -- Type to analyse
+ -> TcSigmaType -- Type to analyse
-> TcM (HsWrapper, TcSigmaType, TcSigmaType)
-- See Note [matchActualFunTys error handling] for all these arguments
--- If (wrap, arg_ty, res_ty) = matchActualFunTy ... fun_ty
+
+-- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty
-- then wrap :: fun_ty ~> (arg_ty -> res_ty)
-- and NB: res_ty is an (uninstantiated) SigmaType
-matchActualFunTy herald ct_orig mb_thing err_info fun_ty
+
+matchActualFunTySigma herald ct_orig mb_thing err_info fun_ty
= go fun_ty
-- Does not allocate unnecessary meta variables: if the input already is
-- a function, we just take it apart. Not only is this efficient,
@@ -291,19 +294,7 @@ matchActualFunTy herald ct_orig mb_thing err_info fun_ty
-- in elsewhere).
where
- -- This function has a bizarre mechanic: it accumulates arguments on
- -- the way down and also builds an argument list on the way up. Why:
- -- 1. The returns args list and the accumulated args list might be different.
- -- The accumulated args include all the arg types for the function,
- -- including those from before this function was called. The returned
- -- list should include only those arguments produced by this call of
- -- matchActualFunTys
- --
- -- 2. The HsWrapper can be built only on the way up. It seems (more)
- -- bizarre to build the HsWrapper but not the arg_tys.
- --
- -- Refactoring is welcome.
- go :: TcSigmaType -- the remainder of the type as we're processing
+ go :: TcSigmaType -- The remainder of the type as we're processing
-> TcM (HsWrapper, TcSigmaType, TcSigmaType)
go ty | Just ty' <- tcView ty = go ty'
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6553dc57a254eba88e7244ad1581957f616a9d2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6553dc57a254eba88e7244ad1581957f616a9d2
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/20200429/906edc42/attachment-0001.html>
More information about the ghc-commits
mailing list