[Git][ghc/ghc][wip/T24676] Fix contexts (again)
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri May 31 09:38:16 UTC 2024
Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC
Commits:
daebe8e5 by Simon Peyton Jones at 2024-05-31T10:37:46+01:00
Fix contexts (again)
- - - - -
2 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -165,7 +165,7 @@ tcInferSigma inst (L loc rn_expr)
do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
; do_ql <- wantQuickLook rn_fun
; (tc_fun, fun_sigma) <- tcInferAppHead fun
- ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_ctxt tc_fun fun_sigma rn_args
+ ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args
; mapM_ (tcValArg do_ql) inst_args
; return app_res_sigma }
@@ -363,19 +363,20 @@ tcApp rn_expr exp_res_ty
-- Step 2: Infer the type of `fun`, the head of the application
; (tc_fun, fun_sigma) <- tcInferAppHead fun
+ ; let tc_head = (tc_fun, fun_ctxt)
-- Step 3: Instantiate the function type (taking a quick look at args)
; do_ql <- wantQuickLook rn_fun
; (inst_args, app_res_rho)
<- setQLInstLevel do_ql $ -- See (TCAPP1) in
-- Note [tcApp: typechecking applications]
- tcInstFun do_ql True fun_ctxt tc_fun fun_sigma rn_args
+ tcInstFun do_ql True tc_head fun_sigma rn_args
-- Step 3: Take a quick look at the result type
; quickLookResultType do_ql app_res_rho exp_res_ty
-- Finish up
- ; finishApp do_ql rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty }
+ ; finishApp do_ql rn_expr tc_head inst_args app_res_rho exp_res_ty }
setQLInstLevel :: QLFlag -> TcM a -> TcM a
setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside
@@ -387,12 +388,13 @@ quickLookResultType :: QLFlag -> TcRhoType -> ExpRhoType -> TcM ()
quickLookResultType DoQL app_res_rho (Check exp_rho) = qlUnify app_res_rho exp_rho
quickLookResultType _ _ _ = return ()
-finishApp :: QLFlag -> HsExpr GhcRn -> AppCtxt
- -> HsExpr GhcTc -> [HsExprArg 'TcpInst]
+finishApp :: QLFlag -> HsExpr GhcRn
+ -> (HsExpr GhcTc, AppCtxt) -- Head of the application
+ -> [HsExprArg 'TcpInst] -- Args of the application
-> TcRhoType -- Inferred type of the application
-> ExpRhoType -- Expected type; this is deeply skolemised
-> TcM (HsExpr GhcTc)
-finishApp do_ql rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
+finishApp do_ql rn_expr tc_head@(tc_fun,_) inst_args app_res_rho exp_res_ty
= do { -- Step 6: qlZonk the type of the result of the call
traceTc "finishApp" $ vcat [ ppr app_res_rho, ppr exp_res_ty ]
; app_res_rho <- case do_ql of
@@ -400,19 +402,19 @@ finishApp do_ql rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
NoQL -> return app_res_rho
-- Step 7: check the result type
- ; res_wrap <- checkResultTy rn_expr fun_ctxt tc_fun inst_args
+ ; res_wrap <- checkResultTy rn_expr tc_head inst_args
app_res_rho exp_res_ty
-- step 8: Typecheck the value arguments
; tc_args <- mapM (tcValArg do_ql) inst_args
-- Step 9: Horrible newtype check
- ; rejectRepPolyNewtypes tc_fun app_res_rho
+ ; rejectRepPolyNewtypes tc_head app_res_rho
-- Step 10: econstruct, with a special case for tagToEnum#.
; tc_expr <- if isTagToEnum tc_fun
- then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho
- else return (rebuildHsApps tc_fun fun_ctxt tc_args)
+ then tcTagToEnum tc_head tc_args app_res_rho
+ else return (rebuildHsApps tc_head tc_args)
; whenDOptM Opt_D_dump_tc_trace $
do { inst_args <- liftZonkM $ mapM zonkArg inst_args -- Only when tracing
@@ -425,19 +427,20 @@ finishApp do_ql rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
; return (mkHsWrap res_wrap tc_expr) }
-checkResultTy :: HsExpr GhcRn -> AppCtxt
- -> HsExpr GhcTc -> [HsExprArg p]
+checkResultTy :: HsExpr GhcRn
+ -> (HsExpr GhcTc, AppCtxt) -- Head
+ -> [HsExprArg p] -- Arguments
-> TcRhoType -- Inferred type of the application; zonked to
-- expose foralls, but maybe not deeply instantiated
-> ExpRhoType -- Expected type; this is deeply skolemised
-> TcM HsWrapper
-- Connect up the inferred type of the application with the expected type
-- This is usually just a unification, but with deep subsumption there is more to do
-checkResultTy _ _ _ _ app_res_rho (Infer inf_res)
+checkResultTy _ _ _ app_res_rho (Infer inf_res)
= do { co <- fillInferResult app_res_rho inf_res
; return (mkWpCastN co) }
-checkResultTy rn_expr fun_ctxt tc_fun inst_args app_res_rho (Check res_ty)
+checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty)
-- Unify with expected type from the context
-- See Note [Unify with expected type before typechecking arguments]
--
@@ -521,8 +524,7 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
, eaql_ctxt = ctxt
, eaql_arg_ty = sc_arg_ty
, eaql_larg = larg@(L arg_loc rn_expr)
- , eaql_head = rn_head
- , eaql_tc_fun = tc_fun
+ , eaql_tc_fun = tc_head
, eaql_args = inst_args
, eaql_encl = arg_influences_enclosing_call
, eaql_res_rho = app_res_rho })
@@ -530,8 +532,7 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
do { -- Expose QL results to tcSkolemise, as in EValArg case
Scaled mult exp_arg_ty <- liftZonkM $ qlZonkScaledTcType sc_arg_ty
- ; traceTc "tcEValArgQL {" (vcat [ ppr rn_head
- , text "app_res_rho:" <+> ppr app_res_rho
+ ; traceTc "tcEValArgQL {" (vcat [ text "app_res_rho:" <+> ppr app_res_rho
, text "exp_arg_ty:" <+> ppr exp_arg_ty
, text "args:" <+> ppr inst_args ])
@@ -542,12 +543,11 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
do { emitConstraints wanted
; unless arg_influences_enclosing_call $ -- Don't repeat
qlUnify app_res_rho exp_arg_rho -- the qlUnify
- ; finishApp DoQL rn_expr ctxt tc_fun inst_args
+ ; finishApp DoQL rn_expr tc_head inst_args
app_res_rho (mkCheckExpType exp_arg_rho) }
; traceTc "tcEValArgQL }" $
- vcat [ text "rn_head:" <+> ppr rn_head
- , text "app_res_rho:" <+> ppr app_res_rho ]
+ vcat [ text "app_res_rho:" <+> ppr app_res_rho ]
; return (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc (mkHsWrap wrap arg')
@@ -591,17 +591,14 @@ tcInstFun :: QLFlag
-- in tcInferSigma, which is used only to implement :type
-- Otherwise we do eager instantiation; in Fig 5 of the paper
-- |-inst returns a rho-type
- -> AppCtxt
- -> HsExpr GhcTc
- -- ^ For error messages and to retrieve concreteness information
- -- of the function
+ -> (HsExpr GhcTc, AppCtxt)
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ( [HsExprArg 'TcpInst]
, TcSigmaType )
-- 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_ctxt tc_fun fun_sigma rn_args
+tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
= do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun
, text "fun_sigma" <+> ppr fun_sigma
, text "fun_ctxt" <+> ppr fun_ctxt
@@ -1682,8 +1679,8 @@ quickLookArg1 :: AppCtxt -> LHsExpr GhcRn
-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
= addArgCtxt ctxt larg $ -- Context needed for constraints
- -- generated by calls in arg
- do { (rn_head@(rn_fun, fun_ctxt), rn_args) <- splitHsApps arg
+ -- generated by calls in arg
+ do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg
-- Step 1: get the type of the head of the argument
; mb_fun_ty <- tcInferAppHead_maybe rn_fun
@@ -1698,10 +1695,11 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
Just (tc_fun, fun_sigma) ->
-- step 2: use |-inst to instantiate the head applied to the arguments
- do { do_ql <- wantQuickLook rn_fun
+ do { let tc_head = (tc_fun, fun_ctxt)
+ ; do_ql <- wantQuickLook rn_fun
; ((inst_args, app_res_rho), wanted)
<- captureConstraints $
- tcInstFun do_ql True fun_ctxt tc_fun fun_sigma rn_args
+ tcInstFun do_ql True tc_head fun_sigma rn_args
; traceTc "quickLookArg 2" $
vcat [ text "arg:" <+> ppr arg
@@ -1733,8 +1731,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
; return (EValArgQL { eaql_ctxt = ctxt
, eaql_arg_ty = sc_arg_ty
, eaql_larg = larg
- , eaql_head = rn_head
- , eaql_tc_fun = tc_fun
+ , eaql_tc_fun = tc_head
, eaql_args = inst_args
, eaql_wanted = wanted
, eaql_encl = arg_influences_enclosing_call
@@ -2099,12 +2096,12 @@ isTagToEnum :: HsExpr GhcTc -> Bool
isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey
isTagToEnum _ = False
-tcTagToEnum :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]
+tcTagToEnum :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc]
-> TcRhoType
-> TcM (HsExpr GhcTc)
-- tagToEnum# :: forall a. Int# -> a
-- See Note [tagToEnum#] Urgh!
-tcTagToEnum tc_fun fun_ctxt tc_args res_ty
+tcTagToEnum (tc_fun, fun_ctxt) tc_args res_ty
| [val_arg] <- dropWhile (not . isHsValArg) tc_args
= do { res_ty <- liftZonkM $ zonkTcType res_ty
@@ -2126,14 +2123,14 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty
; let rep_ty = mkTyConApp rep_tc rep_args
tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun
df_wrap = mkWpCastR (mkSymCo coi)
- tc_expr = rebuildHsApps tc_fun' fun_ctxt [val_arg]
+ tc_expr = rebuildHsApps (tc_fun', fun_ctxt) [val_arg]
; return (mkHsWrap df_wrap tc_expr) }}}}}
| otherwise
= failWithTc TcRnTagToEnumMissingValArg
where
- vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args)
+ vanilla_result = return (rebuildHsApps (tc_fun, fun_ctxt) tc_args)
check_enumeration ty' tc
| -- isTypeDataTyCon: see wrinkle (W1) in
@@ -2226,10 +2223,10 @@ Wrinkle [Representation-polymorphic lambdas] in Note [Typechecking data construc
-- if the representation of its argument isn't known.
--
-- See Note [Eta-expanding rep-poly unlifted newtypes].
-rejectRepPolyNewtypes :: HsExpr GhcTc
+rejectRepPolyNewtypes :: (HsExpr GhcTc, AppCtxt)
-> TcRhoType
-> TcM ()
-rejectRepPolyNewtypes fun app_res_rho = case fun of
+rejectRepPolyNewtypes (fun,_) app_res_rho = case fun of
XExpr (ConLikeTc (RealDataCon con) _ _)
-- Check that this is an unsaturated occurrence of a
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -177,10 +177,8 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg]
, eaql_arg_ty :: Scaled TcSigmaType -- Argument type expected by function
, eaql_larg :: LHsExpr GhcRn -- Original application, for
-- location and error msgs
- , eaql_head :: (HsExpr GhcRn, AppCtxt) -- Function of the application,
- -- typechecked, plus its context
- , eaql_tc_fun :: HsExpr GhcTc -- Typechecked function
- , eaql_args :: [HsExprArg 'TcpInst] -- Args, instantiated
+ , eaql_tc_fun :: (HsExpr GhcTc, AppCtxt) -- Typechecked head
+ , eaql_args :: [HsExprArg 'TcpInst] -- Args: instantiated, not typechecked
, eaql_wanted :: WantedConstraints
, eaql_encl :: Bool -- True <=> we have already qlUnified
-- eaql_arg_ty and eaql_res_rho
@@ -354,6 +352,8 @@ splitHsApps e = go e (top_ctxt 0 e) []
= pure ( (op, VACall op 0 (locA l))
, mkEValArg (VACall op 1 generatedSrcSpan) arg1
: mkEValArg (VACall op 2 generatedSrcSpan) arg2
+ -- generatedSrcSpan because this the span of the call,
+ -- and its hard to say exactly what that is
: EWrap (EExpand (OrigExpr e))
: args )
@@ -375,30 +375,29 @@ splitHsApps e = go e (top_ctxt 0 e) []
-- representation-polymorphic unlifted newtypes have been eta-expanded.
--
-- See Note [Eta-expanding rep-poly unlifted newtypes].
-rebuildHsApps :: HsExpr GhcTc
+rebuildHsApps :: (HsExpr GhcTc, AppCtxt)
-- ^ the function being applied
- -> AppCtxt
-> [HsExprArg 'TcpTc]
-- ^ the arguments to the function
-> HsExpr GhcTc
-rebuildHsApps fun _ [] = fun
-rebuildHsApps fun ctxt (arg : args)
+rebuildHsApps (fun, _) [] = fun
+rebuildHsApps (fun, ctxt) (arg : args)
= case arg of
EValArg { ea_arg = arg, ea_ctxt = ctxt' }
- -> rebuildHsApps (HsApp noExtField lfun arg) ctxt' args
+ -> rebuildHsApps (HsApp noExtField lfun arg, ctxt') args
ETypeArg { ea_hs_ty = hs_ty, ea_ty_arg = ty, ea_ctxt = ctxt' }
- -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args
+ -> rebuildHsApps (HsAppType ty lfun hs_ty, ctxt') args
EPrag ctxt' p
- -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args
+ -> rebuildHsApps (HsPragE noExtField p lfun, ctxt') args
EWrap (EPar ctxt')
- -> rebuildHsApps (gHsPar lfun) ctxt' args
+ -> rebuildHsApps (gHsPar lfun, ctxt') args
EWrap (EExpand orig)
| OrigExpr oe <- orig
- -> rebuildHsApps (mkExpandedExprTc oe fun) ctxt args
+ -> rebuildHsApps (mkExpandedExprTc oe fun, ctxt) args
| otherwise
- -> rebuildHsApps fun ctxt args
+ -> rebuildHsApps (fun, ctxt) args
EWrap (EHsWrap wrap)
- -> rebuildHsApps (mkHsWrap wrap fun) ctxt args
+ -> rebuildHsApps (mkHsWrap wrap fun, ctxt) args
where
lfun = L (noAnnSrcSpan $ appCtxtLoc' ctxt) fun
appCtxtLoc' (VAExpansion _ _ l) = l
@@ -429,9 +428,9 @@ instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
ppr (EPrag _ p) = text "EPrag" <+> ppr p
ppr (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
ppr (EWrap wrap) = ppr wrap
- ppr (EValArg { ea_arg = arg })
- = text "EValArg" <+> ppr arg
- ppr (EValArgQL { eaql_head = fun, eaql_args = args, eaql_res_rho = ty})
+ ppr (EValArg { ea_arg = arg, ea_ctxt = ctxt })
+ = text "EValArg" <> braces (ppr ctxt) <+> ppr arg
+ ppr (EValArgQL { eaql_tc_fun = fun, eaql_args = args, eaql_res_rho = ty})
= hang (text "EValArgQL" <+> ppr fun)
2 (vcat [ ppr args, text "ea_ql_ty:" <+> ppr ty ])
@@ -443,7 +442,7 @@ pprArgInst (EWrap wrap) = ppr wrap
pprArgInst (EValArg { ea_arg = arg, ea_arg_ty = ty })
= hang (text "EValArg" <+> ppr arg)
2 (text "arg_ty" <+> ppr ty)
-pprArgInst (EValArgQL { eaql_head = fun, eaql_args = args, eaql_res_rho = ty})
+pprArgInst (EValArgQL { eaql_tc_fun = fun, eaql_args = args, eaql_res_rho = ty})
= hang (text "EValArgQL" <+> ppr fun)
2 (vcat [ vcat (map pprArgInst args), text "ea_ql_ty:" <+> ppr ty ])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/daebe8e59d88beca2e543c3b841c3cce32f30b0d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/daebe8e59d88beca2e543c3b841c3cce32f30b0d
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/20240531/5a2be363/attachment-0001.html>
More information about the ghc-commits
mailing list