Simon Peyton Jones pushed to branch wip/T26349 at Glasgow Haskell Compiler / GHC Commits: 2004c1aa by Simon Peyton Jones at 2025-10-26T23:43:34+00:00 More - - - - - 5 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -809,7 +809,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args = do { let herald = case fun_ctxt of VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) - ; (wrap, arg_ty, res_ty) <- + ; (fun_co, arg_ty, res_ty) <- -- NB: matchActualFunTy does the rep-poly check. -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int -- In an application (f x), we need 'x' to have a fixed runtime @@ -820,7 +820,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args (n_val_args, fun_sigma) fun_ty ; arg' <- quickLookArg do_ql ctxt arg arg_ty - ; let acc' = arg' : addArgWrap wrap acc + ; let acc' = arg' : addArgWrap (mkWpCastN fun_co) acc ; go (pos+1) acc' res_ty rest_args } new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -765,13 +765,13 @@ tcInferOverLit lit@(OverLit { ol_val = val thing = NameThing from_name mb_thing = Just thing herald = ExpectedFunTyArg thing (HsLit noExtField hs_lit) - ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty + ; (co2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ HsLit noExtField hs_lit - from_expr = mkHsWrap (wrap2 <.> wrap1) $ + from_expr = mkHsWrap (mkWpCastN co2 <.> wrap1) $ mkHsVar (L loc from_id) witness = HsApp noExtField (L (l2l loc) from_expr) lit_expr lit' = OverLit { ol_val = val ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -701,7 +701,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- Expression must be a function ; let herald = ExpectedFunTyViewPat $ unLoc expr - ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) + ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma) <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho -- See Note [View patterns and polymorphism] -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma) @@ -722,7 +722,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- NB: pat_ty comes from matchActualFunTy, so it has a -- fixed RuntimeRep, as needed to call mkWpFun. - expr_wrap = expr_wrap2' <.> expr_wrap1 + expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1 ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) } ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -290,19 +290,24 @@ mkWpFun :: HsWrapper -> HsWrapper -> TcType -- ^ Either "from" type or "to" type of the second wrapper -- (used only when the second wrapper is the identity) -> HsWrapper -mkWpFun WpHole WpHole _ _ = WpHole -mkWpFun w_arg w_res t1 t2 = WpFun w_arg w_res t1 t2 - -- In this case, we will desugar to a lambda - -- - -- \x. w_res[ e w_arg[x] ] - -- - -- To satisfy Note [Representation polymorphism invariants] in GHC.Core, - -- it must be the case that both the lambda bound variable x and the function - -- argument w_arg[x] have a fixed runtime representation, i.e. that both the - -- "from" and "to" types of the first wrapper "w_arg" have a fixed runtime representation. - -- - -- Unfortunately, we can't check this with an assertion here, because of - -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. +mkWpFun w1 w2 st1@(Scaled m1 t1) t2 + = case (w1,w2) of + (WpHole, WpHole) -> WpHole + (WpHole, WpCast co2) -> WpCast (mk_wp_fun_co m1 (mkRepReflCo t1) co2) + (WpCast co1, WpHole) -> WpCast (mk_wp_fun_co m1 (mkSymCo co1) (mkRepReflCo t2)) + (WpCast co1, WpCast co2) -> WpCast (mk_wp_fun_co m1 (mkSymCo co1) co2) + (_, _) -> WpFun w1 w2 st1 t2 + -- In the WpFun case, we will desugar to a lambda + -- + -- \x. w_res[ e w_arg[x] ] + -- + -- To satisfy Note [Representation polymorphism invariants] in GHC.Core, + -- it must be the case that both the lambda bound variable x and the function + -- argument w_arg[x] have a fixed runtime representation, i.e. that both the + -- "from" and "to" types of the first wrapper "w_arg" have a fixed runtime representation. + -- + -- Unfortunately, we can't check this with an assertion here, because of + -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. mkWpSubType :: HsWrapper -> HsWrapper -- See (DSST2) in Note [Deep subsumption and WpSubType] @@ -446,7 +451,7 @@ optSubTypeHsWrapper wrap opt1 (WpEvLam ev) ws = opt_ev_lam ev ws opt1 (WpTyLam tv) ws = opt_ty_lam tv ws opt1 (WpLet binds) ws = pushWpLet binds ws - opt1 (WpFun w1 w2 sty1 ty2) ws = mk_wp_fun (opt w1) (opt w2) sty1 ty2 ws + opt1 (WpFun w1 w2 sty1 ty2) ws = opt_fun w1 w2 sty1 ty2 ws opt1 w@(WpTyApp {}) ws = w : ws opt1 w@(WpEvApp {}) ws = w : ws @@ -459,6 +464,7 @@ optSubTypeHsWrapper wrap opt_ty_lam tv (WpTyApp ty : ws) | Just tv' <- getTyVar_maybe ty , tv==tv' + , all (not_in tv) ws = ws -- (WpTyLam a <+> WpCastCo co <+> w) @@ -475,6 +481,7 @@ optSubTypeHsWrapper wrap opt_ev_lam ev (WpEvApp ev_tm : ws) | EvExpr (Var ev') <- ev_tm , ev == ev' + , all (not_in ev) ws = ws -- (WpEvLam ev <.> WpCast co <.> w) @@ -497,15 +504,28 @@ optSubTypeHsWrapper wrap | otherwise = WpCast co : ws ------------------ - mk_wp_fun w1 w2 sty1@(Scaled w t1) ty2 ws - = case (w1, w2) of - (WpHole, WpHole) -> ws - (WpHole, WpCast co2) -> co_ify (mkRepReflCo t1) co2 - (WpCast co1, WpHole) -> co_ify (mkSymCo co1) (mkRepReflCo ty2) - (WpCast co1, WpCast co2) -> co_ify (mkSymCo co1) co2 - (w1', w2') -> WpFun w1' w2' sty1 ty2 : ws - where - co_ify co1 co2 = opt_co (mk_wp_fun_co w co1 co2) ws + opt_fun w1 w2 sty1 ty2 ws + = case mkWpFun (opt w1) (opt w2) sty1 ty2 of + WpHole -> ws + WpCast co -> opt_co co ws + w -> w : ws + + ------------------ + -- Tiresome check that the lambda-bound type/evidence variable that we + -- want to eta-reduce isn't free in the rest of the wrapper + not_in :: TyVar -> HsWrapper -> Bool + not_in _ WpHole = True + not_in v (WpCast co) = not (anyFreeVarsOfCo (== v) co) + not_in v (WpTyApp ty) = not (anyFreeVarsOfType (== v) ty) + not_in v (WpFun w1 w2 _ _) = not_in v w1 && not_in v w2 + not_in v (WpSubType w) = not_in v w + not_in v (WpCompose w1 w2) = not_in v w1 && not_in v w2 + not_in v (WpEvApp (EvExpr e)) = not (v `elemVarSet` exprFreeVars e) + not_in _ (WpEvApp (EvTypeable {})) = False -- Giving up; conservative + not_in _ (WpEvApp (EvFun {})) = False -- Giving up; conservative + not_in _ (WpTyLam {}) = False -- Give up; conservative + not_in _ (WpEvLam {}) = False -- Ditto + not_in _ (WpLet {}) = False -- Ditto pushWpLet :: TcEvBinds -> [HsWrapper] -> [HsWrapper] -- See if we can transform ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -147,7 +147,7 @@ matchActualFunTy -- (Both are used only for error messages) -> TcRhoType -- ^ Type to analyse: a TcRhoType - -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) + -> TcM (TcCoercion, Scaled TcSigmaTypeFRR, TcSigmaType) -- This function takes in a type to analyse (a RhoType) and returns -- an argument type and a result type (splitting apart a function arrow). -- The returned argument type is a SigmaType with a fixed RuntimeRep; @@ -171,13 +171,13 @@ matchActualFunTy herald mb_thing err_info fun_ty -- hide the forall inside a meta-variable go :: TcRhoType -- The type we're processing, perhaps after -- expanding type synonyms - -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) + -> TcM (TcCoercion, Scaled TcSigmaTypeFRR, TcSigmaType) go ty | Just ty' <- coreView ty = go ty' go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty - ; return (idHsWrapper, Scaled w arg_ty, res_ty) } + ; return (mkNomReflCo fun_ty, Scaled w arg_ty, res_ty) } go ty@(TyVarTy tv) | isMetaTyVar tv @@ -209,7 +209,7 @@ matchActualFunTy herald mb_thing err_info fun_ty ; res_ty <- newOpenFlexiTyVarTy ; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; return (mkWpCastN co, arg_ty, res_ty) } + ; return (co, arg_ty, res_ty) } ------------ mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) @@ -248,8 +248,8 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected -> Arity -> TcSigmaType -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) --- If matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty) --- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) +-- If matchActualFunTys n fun_ty = (wrap, [t1,..,tn], res_ty) +-- then wrap : fun_ty ~> (t1 -> ... -> tn -> res_ty) -- and res_ty is a RhoType -- NB: the returned type is top-instantiated; it's a RhoType matchActualFunTys herald ct_orig n_val_args_wanted top_ty @@ -264,15 +264,13 @@ matchActualFunTys herald ct_orig n_val_args_wanted top_ty go 0 _ fun_ty = return (idHsWrapper, [], fun_ty) go n so_far fun_ty - = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy - herald Nothing - (n_val_args_wanted, top_ty) - fun_ty - ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 + = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing + (n_val_args_wanted, top_ty) 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 -- NB: arg_ty1 comes from matchActualFunTy, so it has - -- a syntactically fixed RuntimeRep as needed to call mkWpFun. - ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } + -- a syntactically fixed RuntimeRep + ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) } {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2004c1aab855043dd009f10df32f0fc4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2004c1aab855043dd009f10df32f0fc4... You're receiving this email because of your account on gitlab.haskell.org.