[Git][ghc/ghc][wip/T24676] Remove dead Delta
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Jun 4 15:02:01 UTC 2024
Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC
Commits:
820c9b16 by Simon Peyton Jones at 2024-06-04T16:01:42+01:00
Remove dead Delta
- - - - -
1 changed file:
- compiler/GHC/Tc/Gen/App.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -625,8 +625,6 @@ zonkArg arg = return arg
* *
********************************************************************* -}
-type Delta = Bool -- True <=> at least one instantiation variable
-
tcInstFun :: QLFlag
-> Bool -- False <=> Instantiate only /inferred/ variables at the end
-- so may return a sigma-type
@@ -649,9 +647,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
, text "fun_ctxt" <+> ppr fun_ctxt
, text "args:" <+> ppr rn_args
, text "do_ql" <+> ppr do_ql ])
- ; (_delta, inst_args, res_rho) <- go 1 False [] fun_sigma rn_args
- -- ToDo: remove delta from go
- ; return (inst_args, res_rho) }
+ ; go 1 [] fun_sigma rn_args }
where
fun_orig = case fun_ctxt of
VAExpansion (OrigStmt{}) _ _ -> DoOrigin
@@ -695,34 +691,33 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-----------
go, go1 :: Int -- Value-argument position of next arg
- -> Delta -- True <=> at least one instantiation variable
-> [HsExprArg 'TcpInst] -- Accumulator, reversed
-> TcSigmaType -> [HsExprArg 'TcpRn]
- -> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType)
+ -> TcM ([HsExprArg 'TcpInst], TcSigmaType)
-- go: If fun_ty=kappa, look it up in Theta
- go pos delta acc fun_ty args
+ go 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 delta acc fun_ty' args
- Flexi -> go1 pos delta acc fun_ty args }
+ Indirect fun_ty' -> go pos acc fun_ty' args
+ Flexi -> go1 pos acc fun_ty args }
| otherwise
- = go1 pos delta acc fun_ty args
+ = go1 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 delta acc fun_ty (arg : rest_args)
+ go1 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 delta acc fun_ty rest_args
+ = go 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 delta acc fun_ty args
+ go1 pos acc fun_ty args
| (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
, (theta, body2) <- if inst_fun args Inferred
then tcSplitPhiTy body1
@@ -750,41 +745,40 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-- argument of (#,#) to @LiftedRep, but want to rule out the
-- second instantiation @r.
- ; go pos (delta || not no_tvs)
- (addArgWrap wrap acc) fun_rho args }
+ ; go 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 delta acc fun_ty []
+ go1 _pos acc fun_ty []
= do { traceTc "tcInstFun:ret" (ppr fun_ty)
- ; return (delta, reverse acc, fun_ty) }
+ ; return (reverse acc, fun_ty) }
-- Rule ITVDQ from the GHC Proposal #281
- go1 pos delta acc fun_ty ((EValArg { ea_arg = arg }) : rest_args)
+ go1 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) delta (addArgWrap wrap acc) inst_body rest_args }
+ ; go (pos+1) (addArgWrap wrap acc) inst_body rest_args }
- go1 pos delta acc fun_ty (EWrap w : args)
- = go1 pos delta (EWrap w : acc) fun_ty args
+ go1 pos acc fun_ty (EWrap w : args)
+ = go1 pos (EWrap w : acc) fun_ty args
- go1 pos delta acc fun_ty (EPrag sp prag : args)
- = go1 pos delta (EPrag sp prag : acc) fun_ty args
+ go1 pos acc fun_ty (EPrag sp prag : args)
+ = go1 pos (EPrag sp prag : acc) fun_ty args
-- Rule ITYARG from Fig 4 of the QL paper
- go1 pos delta acc fun_ty ( ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty }
+ go1 pos acc fun_ty ( ETypeArg { ea_ctxt = 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_ctxt = ctxt, ea_hs_ty = hs_ty, ea_ty_arg = ty_arg }
- ; go pos delta (arg' : acc) inst_ty rest_args }
+ ; go pos (arg' : acc) inst_ty rest_args }
-- Rule IVAR from Fig 4 of the QL paper:
- go1 pos _ acc fun_ty args@(EValArg {} : _)
+ go1 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
@@ -799,8 +793,6 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-- matchActualFunTys is much more general, has a loop, etc.
-- - We must be sure to actually update the variable right now,
-- not defer in any way, because this is a QL instantiation variable.
- -- - We need the freshly allocated unification variables, to extend
- -- delta with.
-- It's easier just to do the job directly here.
do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [pos..]
; res_ty <- newOpenFlexiTyVarTy
@@ -818,10 +810,10 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) 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 True acc' fun_ty' args }
+ ; go pos acc' fun_ty' args }
-- Rule IARG from Fig 4 of the QL paper:
- go1 pos delta acc fun_ty
+ go1 pos acc fun_ty
(EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args)
= do { let herald = case fun_ctxt of
VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
@@ -838,7 +830,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
; arg' <- quickLookArg do_ql ctxt arg arg_ty
; let acc' = arg' : addArgWrap wrap acc
- ; go (pos+1) delta acc' res_ty rest_args }
+ ; 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
@@ -1623,11 +1615,6 @@ quickLookArg :: QLFlag -> AppCtxt
-> Scaled TcSigmaTypeFRR -- ^ Type expected by the function
-> TcM (HsExprArg 'TcpInst)
-- See Note [Quick Look at value arguments]
---
--- The returned Delta is a superset of the one passed in
--- with added instantiation variables from
--- (a) the call itself
--- (b) the arguments of the call
quickLookArg NoQL ctxt larg orig_arg_ty
= skipQuickLook ctxt larg orig_arg_ty
quickLookArg DoQL ctxt larg orig_arg_ty
@@ -1844,7 +1831,7 @@ which has no free instantiation variables, so we can QL-unify
-}
anyFreeKappa :: TcType -> TcM Bool
--- True if there is a free instantiation variable (member of Delta)
+-- True if there is a free instantiation variable
-- in the argument type, after zonking
-- See Note [The fiv test in quickLookArg]
anyFreeKappa ty = unTcMBool (foldQLInstVars go_tv ty)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/820c9b16ee0cf4f6b299d074048430ee4d815be1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/820c9b16ee0cf4f6b299d074048430ee4d815be1
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/20240604/0a5f5c2f/attachment-0001.html>
More information about the ghc-commits
mailing list