[Git][ghc/ghc][wip/T24676] Get rid of QLStatus
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu May 30 11:49:20 UTC 2024
Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC
Commits:
b65feade by Simon Peyton Jones at 2024-05-30T12:49:05+01:00
Get rid of QLStatus
- - - - -
2 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -60,7 +60,6 @@ import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )
import GHC.Types.Var.Set
-import GHC.Types.Basic ( TypeOrKind(..) )
import GHC.Data.Maybe
@@ -517,7 +516,7 @@ tcValArg do_ql (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc arg'
, ea_arg_ty = noExtField }) }
-tcValArg _ (EValArgQL { eaql_status = ql_status
+tcValArg _ (EValArgQL { eaql_wanted = wanted
, eaql_ctxt = ctxt
, eaql_arg_ty = Scaled mult exp_arg_ty
, eaql_larg = larg@(L arg_loc rn_expr)
@@ -527,42 +526,42 @@ tcValArg _ (EValArgQL { eaql_status = ql_status
, eaql_res_rho = app_res_rho })
= addArgCtxt ctxt larg $
tcScalingUsage mult $
- case ql_status of
- QLUnified -- We have decided to unify (no generalisation or deep subsumption)
- -> -- So pass Shallow to finishApp
- do { tc_app <- finishApp DoQL Shallow rn_expr ctxt tc_fun inst_args
- app_res_rho (mkCheckExpType exp_arg_ty)
- ; return (EValArg { ea_ctxt = ctxt
- , ea_arg = L arg_loc tc_app
- , ea_arg_ty = noExtField }) }
-
- QLIndependent wc
- -> do { -- Expose QL results to tcSkolemise, as in EValArg case
- exp_arg_ty <- liftZonkM $ zonkTcType exp_arg_ty
-
- ; traceTc "tcEValArgQL {" (vcat [ ppr rn_head
- , text "status:" <+> ppr ql_status
- , text "app_res_rho:" <+> ppr app_res_rho
- , text "exp_arg_ty:" <+> ppr exp_arg_ty
- , text "args:" <+> ppr inst_args ])
-
- ; ds_flag <- getDeepSubsumptionFlag
- ; (wrap, arg')
- <- tcSkolemise ds_flag GenSigCtxt exp_arg_ty $ \ exp_arg_rho ->
- do { emitConstraints wc
- ; qlUnify app_res_rho exp_arg_rho
- ; monomorphiseQLInstVars inst_args app_res_rho
- ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
- ; finishApp DoQL ds_flag rn_expr ctxt tc_fun 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 ]
-
- ; return (EValArg { ea_ctxt = ctxt
- , ea_arg = L arg_loc (mkHsWrap wrap arg')
- , ea_arg_ty = noExtField }) }
+ do { -- Expose QL results to tcSkolemise, as in EValArg case
+ exp_arg_ty <- liftZonkM $ zonkTcType exp_arg_ty
+
+ ; traceTc "tcEValArgQL {" (vcat [ ppr rn_head
+ , text "app_res_rho:" <+> ppr app_res_rho
+ , text "exp_arg_ty:" <+> ppr exp_arg_ty
+ , text "args:" <+> ppr inst_args ])
+
+ ; ds_flag <- getDeepSubsumptionFlag
+ ; (wrap, arg')
+ <- tcSkolemise ds_flag GenSigCtxt exp_arg_ty $ \ exp_arg_rho ->
+ do { emitConstraints wanted
+ ; qlUnify app_res_rho exp_arg_rho
+ ; monomorphiseQLInstVars inst_args app_res_rho
+ ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
+ ; finishApp DoQL ds_flag rn_expr ctxt tc_fun 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 ]
+
+ ; return (EValArg { ea_ctxt = ctxt
+ , ea_arg = L arg_loc (mkHsWrap wrap arg')
+ , ea_arg_ty = noExtField }) }
+
+-- case ql_status of
+-- QLUnified -- We have decided to unify (no generalisation or deep subsumption)
+-- -> -- So pass Shallow to finishApp
+-- do { tc_app <- finishApp DoQL Shallow rn_expr ctxt tc_fun inst_args
+-- app_res_rho (mkCheckExpType exp_arg_ty)
+-- ; return (EValArg { ea_ctxt = ctxt
+-- , ea_arg = L arg_loc tc_app
+-- , ea_arg_ty = noExtField }) }
+--
+-- QLIndependent wc
-- Tricky point: with deep subsumption, even if ql_status=QLUnified
@@ -1712,7 +1711,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
-- Step 1: get the type of the head of the argument
; mb_fun_ty <- tcInferAppHead_maybe rn_fun
- ; traceTc "quickLookArg 1" $
+ ; traceTc "quickLookArg {" $
vcat [ text "arg:" <+> ppr arg
, text "orig_arg_rho:" <+> ppr orig_arg_rho
, text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty
@@ -1722,7 +1721,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
Nothing -> skipQuickLook ctxt larg sc_arg_ty ; -- fun is too complicated
Just (tc_fun, fun_sigma) ->
- -- Step 2: use |-inst to instantiate the head applied to the arguments
+ -- step 2: use |-inst to instantiate the head applied to the arguments
do { do_ql <- wantQuickLook rn_fun
; ((inst_args, app_res_rho), wanted)
<- captureConstraints $
@@ -1749,39 +1748,50 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
-- Step 4: do quick-look unification if either (A) or (B) hold
-- NB: orig_arg_rho may not be zonked, but that's ok
- ; let -- mk_ql_arg captures the results so far, for resumption in tcValArg
- mk_ql_arg :: QLArgStatus -> HsExprArg 'TcpInst
- mk_ql_arg status
- = EValArgQL { eaql_status = status
- , eaql_ctxt = ctxt
- , eaql_arg_ty = sc_arg_ty
- , eaql_larg = larg
- , eaql_head = rn_head
- , eaql_tc_fun = tc_fun
- , eaql_args = inst_args
- , eaql_res_rho = app_res_rho }
-
- ; if arg_influences_enclosing_call
- then -- No generalisation will take place for this argument! So we can:
- -- * emit the constraints from the argument right now, and
- -- * unify with the expected type
- -- No skolemisation of orig_arg_ty needed here:
- -- tcIsDeepRho checked that there are no foralls to skolemise
+ ; when arg_influences_enclosing_call $
+ qlUnify app_res_rho orig_arg_rho
+
+ ; traceTc "quickLookArg done }" (ppr rn_fun)
+
+ ; return (EValArgQL { eaql_ctxt = ctxt
+ , eaql_arg_ty = sc_arg_ty
+ , eaql_larg = larg
+ , eaql_head = rn_head
+ , eaql_tc_fun = tc_fun
+ , eaql_args = inst_args
+ , eaql_wanted = wanted
+ , eaql_res_rho = app_res_rho }) }}}
+
+-- ; let -- mk_ql_arg captures the results so far, for resumption in tcValArg
+-- mk_ql_arg :: QLArgStatus -> HsExprArg 'TcpInst
+-- mk_ql_arg status
+-- = EValArgQL { eaql_status = status
+-- , eaql_ctxt = ctxt
+-- , eaql_arg_ty = sc_arg_ty
+-- , eaql_larg = larg
+-- , eaql_head = rn_head
+-- , eaql_tc_fun = tc_fun
+-- , eaql_args = inst_args
+-- , eaql_res_rho = app_res_rho }
+-- then -- No generalisation will take place for this argument! So we can:
+-- -- * emit the constraints from the argument right now, and
+-- -- * unify with the expected type
+-- -- No skolemisation of orig_arg_ty needed here:
+-- -- tcIsDeepRho checked that there are no foralls to skolemise
-- Try doing everything with QLIndependent
-- do { emitConstraints wanted
-- ; qlUnify app_res_rho orig_arg_rho
-- ; traceTc "quickLookArg unify" (ppr rn_fun)
-- ; return (mk_ql_arg QLUnified) }
- do { qlUnify app_res_rho orig_arg_rho
- ; return (mk_ql_arg (QLIndependent wanted)) }
-
- else -- Argument does not influence the enclosing call.
- -- Quick-look on this argument was in vain (but we still don't want to waste
- -- the work). So we treat this argument entirely independently:
- -- capture delta and wanted in QLIndependent for later resumption
- do { traceTc "quickLookArg indep" (ppr rn_fun)
- ; return (mk_ql_arg (QLIndependent wanted)) }
- }}}
+-- do { qlUnify app_res_rho orig_arg_rho
+-- ; return (mk_ql_arg (QLIndependent wanted)) }
+--
+-- else -- Argument does not influence the enclosing call.
+-- -- Quick-look on this argument was in vain (but we still don't want to waste
+-- -- the work). So we treat this argument entirely independently:
+-- -- capture delta and wanted in QLIndependent for later resumption
+-- do { traceTc "quickLookArg indep" (ppr rn_fun)
+-- ; return (mk_ql_arg (QLIndependent wanted)) }
@@ -1825,14 +1835,9 @@ monomorphiseQLInstVars inst_args res_rho
go_val_arg_ql inst_args rho = do { mapM_ go_arg inst_args; go_ty rho }
go_arg :: HsExprArg 'TcpInst -> TcM ()
- go_arg (EValArg { ea_arg_ty = arg_ty })
- = go_ty (scaledThing arg_ty)
- go_arg (EValArgQL { eaql_status = QLUnified {}, eaql_args = args
- , eaql_res_rho = rho, eaql_arg_ty = arg_ty })
- = do { go_ty (scaledThing arg_ty); go_val_arg_ql args rho }
- go_arg (EValArgQL { eaql_status = QLIndependent {}, eaql_arg_ty = arg_ty })
- = go_ty (scaledThing arg_ty)
- go_arg _ = return ()
+ go_arg (EValArg { ea_arg_ty = arg_ty }) = go_ty (scaledThing arg_ty)
+ go_arg (EValArgQL { eaql_arg_ty = arg_ty }) = go_ty (scaledThing arg_ty)
+ go_arg _ = return ()
go_ty :: TcType -> TcM ()
go_ty ty = unTcMUnit (foldQLInstVars go_tv ty)
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -16,7 +16,7 @@
-}
module GHC.Tc.Gen.Head
- ( HsExprArg(..), TcPass(..), QLArgStatus(..), QLFlag(..)
+ ( HsExprArg(..), TcPass(..), QLFlag(..)
, AppCtxt(..), appCtxtLoc, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
@@ -173,8 +173,7 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg]
-- Data constructor EValArgQL represents an argument that has been
-- partly-type-checked by Quick Look; see Note [EValArgQL]
- EValArgQL :: { eaql_status :: QLArgStatus
- , eaql_ctxt :: AppCtxt
+ EValArgQL :: { eaql_ctxt :: AppCtxt
, eaql_arg_ty :: Scaled TcSigmaType -- Argument type expected by function
, eaql_larg :: LHsExpr GhcRn -- Original application, for
-- location and error msgs
@@ -182,6 +181,7 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg]
-- typechecked, plus its context
, eaql_tc_fun :: HsExpr GhcTc -- Typechecked function
, eaql_args :: [HsExprArg 'TcpInst] -- Args, instantiated
+ , eaql_wanted :: WantedConstraints
, eaql_res_rho :: TcRhoType } -- Result type of the application
-> HsExprArg 'TcpInst -- Only exists in TcpInst phase
@@ -203,10 +203,6 @@ type family XEVAType (p :: TcPass) where -- Value arguments
data QLFlag = DoQL | NoQL
-data QLArgStatus -- See (QLA2) in Note [Quick Look at value arguments] in GHC.Tc.Gen.App
- = QLUnified -- Unified with caller
- | QLIndependent WantedConstraints -- Independent of caller
-
data EWrap = EPar AppCtxt
| EExpand HsThingRn
| EHsWrap HsWrapper
@@ -449,11 +445,6 @@ pprArgInst (EValArgQL { eaql_head = 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 ])
-
-instance Outputable QLArgStatus where
- ppr QLUnified = text "QLUnified"
- ppr (QLIndependent wc) = text "QLIndependent" <> braces (ppr wc)
-
instance Outputable EWrap where
ppr (EPar _) = text "EPar"
ppr (EHsWrap w) = text "EHsWrap" <+> ppr w
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b65feade78a59bb123e9c0b33a7d0e4641bf2c09
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b65feade78a59bb123e9c0b33a7d0e4641bf2c09
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/20240530/dcf14cdf/attachment-0001.html>
More information about the ghc-commits
mailing list