Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: f85de9bd by Apoorv Ingle at 2025-11-25T12:13:25-06:00 reduce the number of calls to getDeepSubsumption_DataCon by passing it as an argument to checkResultTy. Some error message wibbles - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -385,7 +385,7 @@ Unify result type /before/ typechecking the args Actual: String • In the first argument of ‘Pair’, namely ‘"yes"’ -The latter is much better. That is why we call checkResultType before tcValArgs. +The latter is much better. That is why we call `checkResultTy` before tcValArgs. -} -- CAUTION: Any changes to tcApp should be reflected in tcExprSigma tcApp :: HsExpr GhcRn @@ -442,12 +442,13 @@ tcApp rn_expr exp_res_ty -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] + ; ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun ; case do_ql of NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) -- Step 4.1: subsumption check against expected result type -- See Note [Unify with expected type before typechecking arguments] - ; res_wrap <- checkResultTy rn_expr tc_head inst_args + ; res_wrap <- checkResultTy ds_flag rn_expr tc_head inst_args app_res_rho exp_res_ty -- Step 4.2: typecheck the arguments ; tc_args <- tcValArgs NoQL (rn_fun, fun_lspan) inst_args @@ -467,7 +468,7 @@ tcApp rn_expr exp_res_ty ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho -- Step 5.4: subsumption check against the expected type - ; res_wrap <- checkResultTy rn_expr tc_head inst_args + ; res_wrap <- checkResultTy ds_flag rn_expr tc_head inst_args app_res_rho exp_res_ty -- Step 5.5: wrap up ; finishApp tc_head tc_args app_res_rho res_wrap } } @@ -527,27 +528,25 @@ finishApp tc_head@(tc_fun,_) tc_args app_res_rho res_wrap -- | Connect up the inferred type of an application with the expected type. -- This is usually just a unification, but with deep subsumption there is more to do. -checkResultTy :: HsExpr GhcRn +checkResultTy :: DeepSubsumptionFlag + -> HsExpr GhcRn -> (HsExpr GhcTc, SrcSpan) -- Head -> [HsExprArg p] -- Arguments, just error messages -> TcRhoType -- Inferred type of the application; zonked to -- expose foralls, but maybe not /deeply/ instantiated -> ExpRhoType -- Expected type; this is deeply skolemised -> TcM HsWrapper -checkResultTy rn_expr (fun, _) _inst_args app_res_rho (Infer inf_res) - = do { ds_flag <- getDeepSubsumptionFlag_DataConHead fun - ; fillInferResult ds_flag (exprCtOrigin rn_expr) app_res_rho inf_res - } +checkResultTy ds_flag rn_expr (fun, _) _inst_args app_res_rho (Infer inf_res) + = fillInferResult ds_flag (exprCtOrigin rn_expr) app_res_rho inf_res -checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty) +checkResultTy ds_flag rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty) -- Unify with expected type from the context -- See Note [Unify with expected type before typechecking arguments] -- -- Match up app_res_rho: the result type of rn_expr -- with res_ty: the expected result type = perhaps_add_res_ty_ctxt $ - do { ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun - ; traceTc "checkResultTy {" $ + do { traceTc "checkResultTy {" $ vcat [ text "tc_fun:" <+> ppr tc_fun , text "app_res_rho:" <+> ppr app_res_rho , text "res_ty:" <+> ppr res_ty @@ -695,7 +694,7 @@ tcValArg _ pos (fun, fun_lspan) (EValArgQL { ; tc_args <- tcValArgs DoQL (rn_fun, snd tc_head) inst_args ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho - ; res_wrap <- checkResultTy rn_expr tc_head inst_args + ; res_wrap <- checkResultTy ds_flag rn_expr tc_head inst_args app_res_rho (mkCheckExpType exp_arg_rho) ; finishApp tc_head tc_args app_res_rho res_wrap } ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -21,7 +21,8 @@ module GHC.Tc.Gen.Expr tcInferRho, tcInferRhoNC, tcMonoLExpr, tcMonoLExprNC, tcInferRhoFRR, tcInferRhoFRRNC, - tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig, + tcPolyLExpr, tcPolyLExprSig, tcPolyLExprNC, + tcPolyExpr, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where @@ -120,7 +121,7 @@ tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) ----------------- -- These versions take an ExpType tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType - -> TcM (LHsExpr GhcTc) + -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -269,8 +269,6 @@ splitHsApps e = go e noSrcSpan [] -- and its hard to say exactly what that is : EWrap (EExpand e) : args ) - -- look through PopErrCtxt (cf. T17594f) we do not want to lose the opportunity of calling tcEValArgQL - -- unlike HsPar, it is okay to forget about the PopErrCtxts as it does not persist over in GhcTc land go e lspan args = pure ((e, lspan), args) @@ -1087,18 +1085,16 @@ mis-match in the number of value arguments. add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a add_expr_ctxt e thing_inside = case e of - HsHole _ -> thing_inside + HsHole{} -> thing_inside -- The HsHole special case addresses situations like -- f x = _ -- when we don't want to say "In the expression: _", -- because it is mentioned in the error message itself - HsPar _ e -> add_expr_ctxt (unLoc e) thing_inside + HsPar{} -> thing_inside -- We don't want to say 'In the expression (e)', -- we just want to say 'In the expression, 'e' -- which will be handeled by the recursive call in thing_inside - -- This may be a little inefficient with nested parens exprs, eg. (((e))) - -- But it should be okay as I do not expect too many parens to be nested consecutively ExprWithTySig _ (L _ e') _ | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o (ExprCtxt e) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f85de9bd132fd5e3ef8a3d4dfdf41791... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f85de9bd132fd5e3ef8a3d4dfdf41791... You're receiving this email because of your account on gitlab.haskell.org.