[Git][ghc/ghc][wip/T24676] More wibbles... finally getting there
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed May 29 23:06:18 UTC 2024
Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC
Commits:
6eb79d1a by Simon Peyton Jones at 2024-05-30T00:03:14+01:00
More wibbles... finally getting there
- - - - -
3 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Unify.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -161,7 +161,7 @@ tcInferSigma inst (L loc 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
- ; _tc_args <- tcValArgs inst_args
+ ; mapM_ (tcValArg do_ql) inst_args
; return app_res_sigma }
{- *********************************************************************
@@ -363,25 +363,25 @@ tcApp rn_expr exp_res_ty
-- Typecheck the arguments
; ds_flag <- getDeepSubsumptionFlag
- ; finishApp ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty }
+ ; finishApp do_ql ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty }
setQLInstLevel :: QLFlag -> TcM a -> TcM a
setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside
setQLInstLevel NoQL thing_inside = thing_inside
-finishApp :: DeepSubsumptionFlag -> HsExpr GhcRn -> AppCtxt
+finishApp :: QLFlag -> DeepSubsumptionFlag -> HsExpr GhcRn -> AppCtxt
-> HsExpr GhcTc -> [HsExprArg 'TcpInst]
-> TcRhoType -- Inferred type of the application;
-- zonked, but maybe not deeply instantiated
-> ExpRhoType -- Expected type; this is deeply skolemised
-> TcM (HsExpr GhcTc)
-- At this point there are no more instantiation variables
-finishApp ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
+finishApp do_ql ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
= do { res_wrap <- checkResTy ds_flag rn_expr fun_ctxt tc_fun inst_args
app_res_rho exp_res_ty
-- Typecheck the value arguments
- ; tc_args <- tcValArgs inst_args
+ ; tc_args <- mapM (tcValArg do_ql) inst_args
-- Horrible newtype check
; rejectRepPolyNewtypes tc_fun app_res_rho
@@ -393,7 +393,7 @@ finishApp ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
; whenDOptM Opt_D_dump_tc_trace $
do { inst_args <- liftZonkM $ mapM zonkArg inst_args -- Only when tracing
- ; traceTc "tcApp }" (vcat [ text "inst_args" <+> brackets (pprWithCommas pprHsExprArgTc inst_args)
+ ; traceTc "tcApp }" (vcat [ text "inst_args" <+> brackets (pprWithCommas pprArgInst inst_args)
, text "app_res_rho:" <+> ppr app_res_rho
, text "tc_fun:" <+> ppr tc_fun
, text "tc_args:" <+> ppr tc_args
@@ -421,17 +421,18 @@ checkResTy ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho (Check res_ty)
-- Match up app_res_rho: the result type of rn_expr
-- with res_ty: the expected result type
= perhaps_add_res_ty_ctxt $
- do { traceTc "unifyResTy {" $
+ do { traceTc "checkResTy {" $
vcat [ text "tc_fun:" <+> ppr tc_fun
, text "app_res_rho:" <+> ppr app_res_rho
- , text "res_ty:" <+> ppr res_ty ]
+ , text "res_ty:" <+> ppr res_ty
+ , text "ds_flag:" <+> ppr ds_flag ]
; case ds_flag of
Shallow -> -- No deep subsumption
-- app_res_rho and res_ty are both rho-types,
-- so with simple subsumption we can just unify them
-- No need to zonk; the unifier does that
do { co <- unifyExprType rn_expr app_res_rho res_ty
- ; traceTc "unifyResTy 1 }" (ppr co)
+ ; traceTc "checkResTy 1 }" (ppr co)
; return (mkWpCastN co) }
Deep -> -- Deep subsumption
@@ -441,7 +442,7 @@ checkResTy ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho (Check res_ty)
-- Zonk app_res_rho first, because QL may have instantiated some
-- delta variables to polytypes, and tcSubType doesn't expect that
do { wrap <- tcSubTypeDS rn_expr app_res_rho res_ty
- ; traceTc "unifyResTy 2 }" (ppr app_res_rho $$ ppr res_ty)
+ ; traceTc "checkResTy 2 }" (ppr app_res_rho $$ ppr res_ty)
; return wrap } }
where
-- perhaps_add_res_ty_ctxt: Inside an expansion, the addFunResCtxt stuff is
@@ -471,28 +472,24 @@ quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]
-- see what is going on. For that reason, it is not a full zonk: add
-- more if you need it.
zonkArg :: HsExprArg 'TcpInst -> ZonkM (HsExprArg 'TcpInst)
-zonkArg eva@(EValArg { ea_arg_ty = (do_zonk, Scaled m ty) })
+zonkArg eva@(EValArg { ea_arg_ty = Scaled m ty })
= do { ty' <- zonkTcType ty
- ; return (eva { ea_arg_ty = (do_zonk, Scaled m ty') }) }
+ ; return (eva { ea_arg_ty = Scaled m ty' }) }
zonkArg arg = return arg
----------------
-tcValArgs :: [HsExprArg 'TcpInst] -- Actual argument
- -> TcM [HsExprArg 'TcpTc] -- Resulting argument
-tcValArgs args = mapM tcValArg args
+tcValArg :: QLFlag -> HsExprArg 'TcpInst -- Actual argument
+ -> TcM (HsExprArg 'TcpTc) -- Resulting argument
+tcValArg _ (EPrag l p) = return (EPrag l (tcExprPrag p))
+tcValArg _ (EWrap w) = return (EWrap w)
+tcValArg _ (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty)
-tcValArg :: HsExprArg 'TcpInst -- Actual argument
- -> TcM (HsExprArg 'TcpTc) -- Resulting argument
-tcValArg (EPrag l p) = return (EPrag l (tcExprPrag p))
-tcValArg (EWrap w) = return (EWrap w)
-tcValArg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty)
-
-tcValArg (EValArg { ea_ctxt = ctxt
- , ea_arg = larg@(L arg_loc arg)
- , ea_arg_ty = (do_zonk, Scaled mult exp_arg_ty) })
+tcValArg do_ql (EValArg { ea_ctxt = ctxt
+ , ea_arg = larg@(L arg_loc arg)
+ , ea_arg_ty = Scaled mult exp_arg_ty })
= addArgCtxt ctxt larg $
do { traceTc "tcValArg" $
vcat [ ppr ctxt
@@ -508,7 +505,7 @@ tcValArg (EValArg { ea_ctxt = ctxt
-- Then Theta = [p :-> forall a. a->a], and we want
-- to check 'e' with expected type (forall a. a->a)
-- See Note [Instantiation variables are short lived]
- ; exp_arg_ty <- case do_zonk of
+ ; exp_arg_ty <- case do_ql of
DoQL -> liftZonkM $ zonkTcType exp_arg_ty
NoQL -> return exp_arg_ty
@@ -520,21 +517,21 @@ tcValArg (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc arg'
, ea_arg_ty = noExtField }) }
-tcValArg (EValArgQL { eaql_status = ql_status
- , eaql_ctxt = ctxt
- , eaql_arg_ty = Scaled mult exp_arg_ty
- , eaql_larg = larg@(L arg_loc rn_expr)
- , eaql_head = rn_head
- , eaql_tc_fun = tc_fun
- , eaql_args = inst_args
- , eaql_res_rho = app_res_rho })
+tcValArg _ (EValArgQL { eaql_status = ql_status
+ , eaql_ctxt = ctxt
+ , eaql_arg_ty = Scaled mult exp_arg_ty
+ , eaql_larg = larg@(L arg_loc rn_expr)
+ , eaql_head = rn_head
+ , eaql_tc_fun = tc_fun
+ , eaql_args = inst_args
+ , 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 Shallow rn_expr ctxt tc_fun inst_args app_res_rho
- (mkCheckExpType exp_arg_ty)
+ 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 }) }
@@ -556,8 +553,8 @@ tcValArg (EValArgQL { eaql_status = ql_status
; qlUnify app_res_rho exp_arg_rho
; monomorphiseQLInstVars inst_args app_res_rho
; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
- ; finishApp ds_flag rn_expr ctxt tc_fun inst_args app_res_rho
- (mkCheckExpType exp_arg_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
@@ -1658,20 +1655,20 @@ quickLookArg :: QLFlag -> AppCtxt
-- (a) the call itself
-- (b) the arguments of the call
quickLookArg NoQL ctxt larg orig_arg_ty
- = skipQuickLook NoQL ctxt larg orig_arg_ty
+ = skipQuickLook ctxt larg orig_arg_ty
quickLookArg DoQL ctxt larg orig_arg_ty
= do { is_rho <- tcIsDeepRho (scaledThing orig_arg_ty)
; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho)
; if not is_rho
- then skipQuickLook DoQL ctxt larg orig_arg_ty
+ then skipQuickLook ctxt larg orig_arg_ty
else quickLookArg1 ctxt larg orig_arg_ty }
-skipQuickLook :: QLFlag -> AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType
+skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType
-> TcM (HsExprArg 'TcpInst)
-skipQuickLook do_ql ctxt larg arg_ty
+skipQuickLook ctxt larg arg_ty
= return (EValArg { ea_ctxt = ctxt
, ea_arg = larg
- , ea_arg_ty = (do_ql, arg_ty) })
+ , ea_arg_ty = arg_ty })
-- do_ql <=> remember to zonk this argument in tcValArg
tcIsDeepRho :: TcType -> TcM Bool
@@ -1722,7 +1719,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
, text "args:" <+> ppr rn_args ]
; case mb_fun_ty of {
- Nothing -> skipQuickLook DoQL ctxt larg sc_arg_ty ; -- fun is too complicated
+ 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
@@ -1804,10 +1801,13 @@ 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) }) -- Ignore the DoQL part; f $ (g x) with -XNoImpredicativeTypes
+ 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 (EValArgQL { eaql_status = QLUnified {}, eaql_args = args, eaql_res_rho = rho })
- = go_val_arg_ql args rho
go_arg _ = return ()
go_ty :: TcType -> TcM ()
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -20,7 +20,7 @@ module GHC.Tc.Gen.Head
, AppCtxt(..), appCtxtLoc, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
- , leadingValArgs, isVisibleArg, pprHsExprArgTc
+ , leadingValArgs, isVisibleArg
, tcInferAppHead, tcInferAppHead_maybe
, tcInferId, tcCheckId, obviousSig
@@ -198,12 +198,7 @@ type family XETAType (p :: TcPass) where -- Type arguments
XETAType _ = Type
type family XEVAType (p :: TcPass) where -- Value arguments
- XEVAType 'TcpInst = (QLFlag, Scaled TcSigmaType)
- -- QLFlag = DoQL => we /are/ doing Quick Look,
- -- but this particular arg did not contribute; in this case
- -- we must zonk the type to expose the foralls from other args
- -- (If it did contribute, we'd be in EValArgQL.)
-
+ XEVAType 'TcpInst = Scaled TcSigmaType
XEVAType _ = NoExtField
data QLFlag = DoQL | NoQL
@@ -433,20 +428,23 @@ isVisibleArg (ETypeArg {}) = True
isVisibleArg _ = False
instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
- ppr (EValArg { ea_arg = arg }) = text "EValArg" <+> ppr arg
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})
= hang (text "EValArgQL" <+> ppr fun)
2 (vcat [ ppr args, text "ea_ql_ty:" <+> ppr ty ])
pprArgInst :: HsExprArg 'TcpInst -> SDoc
-pprArgInst (EValArg { ea_arg = arg, ea_arg_ty = ty }) = hang (text "EValArg" <+> ppr arg)
- 2 (text "arg_ty" <+> ppr ty)
-pprArgInst (EPrag _ p) = text "EPrag" <+> ppr p
+-- Ugh! A special version for 'TcpInst, se we can print the arg_ty of EValArg
+pprArgInst (EPrag _ p) = text "EPrag" <+> ppr p
pprArgInst (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
-pprArgInst (EWrap wrap) = ppr wrap
+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})
= hang (text "EValArgQL" <+> ppr fun)
2 (vcat [ vcat (map pprArgInst args), text "ea_ql_ty:" <+> ppr ty ])
@@ -461,11 +459,6 @@ instance Outputable EWrap where
ppr (EHsWrap w) = text "EHsWrap" <+> ppr w
ppr (EExpand orig) = text "EExpand" <+> ppr orig
-pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
-pprHsExprArgTc (EValArg { ea_arg = tm, ea_arg_ty = ty })
- = text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty)
-pprHsExprArgTc arg = ppr arg
-
{- Note [Desugar OpApp in the typechecker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Operator sections are desugared in the renamer; see GHC.Rename.Expr
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -1790,6 +1790,10 @@ doesn't do it yet, awaiting credible user demand. See #24696.
data DeepSubsumptionFlag = Deep | Shallow
+instance Outputable DeepSubsumptionFlag where
+ ppr Deep = text "Deep"
+ ppr Shallow = text "Shallow"
+
getDeepSubsumptionFlag :: TcM DeepSubsumptionFlag
getDeepSubsumptionFlag = do { ds <- xoptM LangExt.DeepSubsumption
; if ds then return Deep else return Shallow }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eb79d1a433b220c4a5d78c954c0c8148c9c5a7a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eb79d1a433b220c4a5d78c954c0c8148c9c5a7a
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/20240529/aa9733df/attachment-0001.html>
More information about the ghc-commits
mailing list