Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: c2735328 by Apoorv Ingle at 2025-11-26T17:21:25-06:00 store ds_flag in EValArgQL to avoid recomputing it - - - - - 2 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -188,11 +188,12 @@ tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcExprSigma inst rn_expr = do { (fun@(rn_fun,fun_lspan), rn_args) <- splitHsApps rn_expr ; (tc_fun, fun_sigma) <- tcInferAppHead fun + ; ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun ; fun_orig <- mk_origin fun_lspan rn_fun rn_fun - ; traceTc "tcExprSigma" (vcat [ text "rn_expr:" <+> ppr rn_expr , text "tc_fun" <+> ppr tc_fun ]) - ; (inst_args, app_res_sigma) <- tcInstFun DoQL inst (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args + ; (inst_args, app_res_sigma) <- tcInstFun DoQL inst ds_flag (fun_orig, rn_fun, fun_lspan) + tc_fun fun_sigma rn_args ; tc_args <- tcValArgs DoQL (rn_fun, fun_lspan) inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_lspan) tc_args ; return (tc_expr, app_res_sigma) } @@ -412,6 +413,7 @@ tcApp rn_expr exp_res_ty IIF_ShallowRho -> True IIF_DeepRho -> True IIF_Sigma -> False + ; ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun -- Step 3.1: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun @@ -431,11 +433,10 @@ tcApp rn_expr exp_res_ty , text "fun_origin" <+> ppr fun_orig , text "do_ql:" <+> ppr do_ql] ; (inst_args, app_res_rho) - <- tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args + <- tcInstFun do_ql inst_final ds_flag (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] - ; ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun ; case do_ql of NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) @@ -652,6 +653,7 @@ tcValArg _ pos (fun, fun_lspan) (EValArgQL { , eaql_arg_ty = sc_arg_ty , eaql_larg = larg@(L arg_loc rn_expr) , eaql_tc_fun = tc_head + , eaql_ds_flag = ds_flag , eaql_rn_fun = rn_fun , eaql_fun_ue = head_ue , eaql_args = inst_args @@ -670,7 +672,6 @@ tcValArg _ pos (fun, fun_lspan) (EValArgQL { , text "head_lspan" <+> ppr fun_lspan , text "tc_head" <+> ppr tc_head]) - ; ds_flag <- getDeepSubsumptionFlag_DataConHead (fst tc_head) ; (wrap, arg') <- tcScalingUsage mult $ tcSkolemise ds_flag GenSigCtxt exp_arg_ty $ \ exp_arg_rho -> @@ -728,15 +729,16 @@ tcInstFun :: QLFlag -- always return a rho-type (but not a deep-rho type) -- Generally speaking we pass in True; in Fig 5 of the paper -- |-inst returns a rho-type + -> DeepSubsumptionFlag -> (CtOrigin, HsExpr GhcRn, SrcSpan) - -> HsExpr GhcTc -- ANI: TODO, move HsExpr GhcRn, SrcSpan to CtOrigin + -> HsExpr GhcTc -> 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: -- "A quick look at impredicativity" (ICFP'20). -tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args +tcInstFun do_ql inst_final ds_flag (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args = do { traceTc "tcInstFun" (vcat [ text "origin" <+> ppr fun_orig , text "tc_fun" <+> ppr tc_fun , text "fun_sigma" <+> ppr fun_sigma @@ -935,7 +937,7 @@ tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_arg (Just $ HsExprTcThing tc_fun) (n_val_args, fun_sigma) fun_ty - ; ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun + -- ; ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun ; arg' <- quickLookArg ds_flag do_ql pos ctxt (rn_fun, fun_lspan) arg arg_ty ; let acc' = arg' : addArgWrap (mkWpCastN fun_co) acc ; go (pos+1) acc' res_ty rest_args } @@ -2022,10 +2024,10 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ ; do_ql <- wantQuickLook rn_fun_arg ; arg_orig <- mk_origin fun_lspan_arg rn_fun_arg fun - + ; ds_flag_arg <- getDeepSubsumptionFlag_DataConHead tc_fun_arg_head ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args + tcInstFun do_ql True ds_flag_arg (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args -- We must capture type-class and equality constraints here, but -- not equality constraints. See (QLA6) in Note [Quick Look at -- value arguments] @@ -2062,6 +2064,7 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ , eaql_larg = larg , eaql_tc_fun = arg_tc_head , eaql_rn_fun = rn_fun_arg + , eaql_ds_flag = ds_flag_arg , eaql_fun_ue = fun_ue , eaql_args = inst_args , eaql_wanted = wanted ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -175,6 +175,7 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] -- location and error msgs , eaql_rn_fun :: HsExpr GhcRn -- Head of the argument if it is an application , eaql_tc_fun :: (HsExpr GhcTc, SrcSpan) -- Typechecked head and its location span + , eaql_ds_flag :: DeepSubsumptionFlag -- Was deepsubsumption enabled for this argument? , eaql_fun_ue :: UsageEnv -- Usage environment of the typechecked head (QLA5) , eaql_args :: [HsExprArg 'TcpInst] -- Args: instantiated, not typechecked , eaql_wanted :: WantedConstraints View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c2735328951f8b73e5f66f22246961f3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c2735328951f8b73e5f66f22246961f3... You're receiving this email because of your account on gitlab.haskell.org.