Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC Commits: 2b0c10d6 by Simon Peyton Jones at 2025-11-07T13:14:25+00:00 More [skip ci] Making static bindings have static constraint solveing Sigh - - - - - 23 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/TcMType.hs - − compiler/GHC/Tc/Utils/TcMType.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/TcType.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -98,7 +98,7 @@ type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, StaticFlag) data StaticFlag = IsStatic | NotStatic - deriving( Data ) + deriving( Eq, Data ) -- IsStatic <=> this binding consists only code; all free -- vars are top level (or themselves static). -- So it can be moved to top level ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -412,7 +412,7 @@ warnRedundantConstraints ctxt env info redundant_evs | null redundant_evs = return () - | SigSkol user_ctxt _ _ <- info + | SigSkol _ user_ctxt _ _ <- info -- When dealing with a user-written type signature, -- we want to add "In the type signature for f". = report_redundant_msg True (setCtLocEnvLoc env (redundantConstraintsSpan user_ctxt)) ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -5481,7 +5481,7 @@ suggestAddSig ctxt ty1 _ty2 find [] _ _ = [] find (implic:implics) seen_eqs tv | tv `elem` ic_skols implic - , InferSkol prs <- ic_info implic + , InferSkol _ prs <- ic_info implic , seen_eqs = map fst prs | otherwise @@ -5555,7 +5555,7 @@ ctxtFixes has_ambig_tvs pred implics , isTyVarClassPred pred -- Don't suggest adding (Eq T) to the context, say , (skol:skols) <- usefulContext implics pred , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol + , SigSkol _ (PatSynCtxt {}) _ _ <- skol = text "\"required\"" | otherwise = empty @@ -5580,7 +5580,7 @@ usefulContext implics pred go :: [Implication] -> [SkolemInfoAnon] go [] = [] go (ic : ics) - | StaticFormSkol <- ic_info ic = [] + | isStaticSkolInfo (ic_info ic) = [] -- Stop at a static form, because all outer Givens are irrelevant -- See (SF3) in Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable | implausible ic = rest @@ -5595,7 +5595,7 @@ usefulContext implics pred | implausible_info (ic_info ic) = True | otherwise = False - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True + implausible_info (SigSkol _ (InfSigCtxt {}) _ _) = True implausible_info _ = False -- Do not suggest adding constraints to an *inferred* type signature @@ -5690,17 +5690,17 @@ tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env ---------------- tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfoAnon env (SigSkol st cx ty tv_prs) = tidySigSkol env st cx ty tv_prs +tidySkolemInfoAnon env (InferSkol st ids) = InferSkol st (mapSnd (tidyType env) ids) tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) tidySkolemInfoAnon _ info = info -tidySigSkol :: TidyEnv -> UserTypeCtxt +tidySigSkol :: TidyEnv -> StaticFlag -> UserTypeCtxt -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon -- We need to take special care when tidying SigSkol -- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' +tidySigSkol env st cx ty tv_prs + = SigSkol st cx (tidy_ty env ty) tv_prs' where tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs inst_env = mkNameEnv tv_prs' ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -5530,8 +5530,8 @@ discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] | otherwise = givens where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False + discard n (Implic { ic_info = SigSkol _ (PatSynCtxt n') _ _ }) = n == n' + discard _ _ = False -- | An error reported after constraint solving. ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -366,6 +366,7 @@ tc_nonrec_group top_lvl sig_fn prag_fn [lbind] thing_inside ; let final_closed = adjustClosedForUnlifted closed ids ; thing <- tcExtendLetEnv top_lvl sig_fn final_closed ids thing_inside + ; return ( (NonRecursive, bind', sendToTopLevel final_closed), thing ) } tc_nonrec_group _ _ _ binds _ -- Non-rec groups should always be a singleton @@ -473,7 +474,9 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv -- Knows nothing about the scope of the bindings -- None of the bindings are pattern synonyms -tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list +tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc + closed@(IsGroupClosed {gc_static = static_flag}) + bind_list = setSrcSpan loc $ recoverM (recoveryCode binder_names sig_fn) $ do -- Set up main recover; take advantage of any type sigs @@ -481,12 +484,12 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list { traceTc "------------------------------------------------" Outputable.empty ; traceTc "Bindings for {" (ppr binder_names) ; dflags <- getDynFlags - ; let plan = decideGeneralisationPlan dflags top_lvl closed sig_fn bind_list + ; let plan = decideGeneralisationPlan dflags closed sig_fn bind_list ; traceTc "Generalisation plan" (ppr plan) ; result@(_, scaled_poly_ids) <- case plan of - NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list - InferGen -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn bind_list - CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind + NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list + InferGen -> tcPolyInfer top_lvl static_flag rec_tc prag_fn sig_fn bind_list + CheckGen lbind sig -> tcPolyCheck static_flag prag_fn sig lbind ; let poly_ids = map scaledThing scaled_poly_ids @@ -567,14 +570,13 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list * * ********************************************************************* -} -tcPolyCheck :: TcPragEnv - -> TcCompleteSig +tcPolyCheck :: StaticFlag -> TcPragEnv -> TcCompleteSig -> LHsBind GhcRn -- Must be a FunBind -> TcM (LHsBinds GhcTc, [Scaled TcId]) -- There is just one binding, -- it is a FunBind -- it has a complete type signature, -tcPolyCheck prag_fn +tcPolyCheck static_flag prag_fn sig@(CSig { sig_bndr = poly_id, sig_ctxt = ctxt }) (L bind_loc (FunBind { fun_id = L nm_loc name , fun_matches = matches })) @@ -589,7 +591,7 @@ tcPolyCheck prag_fn ; mult <- newMultiplicityVar ; (wrap_gen, (wrap_res, matches')) - <- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty -> + <- tcSkolemiseCompleteSig sig static_flag $ \invis_pat_tys rho_ty -> let mono_id = mkLocalId mono_name (idMult poly_id) rho_ty in tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ @@ -632,7 +634,7 @@ tcPolyCheck prag_fn ; return ([abs_bind], [Scaled mult poly_id]) } -tcPolyCheck _prag_fn sig bind +tcPolyCheck _static _prag_fn sig bind = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] @@ -719,13 +721,14 @@ To address this we to do a few things -} tcPolyInfer - :: TopLevelFlag + :: TopLevelFlag -- Syntactically top-leve + -> StaticFlag -- Static (morally top level) -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> TcPragEnv -> TcSigFun -> [LHsBind GhcRn] -> TcM (LHsBinds GhcTc, [Scaled TcId]) -tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn bind_list +tcPolyInfer top_lvl static_flag rec_tc prag_fn tc_sig_fn bind_list = do { (tclvl, wanted, (binds', mono_infos)) <- pushLevelAndCaptureConstraints $ tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list @@ -745,7 +748,8 @@ tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn bind_list ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) ; ((qtvs, givens, ev_binds, insoluble), residual) - <- captureConstraints $ simplifyInfer top_lvl tclvl infer_mode sigs name_taus wanted + <- captureConstraints $ + simplifyInfer top_lvl static_flag tclvl infer_mode sigs name_taus wanted ; let inferred_theta = map evVarPred givens ; scaled_exports <- checkNoErrs $ @@ -1804,29 +1808,32 @@ instance Outputable GeneralisationPlan where ppr (CheckGen _ s) = text "CheckGen" <+> ppr s decideGeneralisationPlan - :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun + :: DynFlags -> IsGroupClosed -> TcSigFun -> [LHsBind GhcRn] -> GeneralisationPlan -decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds +decideGeneralisationPlan dflags (IsGroupClosed { gc_static = static_flag + , gc_closed = closed_type }) + sig_fn lbinds | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig | generalise_binds = InferGen | otherwise = NoGen where generalise_binds - | isTopLevel top_lvl = True - -- See Note [Always generalise top-level bindings] + | null binders = False + -- Not if `binders` is empty: there is no binder to generalise, so + -- generalising does nothing. And trying to generalise hurts linear + -- types (see #25428). So we don't force it. + -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind. + + | IsStatic <- static_flag = True + -- See Note [Always generalise syntactically top-level bindings] | has_mult_anns_and_pats = False -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear] - | IsGroupClosed _ _ True <- closed - , not (null binders) = True - -- The 'True' means that all of the group's + | closed_type = True + -- The `closed_type` means that all of the group's -- free vars have ClosedTypeId=True; so we can ignore -- -XMonoLocalBinds, and generalise anyway. - -- Except if 'fv' is empty: there is no binder to generalise, so - -- generalising does nothing. And trying to generalise hurts linear - -- types (see #25428). So we don't force it. - -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind. | has_partial_sigs = True -- See Note [Partial type signatures and generalisation] @@ -1855,7 +1862,9 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds isClosedBndrGroup :: TcTypeEnv -> [LHsBind GhcRn] -> IsGroupClosed isClosedBndrGroup type_env binds - = IsGroupClosed is_static fv_env type_closed + = IsGroupClosed { gc_static = is_static + , gc_fvs = fv_env + , gc_closed = type_closed } where fv_env :: NameEnv NameSet fv_env = mkNameEnv $ [ (b,fvs) | (bs,fvs) <- bind_fvs, b <-bs ] @@ -1886,9 +1895,9 @@ isClosedBndrGroup type_env binds id_is_static name | Just thing <- lookupNameEnv type_env name = case thing of - AGlobal {} -> True - ATcId { tct_info = LetBound { lb_top = IsStatic } } -> True - _ -> False + AGlobal {} -> True + ATcId { tct_info = LetBound { lb_static = IsStatic } } -> True + _ -> False | otherwise -- Imported Ids = True @@ -1916,15 +1925,20 @@ isClosedBndrGroup type_env binds -- Ditto class method etc from the current module adjustClosedForUnlifted :: IsGroupClosed -> [Scaled TcId] -> IsGroupClosed -adjustClosedForUnlifted closed@(IsGroupClosed top_lvl fv_env type_closed) ids - | IsStatic <- top_lvl - , all definitely_lifted ids = closed - | otherwise = IsGroupClosed NotStatic fv_env type_closed +adjustClosedForUnlifted closed ids + | IsGroupClosed { gc_static = IsStatic } <- closed + , not (all closed_and_lifted ids) + = closed { gc_static = NotStatic } + | otherwise + = closed where - definitely_lifted (Scaled _ id) = definitelyLiftedType (idType id) + closed_and_lifted (Scaled _ id) = noFreeVarsOfType ty + && definitelyLiftedType ty + where + ty = idType id sendToTopLevel :: IsGroupClosed -> StaticFlag -sendToTopLevel (IsGroupClosed top _ _) = top +sendToTopLevel (IsGroupClosed { gc_static = is_static }) = is_static lHsBindFreeVars :: LHsBind GhcRn -> NameSet lHsBindFreeVars (L _ (FunBind { fun_ext = fvs })) = fvs @@ -1932,16 +1946,17 @@ lHsBindFreeVars (L _ (PatBind { pat_ext = fvs })) = fvs lHsBindFreeVars _ = emptyNameSet -{- Note [Always generalise top-level bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Always generalise syntactically top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is very confusing to apply NoGen to a top level binding. Consider (#20123): module M where x = 5 f y = (x, y) -The MR means that x=5 is not generalise, so f's binding is no Closed. So we'd -be tempted to use NoGen. But that leads to f :: Any -> (Integer, Any), which -is plain stupid. +The MR means that x=5 is not generalised, so f's binding has a free variable +that is not ClosedTypeId. So we'd be tempted to use NoGen. But that leads to + f :: Any -> (Integer, Any) +which is plain stupid. NoGen is good when we have call sites, but not at top level, where the function may be exported. And it's easier to grok "MonoLocalBinds" as ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -204,7 +204,7 @@ tcPolyExprCheck expr res_ty = do { (wrap, expr') <- tcSkolemiseExpectedType ty thing_inside ; return (mkHsWrap wrap expr') } outer_skolemise (Right sig) thing_inside - = do { (wrap, expr') <- tcSkolemiseCompleteSig sig thing_inside + = do { (wrap, expr') <- tcSkolemiseCompleteSig sig NotStatic thing_inside ; return (mkHsWrap wrap expr') } -- inner_skolemise is used when we do not have a lambda ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -689,7 +689,8 @@ tcExprSig expr sig@(TcPartialSig (PSig { psig_name = name, psig_loc = loc })) = NoRestrictions ; ((qtvs, givens, ev_binds, _), residual) <- captureConstraints $ - simplifyInfer NotTopLevel tclvl infer_mode [sig_inst] [(name, tau)] wanted + simplifyInfer NotTopLevel NotStatic tclvl infer_mode + [sig_inst] [(name, tau)] wanted ; emitConstraints residual ; tau <- liftZonkM $ zonkTcType tau ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -622,7 +622,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of VarPat x (L l name) -> do { (wrap, id) <- tcPatBndr penv name pat_ty - ; res <- tcCheckUsage name (scaledMult pat_ty) $ + ; res <- tcCheckUsage (Scaled (scaledMult pat_ty) id) $ tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -1979,7 +1979,7 @@ setMainCtxt main_name io_ty thing_inside checkConstraints skol_info [] [] $ -- Builds an implication if necessary thing_inside -- e.g. with -fdefer-type-errors where - skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty [] + skol_info = SigSkol IsStatic (FunSigCtxt main_name NoRRC) io_ty [] {- Note [Dealing with main] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2635,7 +2635,7 @@ tcRnExpr hsc_env mode rdr_expr let { fresh_it = itName uniq (getLocA rdr_expr) } ; ((qtvs, dicts, _, _), residual) <- captureConstraints $ - simplifyInfer TopLevel tclvl infer_mode + simplifyInfer TopLevel IsStatic tclvl infer_mode [] {- No sig vars -} [(fresh_it, res_ty)] lie ; ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -46,6 +46,8 @@ import GHC.Tc.Instance.FunDeps import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType +import GHC.Hs.Binds ( StaticFlag ) + import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Ppr @@ -908,7 +910,8 @@ instance Outputable InferMode where ppr EagerDefaulting = text "EagerDefaulting" ppr NoRestrictions = text "NoRestrictions" -simplifyInfer :: TopLevelFlag +simplifyInfer :: TopLevelFlag -- Syntactically top-level + -> StaticFlag -- Static (morally top level) -> TcLevel -- Used when generating the constraints -> InferMode -> [TcIdSigInst] -- Any signatures (possibly partial) @@ -920,7 +923,7 @@ simplifyInfer :: TopLevelFlag TcEvBinds, -- ... binding these evidence variables Bool) -- True <=> the residual constraints are insoluble -simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds +simplifyInfer top_lvl static_flag rhs_tclvl infer_mode sigs name_taus wanteds | isEmptyWC wanteds = do { -- When quantifying, we want to preserve any order of variables as they -- appear in partial signatures. cf. decideQuantifiedTyVars @@ -931,7 +934,7 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) - ; skol_info <- mkSkolemInfo (InferSkol name_taus) + ; skol_info <- mkSkolemInfo (InferSkol static_flag name_taus) ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds, False) } @@ -992,7 +995,8 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds ; bound_theta_vars <- mapM TcM.newEvVar bound_theta ; let full_theta = map idType bound_theta_vars - skol_info = InferSkol [ (name, mkPhiTy full_theta ty) + skol_info = InferSkol static_flag + [ (name, mkPhiTy full_theta ty) | (name, ty) <- name_taus ] -- mkPhiTy: we don't add the quantified variables here, because -- they are also bound in ic_skols and we want them to be tidied ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1284,7 +1284,7 @@ nestImplicTcS skol_info ev_binds_var inner_tclvl (TcS thing_inside) -- start with a completely empty inert set; in particular, no Givens -- See (SF3) in Note [Grand plan for static forms] -- in GHC.Iface.Tidy.StaticPtrTable - | StaticFormSkol <- skol_info + | isStaticSkolInfo skol_info = emptyInertSet inner_tclvl | otherwise ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -533,7 +533,7 @@ findRedundantGivens (Implic { ic_info = info, ic_need = need, ic_given = givens = any isImprovementPred (pred : transSuperClasses pred) warnRedundantGivens :: SkolemInfoAnon -> Bool -warnRedundantGivens (SigSkol ctxt _ _) +warnRedundantGivens (SigSkol _ ctxt _ _) = case ctxt of FunSigCtxt _ rrc -> reportRedundantConstraints rrc ExprSigCtxt rrc -> reportRedundantConstraints rrc ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -299,7 +299,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ; (ev_binds, (tc_bind, _)) <- checkConstraints skol_info tyvars [this_dict] $ - tcPolyCheck no_prag_fn local_dm_sig + tcPolyCheck NotStatic no_prag_fn local_dm_sig (L bind_loc lm_bind) ; let export = ABE { abe_poly = global_dm_id ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -2121,7 +2121,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind , sig_ctxt = ctxt , sig_loc = getLocA hs_sig_ty } - ; (tc_bind, [Scaled _ inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind + ; (tc_bind, [Scaled _ inner_id]) <- tcPolyCheck NotStatic no_prag_fn inner_meth_sig meth_bind ; let export = ABE { abe_poly = local_meth_id , abe_mono = inner_id @@ -2146,7 +2146,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind -- instance C [c] where { op = <rhs> } -- In <rhs>, 'c' is scope but 'b' is not! - ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind + ; (tc_bind, _) <- tcPolyCheck NotStatic no_prag_fn tc_sig meth_bind ; return tc_bind } where ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -153,7 +153,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details ; ((univ_tvs, req_dicts, ev_binds, _), residual) <- captureConstraints $ - simplifyInfer TopLevel tclvl NoRestrictions [] named_taus wanted + simplifyInfer TopLevel IsStatic tclvl NoRestrictions [] named_taus wanted ; top_ev_binds <- checkNoErrs (simplifyTop residual) ; addTopEvBinds top_ev_binds $ @@ -392,7 +392,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; checkTc (all (isManyTy . scaledMult) arg_tys) $ TcRnLinearPatSyn sig_body_ty - ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty []) + ; skol_info <- mkSkolemInfo (SigSkol IsStatic (PatSynCtxt name) pat_ty []) -- The type here is a bit bogus, but we do not print -- the type for PatSynCtxt, so it doesn't matter -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin" @@ -980,7 +980,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) ; traceTc "tcPatSynBuilderBind {" $ vcat [ ppr patsyn , ppr builder_id <+> dcolon <+> ppr (idType builder_id) ] - ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind) + ; (builder_binds, _) <- tcPolyCheck IsStatic emptyPragEnv sig (noLocA bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } } ===================================== compiler/GHC/Tc/Types/BasicTypes.hs ===================================== @@ -351,7 +351,7 @@ data IdBindingInfo = NotLetBound | LetBound - { lb_top :: StaticFlag + { lb_static :: StaticFlag -- IsStatic <=> this binding may safely be moved to top level -- E.g f x = let ys = reverse [1,2] -- zs = reverse ys @@ -369,14 +369,17 @@ data IdBindingInfo -- all free vars of `e` have lb_clos=ClosedTypeId } --- | IsGroupClosed describes a group of --- mutually-recursive /renamed/ (but not yet typechecked) bindings +-- | IsGroupClosed describes a group of mutually-recursive /renamed/ +-- (but not yet typechecked) bindings data IsGroupClosed = IsGroupClosed - StaticFlag -- IsStatic <=> all free vars of the group are top-level or static - (NameEnv RhsNames) -- Frees for the RHS of each binding in the group - -- (includes free vars of RHS bound in the same group) - ClosedTypeId -- True <=> all the free vars of the group have closed types + { gc_static :: StaticFlag -- IsStatic <=> all free vars of the group are top-level or static + + , gc_fvs :: NameEnv RhsNames -- Free vars for the RHS of each binding in the group + -- (includes free vars of RHS bound in the same group) + + , gc_closed :: ClosedTypeId -- True <=> all the free vars of the group have closed types + } type RhsNames = NameSet -- Names of variables, mentioned on the RHS of -- a definition, that are not Global or ClosedLet @@ -536,7 +539,7 @@ in the type environment. instance Outputable IdBindingInfo where ppr NotLetBound = text "NotLetBound" - ppr (LetBound { lb_top = top_lvl, lb_fvs = fvs, lb_closed = cls }) + ppr (LetBound { lb_static = top_lvl, lb_fvs = fvs, lb_closed = cls }) = text "LetBound" <> braces (sep [ ppr top_lvl, text "closed-type=" <+> ppr cls , ppr fvs ]) ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1642,7 +1642,7 @@ getUserGivensFromImplics implics get acc [] = acc get acc (implic : implics) - | StaticFormSkol <- ic_info implic + | isStaticSkolInfo (ic_info implic) = acc -- For static forms, ignore all outer givens -- See (SF3) in Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable @@ -2150,7 +2150,9 @@ checkSkolInfoAnon :: SkolemInfoAnon -- From the implication -- So it doesn't matter much if its's incomplete checkSkolInfoAnon sk1 sk2 = go sk1 sk2 where - go (SigSkol c1 t1 s1) (SigSkol c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2 + go (SigSkol _ c1 t1 s1) (SigSkol _ c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2 + go (InferSkol _ ids1) (InferSkol _ ids2) = equalLength ids1 ids2 && + and (zipWith eq_pr ids1 ids2) go (SigTypeSkol cx1) (SigTypeSkol cx2) = cx1==cx2 go (ForAllSkol _) (ForAllSkol _) = True @@ -2167,8 +2169,6 @@ checkSkolInfoAnon sk1 sk2 = go sk1 sk2 go (SpecESkol n1) (SpecESkol n2) = n1==n2 go (PatSkol c1 _) (PatSkol c2 _) = getName c1 == getName c2 -- Too tedious to compare the HsMatchContexts - go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 && - and (zipWith eq_pr ids1 ids2) go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2 go ReifySkol ReifySkol = True go RuntimeUnkSkol RuntimeUnkSkol = True ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -15,9 +15,9 @@ module GHC.Tc.Types.Origin ( ReportRedundantConstraints(..), reportRedundantConstraints, redundantConstraintsSpan, - -- * SkolemInfo + -- * SkolemInfo, SkolemInfoAnon SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, - unkSkol, unkSkolAnon, + unkSkol, unkSkolAnon, isStaticSkolInfo, -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, @@ -270,11 +270,18 @@ data SkolemInfoAnon -- a programmer-supplied type signature -- Location of the binding site is on the TyVar -- See Note [SigSkol SkolemInfo] + StaticFlag UserTypeCtxt -- What sort of signature TcType -- Original type signature (before skolemisation) [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar -- to its instantiated version + | InferSkol + StaticFlag + [(Name,TcType)] -- We have inferred a type for these (mutually recursive) + -- polymorphic Ids, and are now checking that their RHS + -- constraints are satisfied. + | SigTypeSkol UserTypeCtxt -- like SigSkol, but when we're kind-checking the *type* -- hence, we have less info @@ -311,11 +318,6 @@ data SkolemInfoAnon | RuleSkol RuleName -- The LHS of a RULE | SpecESkol Name -- A SPECIALISE pragma - | InferSkol [(Name,TcType)] - -- We have inferred a type for these (mutually recursive) - -- polymorphic Ids, and are now checking that their RHS - -- constraints are satisfied. - | BracketSkol -- Template Haskell bracket | UnifyForAllSkol -- We are unifying two for-all types @@ -370,7 +372,7 @@ instance Outputable SkolemInfoAnon where pprSkolInfo :: SkolemInfoAnon -> SDoc -- Complete the sentence "is a rigid type variable bound by..." -pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty +pprSkolInfo (SigSkol _ cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx pprSkolInfo (ForAllSkol tvs) = text "an explicit forall" <+> ppr tvs pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" @@ -388,7 +390,7 @@ pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name pprSkolInfo (SpecESkol name) = text "a SPECIALISE pragma for" <+> quotes (ppr name) pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl , text "in" <+> pprMatchContext mc ] -pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") +pprSkolInfo (InferSkol _ ids) = hang (text "the inferred type" <> plural ids <+> text "of") 2 (vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]) pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty @@ -467,6 +469,13 @@ in the right place. So we proceed as follows: the instantiated skolems lying around in other types. -} +isStaticSkolInfo :: SkolemInfoAnon -> Bool +isStaticSkolInfo StaticFormSkol = True +isStaticSkolInfo (SigSkol IsStatic _ _ _) = True +isStaticSkolInfo (InferSkol IsStatic _) = True +isStaticSkolInfo _ = False + + {- ********************************************************************* * * CtOrigin ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -91,7 +91,7 @@ import GHC.Iface.Load import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import {-# SOURCE #-} GHC.Tc.Utils.TcMType ( tcCheckUsage ) +import GHC.Tc.Utils.TcMType ( tcCheckUsage ) import GHC.Tc.Types.LclEnv import GHC.Core.InstEnv @@ -675,7 +675,7 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a tcExtendRecIds pairs thing_inside = tc_extend_local_env NotTopLevel [ (name, ATcId { tct_id = let_id - , tct_info = LetBound { lb_top = NotStatic + , tct_info = LetBound { lb_static = NotStatic , lb_fvs = emptyNameSet , lb_closed = False } }) | (name, let_id) <- pairs ] $ @@ -691,7 +691,7 @@ tcExtendSigIds top_lvl sig_ids thing_inside , tct_info = info }) | id <- sig_ids , let closed = isTypeClosedLetBndr id - info = LetBound { lb_top = NotStatic + info = LetBound { lb_static = NotStatic , lb_fvs = emptyNameSet , lb_closed = closed } ] thing_inside @@ -703,25 +703,21 @@ tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed -- Used for both top-level value bindings and nested let/where-bindings -- Used for a single NonRec or a single Rec -- Adds to the TcBinderStack too -tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_static fv_env _) +tcExtendLetEnv top_lvl _sig_fn + (IsGroupClosed {gc_static = group_static, gc_fvs = fv_env}) ids thing_inside = tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $ tc_extend_local_env top_lvl [ (idName id, ATcId { tct_id = id , tct_info = mk_tct_info id }) | Scaled _ id <- ids ] $ - foldr check_usage thing_inside scaled_names + foldr tcCheckUsage thing_inside ids where mk_tct_info id - = LetBound { lb_top = group_static + = LetBound { lb_static = group_static , lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet , lb_closed = isTypeClosedLetBndr id } - scaled_names = [Scaled p (idName id) | Scaled p id <- ids ] - - check_usage :: Scaled Name -> TcM a -> TcM a - check_usage (Scaled p id) thing_inside = tcCheckUsage id p thing_inside - tcExtendIdEnv :: [TcId] -> TcM a -> TcM a -- For lambda-bound and case-bound Ids -- Extends the TcBinderStack as well ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -2227,13 +2227,15 @@ a \/\a in the final result but all the occurrences of a will be zonked to () -- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the -- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the -- usage environment. -tcCheckUsage :: Name -> Mult -> TcM a -> TcM a -tcCheckUsage name id_mult thing_inside +tcCheckUsage :: Scaled TcId -> TcM a -> TcM a +tcCheckUsage (Scaled id_mult id) thing_inside = do { (local_usage, result) <- tcCollectingUsage thing_inside ; check_usage (lookupUE local_usage name) ; tcEmitBindingUsage (deleteUE local_usage name) ; return result } where + name = idName id + check_usage :: Usage -> TcM () -- Checks that the usage of the newly introduced binder is compatible with -- its multiplicity. ===================================== compiler/GHC/Tc/Utils/TcMType.hs-boot deleted ===================================== @@ -1,7 +0,0 @@ -module GHC.Tc.Utils.TcMType where - -import GHC.Tc.Types -import GHC.Types.Name -import GHC.Core.TyCo.Rep - -tcCheckUsage :: Name -> Mult -> TcM a -> TcM a ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -421,6 +421,7 @@ Some examples: tcSkolemiseGeneral :: DeepSubsumptionFlag + -> StaticFlag -> UserTypeCtxt -> TcType -> TcType -- top_ty and expected_ty -- Here, top_ty is the type we started to skolemise; used only in SigSkol @@ -429,11 +430,11 @@ tcSkolemiseGeneral -- keeping the same top_ty, but successively smaller expected_tys -> ([(Name, TcInvisTVBinder)] -> TcType -> TcM result) -> TcM (HsWrapper, result) -tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside +tcSkolemiseGeneral ds_flag static_flag ctxt top_ty expected_ty thing_inside | isRhoTyDS ds_flag expected_ty -- Fast path for a very very common case: no skolemisation to do -- But still call checkConstraints in case we need an implication regardless - = do { let sig_skol = SigSkol ctxt top_ty [] + = do { let sig_skol = SigSkol static_flag ctxt top_ty [] ; (ev_binds, result) <- checkConstraints sig_skol [] [] $ thing_inside [] expected_ty ; return (mkWpLet ev_binds, result) } @@ -444,7 +445,7 @@ tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside ; rec { (wrap, tv_prs, given, rho_ty) <- case ds_flag of Deep -> deeplySkolemise skol_info expected_ty Shallow -> topSkolemise skol_info expected_ty - ; let sig_skol = SigSkol ctxt top_ty (map (fmap binderVar) tv_prs) + ; let sig_skol = SigSkol static_flag ctxt top_ty (map (fmap binderVar) tv_prs) ; skol_info <- mkSkolemInfo sig_skol } ; let skol_tvs = map (binderVar . snd) tv_prs @@ -457,6 +458,7 @@ tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside -- often empty, in which case mkWpLet is a no-op tcSkolemiseCompleteSig :: TcCompleteSig + -> StaticFlag -> ([ExpPatType] -> TcRhoType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty @@ -464,11 +466,11 @@ tcSkolemiseCompleteSig :: TcCompleteSig -- tcSkolemiseCompleteSig and tcTopSkolemise tcSkolemiseCompleteSig (CSig { sig_bndr = poly_id, sig_ctxt = ctxt, sig_loc = loc }) - thing_inside + static_flag thing_inside = do { cur_loc <- getSrcSpanM ; let poly_ty = idType poly_id ; setSrcSpan loc $ -- Sets the location for the implication constraint - tcSkolemiseGeneral Shallow ctxt poly_ty poly_ty $ \tv_prs rho_ty -> + tcSkolemiseGeneral Shallow static_flag ctxt poly_ty poly_ty $ \tv_prs rho_ty -> setSrcSpan cur_loc $ -- Revert to the original location tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $ thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty } @@ -482,14 +484,14 @@ tcSkolemiseExpectedType :: TcSigmaType -- In the call (f e) we will call tcSkolemiseExpectedType on (forall a.blah) -- before typececking `e` tcSkolemiseExpectedType exp_ty thing_inside - = tcSkolemiseGeneral Shallow GenSigCtxt exp_ty exp_ty $ \tv_prs rho_ty -> + = tcSkolemiseGeneral Shallow NotStatic GenSigCtxt exp_ty exp_ty $ \tv_prs rho_ty -> thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty tcSkolemise :: DeepSubsumptionFlag -> UserTypeCtxt -> TcSigmaType -> (TcRhoType -> TcM result) -> TcM (HsWrapper, result) tcSkolemise ds_flag ctxt expected_ty thing_inside - = tcSkolemiseGeneral ds_flag ctxt expected_ty expected_ty $ \_ rho_ty -> + = tcSkolemiseGeneral ds_flag NotStatic ctxt expected_ty expected_ty $ \_ rho_ty -> thing_inside rho_ty checkConstraints :: SkolemInfoAnon @@ -584,6 +586,7 @@ implicationNeeded skol_info skol_tvs given alwaysBuildImplication :: SkolemInfoAnon -> Bool -- See Note [When to build an implication] +alwaysBuildImplication (SigSkol IsStatic _ _ _) = True alwaysBuildImplication _ = False {- Commmented out for now while I figure out about error messages. @@ -829,7 +832,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside | isSigmaTy ty -- An invisible quantifier at the top || (n_req > 0 && isForAllTy ty) -- A visible quantifier at top, and we need it = do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty - ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs) + ; let sig_skol = SigSkol NotStatic ctx top_ty (tv_nms `zip` skol_tvs) skol_tvs = binderVars bndrs ; skol_info <- mkSkolemInfo sig_skol } -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] @@ -854,7 +857,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside ; case ds_flag of Shallow -> do { res <- thing_inside pat_tys (mkCheckExpType rho_ty) ; return (idHsWrapper, res) } - Deep -> tcSkolemiseGeneral Deep ctx top_ty rho_ty $ \_ rho_ty -> + Deep -> tcSkolemiseGeneral Deep NotStatic ctx top_ty rho_ty $ \_ rho_ty -> -- "_" drop the /deeply/-skolemise binders -- They do not line up with binders in the Match thing_inside pat_tys (mkCheckExpType rho_ty) } @@ -2054,7 +2057,7 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected arg_wrap res_wrap } where - given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) + given_orig = GivenOrigin (SigSkol NotStatic GenSigCtxt exp_arg []) -- | Like 'mkWpFun', except that it performs the necessary -- representation-polymorphism checks on the argument type in the case that ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -521,10 +521,10 @@ zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk zonkSkolemInfoAnon :: SkolemInfoAnon -> ZonkM SkolemInfoAnon -zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty - ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys - ; return (InferSkol ntys') } +zonkSkolemInfoAnon (SigSkol st cx ty tv_prs) = do { ty' <- zonkTcType ty + ; return (SigSkol st cx ty' tv_prs) } +zonkSkolemInfoAnon (InferSkol st ntys) = do { ntys' <- mapM do_one ntys + ; return (InferSkol st ntys') } where do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } zonkSkolemInfoAnon skol_info = return skol_info View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b0c10d66f4576bd6cf0313a58387312... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b0c10d66f4576bd6cf0313a58387312... You're receiving this email because of your account on gitlab.haskell.org.