Simon Peyton Jones pushed to branch wip/ani/better-expansion at Glasgow Haskell Compiler / GHC Commits: 10f21fa6 by Simon Peyton Jones at 2026-03-31T21:50:22+01:00 Move tcExpand to a new file Also tidy up mk_origin - - - - - 6 changed files: - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -656,8 +656,8 @@ tcInstFun :: QLFlag -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( [HsExprArg 'TcpInst] , TcSigmaType ) -- Does not instantiate trailing invisible foralls --- This crucial function implements the |-inst judgement in Fig 4, plus the --- modification in Fig 5, of the QL paper: +-- 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 rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args = do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun @@ -665,7 +665,8 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args , text "fun_sigma" <+> ppr fun_sigma , text "args:" <+> ppr rn_args , text "do_ql" <+> ppr do_ql]) - ; res@(_, fun_ty) <- go 1 [] fun_sigma rn_args + ; fun_origin <- mk_origin rn_head + ; res@(_, fun_ty) <- go fun_origin 1 [] fun_sigma rn_args ; traceTc "tcInstFun:ret" (ppr fun_ty) ; return res } @@ -683,7 +684,7 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args = 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 + -- 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 @@ -692,8 +693,6 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args ; 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 @@ -725,34 +724,35 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args inst_fun _ = isInferredForAllTyFlag ----------- - go, go1 :: Int -- Value-argument position of next arg + go, go1 :: CtOrigin -- Of the function + -> Int -- Value-argument position of next arg -> [HsExprArg 'TcpInst] -- Accumulator, reversed -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ([HsExprArg 'TcpInst], TcSigmaType) -- go: If fun_ty=kappa, look it up in Theta - go pos acc fun_ty args + go fun_orig pos acc fun_ty args | Just kappa <- getTyVar_maybe fun_ty , isQLInstTyVar kappa = do { cts <- readMetaTyVar kappa ; case cts of - Indirect fun_ty' -> go pos acc fun_ty' args - Flexi -> go1 pos acc fun_ty args } + Indirect fun_ty' -> go fun_orig pos acc fun_ty' args + Flexi -> go1 fun_orig pos acc fun_ty args } | otherwise - = go1 pos acc fun_ty args + = go1 fun_orig pos acc fun_ty args -- go1: fun_ty is not filled-in instantiation variable -- ('go' dealt with that case) -- Handle out-of-scope functions gracefully - go1 pos acc fun_ty (arg : rest_args) + go1 fun_orig pos acc fun_ty (arg : rest_args) | fun_is_out_of_scope, looks_like_type_arg arg -- See Note [VTA for out-of-scope functions] - = go pos acc fun_ty rest_args + = go fun_orig pos acc fun_ty rest_args -- Rule IALL from Fig 4 of the QL paper; applies even if args = [] -- Instantiate invisible foralls and dictionaries. -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate - go1 pos acc fun_ty args + go1 fun_orig pos acc fun_ty args | (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty , (theta, body2) <- if inst_fun args Inferred then tcSplitPhiTy body1 @@ -763,8 +763,7 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args , let no_tvs = null tvs no_theta = null theta , not (no_tvs && no_theta) - = do { fun_orig <- mk_origin rn_head - ; (wrap, fun_rho) <- + = do { (wrap, fun_rho) <- -- addHeadCtxt: important for the class constraints -- that may be emitted from instantiating fun_sigma setSrcSpan fun_lspan $ @@ -782,12 +781,12 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args -- argument of (#,#) to @LiftedRep, but want to rule out the -- second instantiation @r. - ; go pos (addArgWrap wrap acc) fun_rho args } + ; go fun_orig pos (addArgWrap wrap acc) fun_rho args } -- Going around again means we deal easily with -- nested forall a. Eq a => forall b. Show b => blah -- Rule IRESULT from Fig 4 of the QL paper; no more arguments - go1 _pos acc fun_ty [] + go1 _fun_orig _pos acc fun_ty [] | XExpr (ConLikeTc (RealDataCon dc)) <- tc_fun , isNewDataCon dc , [Scaled _ orig_arg_ty] <- dataConOrigArgTys dc @@ -807,30 +806,30 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args = return (reverse acc, fun_ty) -- Rule ITVDQ from the GHC Proposal #281 - go1 pos acc fun_ty ((EValArg { ea_arg = arg }) : rest_args) + go1 fun_orig pos acc fun_ty ((EValArg { ea_arg = arg }) : rest_args) | Just (tvb, body) <- tcSplitForAllTyVarBinder_maybe fun_ty = assertPpr (binderFlag tvb == Required) (ppr fun_ty $$ ppr arg) $ -- Any invisible binders have been instantiated by IALL above, -- so this forall must be visible (i.e. Required) do { (ty_arg, inst_body) <- tcVDQ fun_conc_tvs (tvb, body) arg ; let wrap = mkWpTyApps [ty_arg] - ; go (pos+1) (addArgWrap wrap acc) inst_body rest_args } + ; go fun_orig (pos+1) (addArgWrap wrap acc) inst_body rest_args } - go1 pos acc fun_ty (EWrap w : args) - = go1 pos (EWrap w : acc) fun_ty args + go1 fun_orig pos acc fun_ty (EWrap w : args) + = go1 fun_orig pos (EWrap w : acc) fun_ty args - go1 pos acc fun_ty (EPrag sp prag : args) - = go1 pos (EPrag sp prag : acc) fun_ty args + go1 fun_orig pos acc fun_ty (EPrag sp prag : args) + = go1 fun_orig pos (EPrag sp prag : acc) fun_ty args -- Rule ITYARG from Fig 4 of the QL paper - go1 pos acc fun_ty ( ETypeArg { ea_loc_span = ctxt, ea_hs_ty = hs_ty } - : rest_args ) + go1 fun_orig pos acc fun_ty ( ETypeArg { ea_loc_span = ctxt, ea_hs_ty = hs_ty } + : rest_args ) = do { (ty_arg, inst_ty) <- tcVTA fun_conc_tvs fun_ty hs_ty ; let arg' = ETypeArg { ea_loc_span = ctxt, ea_hs_ty = hs_ty, ea_ty_arg = ty_arg } - ; go pos (arg' : acc) inst_ty rest_args } + ; go fun_orig pos (arg' : acc) inst_ty rest_args } -- Rule IVAR from Fig 4 of the QL paper: - go1 pos acc fun_ty args@(EValArg {} : _) + go1 fun_orig pos acc fun_ty args@(EValArg {} : _) | Just kappa <- getTyVar_maybe fun_ty , isQLInstTyVar kappa = -- Function type was of form f :: forall a b. t1 -> t2 -> b @@ -846,7 +845,7 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args -- - We must be sure to actually update the variable right now, -- not defer in any way, because this is a QL instantiation variable. -- It's easier just to do the job directly here. - do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [pos..] + do { arg_tys <- zipWithM (new_arg_ty fun_orig) (leadingValArgs args) [pos..] ; res_ty <- newOpenFlexiTyVarTyQL do_ql TauTv ; let fun_ty' = mkScaledFunTys arg_tys res_ty @@ -862,13 +861,12 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args -- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk -- co_wrap :: (fun_ty' |> kind_co) ~ fun_ty' - ; go pos acc' fun_ty' args } + ; go fun_orig pos acc' fun_ty' args } -- Rule IARG from Fig 4 of the QL paper: - go1 pos acc fun_ty + go1 fun_orig pos acc fun_ty (EValArg { ea_arg = arg, ea_loc_span = ctxt } : rest_args) - = do { fun_orig <- mk_origin rn_head - ; let herald = mk_herald fun_orig tc_fun (unLoc arg) + = do { 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 @@ -882,13 +880,12 @@ tcInstFun do_ql inst_final rn_head@(_, fun_lspan) tc_fun fun_sigma rn_args (n_val_args, fun_sigma) fun_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 } + ; go fun_orig (pos+1) acc' res_ty rest_args } - new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType) + new_arg_ty :: CtOrigin -> LHsExpr GhcRn -> Int -> TcM (Scaled TcType) -- Make a fresh nus for each argument in rule IVAR - new_arg_ty (L _ arg) i - = do { fun_orig <- mk_origin rn_head - ; arg_nu <- newArgTyVarTyQL do_ql $ + new_arg_ty fun_orig (L _ arg) i + = do { 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 ===================================== compiler/GHC/Tc/Gen/Expand.hs ===================================== @@ -0,0 +1,118 @@ +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.Gen.Expand( tcExpand ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) + +import GHC.Hs + +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.ErrCtxt + +import GHC.Rename.Utils + +import GHC.Types.SrcLoc + + +{- Note [Typechecking by expansion: overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For many constructs, rather than typechecking the user-written code +directly, it's much easier to + * Expand (or desugar) the code to something simpler + * Typecheck that simpler expression + +Example: Typechecking the do expression. The typechecker looks (somewhat) like this: + + tcExpr e@(HsDo _ stmts) rho = do { hse <- expandDoStmts stmts + ; tcHsExpansion hse rho } + +The `expandDoStmts` replaces the HsDo { x <- e1; return x } +with something like + HSE { hse_ctxt = ExprCtxt e + , hse_exp = e1 >>= \ x -> x } +and we then typecheck the expression `e1 >>= \ x -> x` + +See also Note [Handling overloaded and rebindable constructs] + and Note [Doing XXExprGhcRn in the Renamer vs Typechecker] + +The Big Question is how to ensure that error messages mention +only user-written source code, and never talk about the expanded code. +The rest of this Note explains how that is done. + +* The expansion process typically takes a user written thing + L lspan ue + and returns + L lspan (XExpr (ExpandedThingRn (HSE { hse_ctxt = ue + , hse_exp = ee } )) + where `ee` is the expansion of the user written thing `ue` + +* The type checker context has 3 key fields that describe the context: + TcLclCtxt { tcl_loc :: RealSrcSpan + , tcl_in_gen_code :: Bool + , tcl_err_ctxt :: ErrCtxtStack + , ... } + Note `tcl_loc` always points to a real place in the source code, + hence `RealSrcSpan`. + + The `tcl_err_ctxt` is a stack of contexts, each saying something + like "In the expression: x+y" or "In second argument of `$` namely 'r { x=2 }'" + + The `tcl_in_gen_code` is a boolean that keeps track of whether + the current expression being typechecked is compiler generated + or user generated. + + INVARIANT: `tcl_loc` and `tcl_in_gen_code` are modified only in `setSrcSpan`. + +* Now, when + tcMonoLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + gets a located expression, it does 3 things: + (a) Calls `setSrcSpanA` to set the ambient source-code location + (b) Calls `addExprCtxt` to push a suitable `HsCtxt` on top of the `tcl_err_ctxt`. + (c) Calls `tcExpr` to typecheck the expression. + +* In these calls, if the `span` is generated (see `isGeneratedSrcSpan`), then + - `setSrcSpanA` sets `tcl_in_gen_code` to `True`, and leaves `tcl_loc` unchanged + - `addExprCtxt` is a no-op if `tcl_in_gen_code` is True + The result is that `tcl_loc` has the span from the innermost /user/ tree node; + and the ErrCtxtStack in `tcl_err_ctxt` only has contexts arisign from user code. + +* Note that inside an expansion we have sub-expressions from the original program. + As soon as we enter one of those, identified by a /user/ span, `setSrcSpanA` will + sets the `tcl_loc` to reflect that span, and switch off `tcl_in_gen_code`. Nice! +-} + +--------------- +tcExpand :: HsExpr GhcRn -> TcM (Maybe (HsExpansion GhcRn)) +tcExpand e@(OpApp _ arg1 op arg2) + = return $ Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = foldl ap op [arg1,arg2] } + where + ap f a = wrapGenSpan (HsApp noExtField f a) + +tcExpand (XExpr (ExpandedThingRn hse)) + = return (Just hse) + +tcExpand e@(HsUntypedSplice splice_res _) +-- See Note [Looking through Template Haskell splices in splitHsApps] + = do { fun <- getUntypedSpliceBody splice_res + ; return $ Just $ + HSE { hse_ctxt = ExprCtxt e -- ToDo: right? + , hse_exp = L noSrcSpanA fun } } -- Span? +{- + where + lspan' :: SrcSpan + lspan' = case splice of + HsUntypedSpliceExpr _ (L l _) -> locA l -- l :: SrcAnn AnnListItem + HsQuasiQuote _ _ (L l _) -> locA l -- l :: SrcAnn NoEpAnns + (XUntypedSplice (HsImplicitLiftSplice _ _ _ (L l _))) -> locA l +-} + +tcExpand _ = return Nothing ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -19,7 +19,6 @@ module GHC.Tc.Gen.Expr tcInferRhoFRR, tcInferRhoFRRNC, tcPolyLExpr, tcPolyLExprSig, tcPolyLExprNC, tcPolyExpr, tcExpr, - tcExpand, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where @@ -31,10 +30,10 @@ import {-# SOURCE #-} GHC.Tc.Gen.Splice import GHC.Hs import GHC.Hs.Syn.Type - import GHC.Rename.Utils import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls ) +import GHC.Tc.Gen.Expand( tcExpand ) import GHC.Tc.Gen.App import GHC.Tc.Gen.Head import GHC.Tc.Gen.Do @@ -770,73 +769,6 @@ tcExpr e res_ty ************************************************************************ -} -{- Note [Typechecking by expansion: overview] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For many constructs, rather than typechecking the user-written code -directly, it's much easier to - * Expand (or desugar) the code to something simpler - * Typecheck that simpler expression - -Example: Typechecking the do expression. The typechecker looks (somewhat) like this: - - tcExpr e@(HsDo _ stmts) rho = do { hse <- expandDoStmts stmts - ; tcHsExpansion hse rho } - -The `expandDoStmts` replaces the HsDo { x <- e1; return x } -with something like - HSE { hse_ctxt = ExprCtxt e - , hse_exp = e1 >>= \ x -> x } -and we then typecheck the expression `e1 >>= \ x -> x` - -See also Note [Handling overloaded and rebindable constructs] - and Note [Doing XXExprGhcRn in the Renamer vs Typechecker] - -The Big Question is how to ensure that error messages mention -only user-written source code, and never talk about the expanded code. -The rest of this Note explains how that is done. - -* The expansion process typically takes a user written thing - L lspan ue - and returns - L lspan (XExpr (ExpandedThingRn (HSE { hse_ctxt = ue - , hse_exp = ee } )) - where `ee` is the expansion of the user written thing `ue` - -* The type checker context has 3 key fields that describe the context: - TcLclCtxt { tcl_loc :: RealSrcSpan - , tcl_in_gen_code :: Bool - , tcl_err_ctxt :: ErrCtxtStack - , ... } - Note `tcl_loc` always points to a real place in the source code, - hence `RealSrcSpan`. - - The `tcl_err_ctxt` is a stack of contexts, each saying something - like "In the expression: x+y" or "In second argument of `$` namely 'r { x=2 }'" - - The `tcl_in_gen_code` is a boolean that keeps track of whether - the current expression being typechecked is compiler generated - or user generated. - - INVARIANT: `tcl_loc` and `tcl_in_gen_code` are modified only in `setSrcSpan`. - -* Now, when - tcMonoLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - gets a located expression, it does 3 things: - (a) Calls `setSrcSpanA` to set the ambient source-code location - (b) Calls `addExprCtxt` to push a suitable `HsCtxt` on top of the `tcl_err_ctxt`. - (c) Calls `tcExpr` to typecheck the expression. - -* In these calls, if the `span` is generated (see `isGeneratedSrcSpan`), then - - `setSrcSpanA` sets `tcl_in_gen_code` to `True`, and leaves `tcl_loc` unchanged - - `addExprCtxt` is a no-op if `tcl_in_gen_code` is True - The result is that `tcl_loc` has the span from the innermost /user/ tree node; - and the ErrCtxtStack in `tcl_err_ctxt` only has contexts arisign from user code. - -* Note that inside an expansion we have sub-expressions from the original program. - As soon as we enter one of those, identified by a /user/ span, `setSrcSpanA` will - sets the `tcl_loc` to reflect that span, and switch off `tcl_in_gen_code`. Nice! --} - tcHsExpansion :: HsExpansion GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcHsExpansion (HSE { hse_ctxt = o, hse_exp = e }) res_ty = do { e' <- tcMonoLExpr e res_ty @@ -844,31 +776,6 @@ tcHsExpansion (HSE { hse_ctxt = o, hse_exp = e }) res_ty HSE { hse_ctxt = o, hse_exp = e' } } ---------------- -tcExpand :: HsExpr GhcRn -> TcM (Maybe (HsExpansion GhcRn)) -tcExpand e@(OpApp _ arg1 op arg2) - = return (Just (HSE { hse_ctxt = ExprCtxt e - , hse_exp = wrapGenSpan (unLoc $ mkHsApps op [arg1,arg2]) })) -tcExpand (XExpr (ExpandedThingRn hse)) - = return (Just hse) - -tcExpand e@(HsUntypedSplice splice_res _) --- See Note [Looking through Template Haskell splices in splitHsApps] - = do { fun <- getUntypedSpliceBody splice_res - ; return $ Just $ - HSE { hse_ctxt = ExprCtxt e -- ToDo: right? - , hse_exp = L noSrcSpanA fun } } -- Span? -{- - where - lspan' :: SrcSpan - lspan' = case splice of - HsUntypedSpliceExpr _ (L l _) -> locA l -- l :: SrcAnn AnnListItem - HsQuasiQuote _ _ (L l _) -> locA l -- l :: SrcAnn NoEpAnns - (XUntypedSplice (HsImplicitLiftSplice _ _ _ (L l _))) -> locA l --} - -tcExpand _ = return Nothing - {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -9,7 +9,6 @@ import GHC.Tc.Types.BasicTypes( TcCompleteSig ) import GHC.Tc.Types.Origin ( CtOrigin, FixedRuntimeRepContext ) import GHC.Core.Type ( Mult ) import GHC.Hs.Extension ( GhcRn, GhcTc ) -import Data.Maybe( Maybe ) tcCheckPolyExpr, tcCheckPolyExprNC :: LHsExpr GhcRn @@ -40,8 +39,6 @@ tcInferExprSigma :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcInferExpr :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) -tcExpand :: HsExpr GhcRn -> TcM (Maybe (HsExpansion GhcRn)) - tcSyntaxOp :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -21,13 +21,14 @@ module GHC.Tc.Gen.Head , pprArgInst, addFunResCtxt ) where -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcExpand, tcCheckPolyExprNC, tcPolyLExprSig ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) import GHC.Prelude import GHC.Hs import GHC.Hs.Syn.Type import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Expand( tcExpand ) import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig ) import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) ===================================== compiler/ghc.cabal.in ===================================== @@ -832,6 +832,7 @@ Library GHC.Tc.Gen.Bind GHC.Tc.Gen.Default GHC.Tc.Gen.Do + GHC.Tc.Gen.Expand GHC.Tc.Gen.Export GHC.Tc.Gen.Expr GHC.Tc.Gen.Foreign View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10f21fa6d32a88ff9c7dcd36d357d5d7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10f21fa6d32a88ff9c7dcd36d357d5d7... You're receiving this email because of your account on gitlab.haskell.org.