Apoorv Ingle pushed to branch wip/ani/better-expansion at Glasgow Haskell Compiler / GHC Commits: fac14765 by Apoorv Ingle at 2026-03-31T14:41:18-05:00 move mk_origin inside tcInstFun - - - - - 2 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -380,22 +380,12 @@ tcApp rn_expr rn_fun rn_args exp_res_ty -- Step 3.1: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun - -- Setp 3.2 Set the correct origin to blame for the error message - -- What should be the origin for this function call? - -- If the head of the function is user written - -- then it can be used in the error message - -- If it is generated code location span, blame it on the - -- origin that can be retrived from the top of the error ctxt stack. - -- See Note [Error contexts in generated code] - ; fun_orig <- mk_origin fun_lspan rn_fun - ; traceTc "tcApp:inferAppHead" $ vcat [ text "tc_fun:" <+> ppr tc_fun , text "fun_sigma:" <+> ppr fun_sigma - , text "fun_origin" <+> ppr fun_orig , text "do_ql:" <+> ppr do_ql] ; (inst_args, app_res_rho) - <- tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args + <- tcInstFun do_ql inst_final (rn_fun, fun_lspan) tc_fun fun_sigma rn_args -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] @@ -661,7 +651,7 @@ tcInstFun :: QLFlag -- always return a rho-type (but not a deep-rho type) -- Generally speaking we pass in True; in Fig 5 of the paper -- |-inst returns a rho-type - -> (CtOrigin, HsExpr GhcRn, SrcSpan) + -> (HsExpr GhcRn, SrcSpan) -> HsExpr GhcTc -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( [HsExprArg 'TcpInst] @@ -669,18 +659,41 @@ tcInstFun :: QLFlag -- This crucial function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20). -tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args - = do { traceTc "tcInstFun" (vcat [ text "origin" <+> ppr fun_orig - , text "tc_fun" <+> ppr tc_fun +tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args + = do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun + , text "rn_fun" <+> ppr rn_head , text "fun_sigma" <+> ppr fun_sigma , text "args:" <+> ppr rn_args - , text "do_ql" <+> ppr do_ql - , text "ctx" <+> ppr fun_lspan]) + , text "do_ql" <+> ppr do_ql]) ; res@(_, fun_ty) <- go 1 [] fun_sigma rn_args ; traceTc "tcInstFun:ret" (ppr fun_ty) ; return res } where + -- What should be the origin for this function call? + -- If the head of the function is user written + -- then it can be used in the error message + -- If it is generated code location span, blame it on the + -- origin that can be retrived from the top of the error ctxt stack. + -- See Note [Error contexts in generated code] + mk_origin :: (HsExpr GhcRn, SrcSpan) -- The head of the application chain and its location + -> TcM CtOrigin + mk_origin (rn_fun, fun_lspan) + | not (isGeneratedSrcSpan fun_lspan) + = return $ exprCtOrigin rn_fun + + | otherwise -- If the location is generated, the best we can do is to + -- approximate by looking on top of the error message stack + = do { err_ctxt_stack <- getErrCtxt + ; let hs_ctxt = case err_ctxt_stack of + (c:_) -> c + [] -> pprPanic "mk_origin" (ppr rn_fun) + ; traceTc "mk_origin" (pprHsCtxt hs_ctxt) + ; return $ hsCtxtCtOrigin hs_ctxt + } + + + -- These are the type variables which must be instantiated to concrete -- types. See Note [Representation-polymorphic Ids with no binding] -- in GHC.Tc.Utils.Concrete @@ -750,7 +763,8 @@ tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_arg , let no_tvs = null tvs no_theta = null theta , not (no_tvs && no_theta) - = do { (wrap, fun_rho) <- + = do { fun_orig <- mk_origin rn_head + ; (wrap, fun_rho) <- -- addHeadCtxt: important for the class constraints -- that may be emitted from instantiating fun_sigma setSrcSpan fun_lspan $ @@ -853,7 +867,8 @@ tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_arg -- Rule IARG from Fig 4 of the QL paper: go1 pos acc fun_ty (EValArg { ea_arg = arg, ea_loc_span = ctxt } : rest_args) - = do { let herald = mk_herald tc_fun (unLoc arg) + = do { fun_orig <- mk_origin rn_head + ; let herald = mk_herald fun_orig tc_fun (unLoc arg) ; (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 @@ -865,15 +880,16 @@ tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_arg matchActualFunTy herald (Just $ HsExprTcThing tc_fun) (n_val_args, fun_sigma) fun_ty - ; arg' <- quickLookArg do_ql pos ctxt (rn_fun, fun_lspan) arg arg_ty + ; arg' <- quickLookArg do_ql pos ctxt rn_head arg arg_ty ; 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) -- Make a fresh nus for each argument in rule IVAR new_arg_ty (L _ arg) i - = do { arg_nu <- newArgTyVarTyQL do_ql $ - FRRExpectedFunTy (mk_herald tc_fun arg) i + = do { fun_orig <- mk_origin rn_head + ; arg_nu <- newArgTyVarTyQL do_ql $ + FRRExpectedFunTy (mk_herald fun_orig tc_fun arg) i -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc], -- thereby ensuring that the arguments have concrete runtime representations @@ -883,12 +899,13 @@ tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_arg ; return (mkScaled mult_ty arg_nu) } - mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> ExpectedFunTyCtxt - mk_herald tc_fun arg + mk_herald :: CtOrigin -> HsExpr GhcTc -> HsExpr GhcRn -> ExpectedFunTyCtxt + mk_herald fun_orig tc_fun arg = case fun_orig of DoStmtOrigin -> ExpectedFunTySyntaxOp DoStmtOrigin tc_fun _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) arg + -- Is the argument supposed to instantiate a forall? -- -- In other words, given a function application `fn arg`, @@ -1959,17 +1976,15 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ do { let arg_tc_head = (tc_fun_arg_head, fun_lspan_arg) ; do_ql <- wantQuickLook rn_fun_arg - ; arg_orig <- mk_origin fun_lspan_arg rn_fun_arg ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args + tcInstFun do_ql True (rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args -- We must capture type-class and equality constraints here, but -- not usage information. See (QLA6) in Note [Quick Look at -- value arguments] ; traceTc "quickLookArg 2" $ vcat [ text "arg:" <+> ppr arg - , text "orig:" <+> ppr arg_orig , text "orig_arg_rho:" <+> ppr orig_arg_rho , text "app_res_rho:" <+> ppr app_res_rho ] @@ -2007,24 +2022,6 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ , eaql_res_rho = app_res_rho }) }}} -mk_origin :: SrcSpan -- SrcSpan of the function - -> HsExpr GhcRn -- The head of the expression application chain - -> TcM CtOrigin -mk_origin fun_lspan rn_fun - | not (isGeneratedSrcSpan fun_lspan) - = return $ exprCtOrigin rn_fun - - | otherwise -- If the location is generated, the best we can do is to - -- approximate by looking on top of the error message stack - = do { err_ctxt_stack <- getErrCtxt - ; let hs_ctxt = case err_ctxt_stack of - (c:_) -> c - [] -> pprPanic "mk_origin" (ppr rn_fun) - ; traceTc "mk_origin" (pprHsCtxt hs_ctxt) - ; return $ hsCtxtCtOrigin hs_ctxt - } - - {- ********************************************************************* * * Folding over instantiation variables ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -446,7 +446,7 @@ tcInferAppHead_maybe :: HsExpr GhcRn -- the argument is an XExpr tcInferAppHead_maybe fun = case fun of HsVar _ nm -> Just <$> tcInferId nm - ExprWithTySig _ e hs_ty -> Just <$>tcExprWithSig e hs_ty + ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f _ -> return Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fac147656c82853b6476e84a68072847... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fac147656c82853b6476e84a68072847... You're receiving this email because of your account on gitlab.haskell.org.