Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC Commits: 66df1b00 by Florian Ragwitz at 2026-10-07T18:00:32-07:00 Remove tcg_inst_meths in favour of a new IdDetails constructor Thanks for this great suggestion, Sam! <3 - - - - - 86f16aea by Florian Ragwitz at 2026-10-07T18:00:32-07:00 Revert back to just using getOccString for DFunIds - - - - - 12 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Id/Info.hs - testsuite/tests/hpc/instmeths/instmeths.stdout - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -3082,6 +3082,7 @@ wantCallsFor _env f JoinId {} -> True WorkerLikeId {} -> True RepPolyId {} -> True + InstMethId {} -> True interestingDict :: SpecEnv -> CoreExpr -> Bool -- This is a subtle and important function ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -453,6 +453,7 @@ toIfaceTopBndr id toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails (InstMethId {}) = IfVanillaId toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -147,7 +147,6 @@ deSugar hsc_env tcg_tcs = tcs, tcg_default_exports = defaults, tcg_insts = insts, - tcg_inst_meths = inst_meths, tcg_fam_insts = fam_insts, tcg_complete_matches = complete_matches, tcg_self_boot = self_boot @@ -172,7 +171,7 @@ deSugar hsc_env (initTicksConfig (hsc_dflags hsc_env)) mod mod_loc export_set (typeEnvTyCons type_env) - insts inst_meths binds + insts binds else return (binds, Nothing) ; let modBreaks | Just (_, _, breakpointSpecs) <- m_tickInfo ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE NondecreasingIndentation, DataKinds #-} +{-# LANGUAGE NondecreasingIndentation, DataKinds, ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -45,12 +45,12 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Set import GHC.Types.Name +import GHC.Types.Name.Env import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Tickish import GHC.Types.ProfAuto import GHC.Tc.Types.ErrCtxt -import GHC.Tc.Utils.TcType import Control.Monad import Data.List (isSuffixOf, intersperse) @@ -105,14 +105,11 @@ addTicksToBinds -- hasn't set it), so we have to work from this set. -> [TyCon] -- ^ Type constructors in this module -> [ClsInst] -- ^ Class instances in this module - -> IdEnv DFunId -- ^ Mapping from class method Ids to the DFunIds - -- of the class instance they belong to. See Note - -- [Instance Method Coverage]. -> LHsBinds GhcTc -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick, SizedSeq Tick)) addTicksToBinds logger cfg - mod mod_loc exports tyCons insts inst_meths binds + mod mod_loc exports tyCons insts binds | let passes = ticks_passes cfg , not (null passes) , Just orig_file <- ml_hs_file mod_loc = do @@ -137,8 +134,8 @@ addTicksToBinds logger cfg , this_mod = mod , tickishType = tickish , recSelBinds = emptyVarEnv - , instMeths = inst_meths - , instTicks = emptyVarEnv + , instMeths = emptyVarEnv + , instTicks = emptyNameEnv } addTick = do instTicks <- allocInstTicks insts @@ -276,7 +273,9 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds env{ instMeths = instMeths env `extendVarEnvList` [ (abe_mono, dfun) | ABE{ abe_poly, abe_mono } <- abs_exports - , Just dfun <- [lookupVarEnv (instMeths env) abe_poly] ] } + , Just dfun <- [instMeth abe_poly] ] } + where instMeth (idDetails -> InstMethId dfun) = Just dfun + instMeth id = lookupVarEnv (instMeths env) id addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do let name = getOccString id @@ -375,11 +374,9 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches -- inherited and hand-written, we need to go out of our way to create top-level -- tick boxes only for methods which correspond to user-written code. -- --- To do so, 'addTicksToBinds' receives a mapping from class instance 'Id's to --- the 'DFunId's of the dictionary backing the associated instance. When --- creating tick boxes for top-level bindings, we can then decide if a given --- 'FunBind' corresponds to an inherited/generated instance method of a class --- and skip creating the tick box for it. +-- Instance method 'Id's carry the name of the 'DFunId' of the instance they +-- belong to. When creating tick boxes for top-level bindings, we can use this +-- information to skip creating boxes for inherited/generated instance methods. -- -- Additionally, we also want to inform the user whether or not their class -- instance as a whole has been used at run-time. To do so, we create a single @@ -1152,8 +1149,8 @@ data TickTransEnv = TTE { fileName :: FastString , this_mod :: Module , tickishType :: TickishType , recSelBinds :: IdEnv DVarSet - , instMeths :: IdEnv DFunId - , instTicks :: IdEnv CoreTickish + , instMeths :: IdEnv Name + , instTicks :: NameEnv CoreTickish } -- deriving Show @@ -1295,19 +1292,18 @@ isBlackListed GeneratedSrcSpan{} = return False isBlackListed UnhelpfulSpan{} = return False -- See Note [Instance Method Coverage]. -allocInstTicks :: [ClsInst] -> TM (IdEnv CoreTickish) +allocInstTicks :: [ClsInst] -> TM (NameEnv CoreTickish) allocInstTicks insts = - ifDensity TickForCoverage (mkVarEnv . catMaybes <$> mapM alloc insts) (pure emptyVarEnv) + ifDensity TickForCoverage (mkNameEnv . catMaybes <$> mapM alloc insts) (pure emptyNameEnv) where alloc ClsInst{ is_dfun, is_cls } | null (classMethods is_cls) = pure Nothing - | otherwise = fmap (is_dfun,) <$> allocATickBox (TopLevelBox [s]) - False True (getSrcSpan is_dfun) noFVs - where s = showSDocOneLine defaultSDocContext (pprSigmaType (idType is_dfun)) + | otherwise = fmap (idName is_dfun,) <$> allocATickBox (TopLevelBox [getOccString is_dfun]) + False True (getSrcSpan is_dfun) noFVs -- See Note [Instance Method Coverage]. instMethTick :: Id -> TM (Maybe CoreTickish) -instMethTick id = getEnv <&> \e -> lookupVarEnv (instMeths e) id >>= lookupVarEnv (instTicks e) +instMethTick id = getEnv <&> \e -> lookupVarEnv (instMeths e) id >>= lookupNameEnv (instTicks e) -- the tick application inherits the source position of its -- expression argument to support nested box allocations ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -1768,7 +1768,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; - (inst_binds, inst_meths) <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -1800,9 +1800,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, , tcg_anns = tcg_anns tcg_env ++ annotations , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] - , tcg_inst_meths = tcg_inst_meths tcg_env `plusVarEnv` inst_meths } } ; -- See Note [Newtype constructor usage in foreign declarations] addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -59,7 +59,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.InstEnv -import GHC.Core.Predicate( classMethodInstTy ) +import GHC.Core.Predicate( classMethodInstTy, isCoVarType ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.DataCon @@ -72,6 +72,7 @@ import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.ForeignCall ( typeCheckCType ) import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.InlinePragma import GHC.Types.SourceFile import GHC.Types.SourceText @@ -1285,7 +1286,7 @@ takes a slightly different approach. ********************************************************************* -} tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] - -> TcM (LHsBinds GhcTc, IdEnv DFunId) + -> TcM (LHsBinds GhcTc) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -1302,11 +1303,11 @@ tcInstDecls2 tycl_decls inst_decls -- Add the default method Ids (again) -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits) -- See Note [Default methods in the type environment] - ; (inst_binds_s, inst_meths_s) <- unzip <$> (tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls) + ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ + mapM tcInstDecl2 inst_decls -- Done - ; return (dm_binds ++ concat inst_binds_s, plusVarEnvList inst_meths_s) } + ; return (dm_binds ++ concat inst_binds_s) } {- Note [Default methods in the type environment] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1322,12 +1323,12 @@ So right here in tcInstDecls2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk. -} -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc, IdEnv DFunId) +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return (emptyLHsBinds, emptyVarEnv)) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 dfun_ty) $ + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 dfun_ty) $ do { -- Instantiate the instance decl with skolem constants (skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- tcSkolDFunType dfun_ty ; dfun_ev_vars <- newEvVars dfun_theta @@ -1345,7 +1346,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- See Note [Typechecking plan for instance declarations] ; dfun_ev_binds_var <- newTcEvBinds ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics, meth_ids)) + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) <- pushTcLevelM $ do { (sc_ids, sc_binds, sc_implics) <- tcSuperClasses skol_info dfun_id clas inst_tyvars @@ -1359,8 +1360,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; return ( sc_ids ++ meth_ids , sc_binds ++ meth_binds - , sc_implics `unionBags` meth_implics - , meth_ids ) } + , sc_implics `unionBags` meth_implics ) } ; imp <- newImplication ; emitImplication $ @@ -1417,7 +1417,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_binds = [dict_bind] , abs_sig = True } - ; return (L loc' main_bind : sc_meth_binds, mkVarEnv $ (,dfun_id) <$> meth_ids) + ; return (L loc' main_bind : sc_meth_binds) } where dfun_id = instanceDFunId ispec @@ -1860,7 +1860,7 @@ tcMethods _skol_info dfun_id clas tyvars dfun_ev_vars inst_tys tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) tc_item (sel_id, dm_info) | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn - = tcMethodBody False clas tyvars dfun_ev_vars inst_tys + = tcMethodBody False dfun_id clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived hs_sig_fn spec_inst_prags prags sel_id user_bind bndr_loc @@ -1880,7 +1880,7 @@ tcMethods _skol_info dfun_id clas tyvars dfun_ev_vars inst_tys -- See Note [Implementation of Unsatisfiable constraints], -- in GHC.Tc.Errors, point (D). _ | (theta_id,unsat_msg) : _ <- unsat_thetas - -> do { (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + -> do { (meth_id, _) <- mkMethIds dfun_id clas tyvars dfun_ev_vars inst_tys sel_id ; unsat_id <- tcLookupKnownKeyId unsatisfiableIdKey -- Recall that unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a @@ -1897,7 +1897,7 @@ tcMethods _skol_info dfun_id clas tyvars dfun_ev_vars inst_tys Just (dm_name, dm_spec) -> do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name dm_spec ; tcMethodBody (is_vanilla_dm dm_spec) - clas tyvars dfun_ev_vars inst_tys + dfun_id clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived hs_sig_fn spec_inst_prags inline_prags sel_id meth_bind inst_loc } @@ -1905,7 +1905,7 @@ tcMethods _skol_info dfun_id clas tyvars dfun_ev_vars inst_tys -- No default method Nothing -> do { traceTc "tc_def: warn" (ppr sel_id) - ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, _) <- mkMethIds dfun_id clas tyvars dfun_ev_vars inst_tys sel_id ; dflags <- getDynFlags -- Add a binding whose RHS is an error @@ -2031,13 +2031,13 @@ Instead, we take the following approach: tcMethodBody :: Bool -- True <=> This is a vanilla default method -- See (TRC5) in Note [Tracking needed EvIds] -- in GHC.Tc.Solver.Solve - -> Class -> [TcTyVar] -> [EvVar] -> [TcType] + -> DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds -> Bool -> HsSigFun -> [LTcSpecPrag] -> [LSig GhcRn] -> Id -> LHsBind GhcRn -> SrcSpan -> TcM (TcId, LHsBind GhcTc, Maybe Implication) -tcMethodBody is_vanilla_dm clas tyvars dfun_ev_vars inst_tys +tcMethodBody is_vanilla_dm dfun_id clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived sig_fn spec_inst_prags prags sel_id (L bind_loc meth_bind) bndr_loc @@ -2045,7 +2045,7 @@ tcMethodBody is_vanilla_dm clas tyvars dfun_ev_vars inst_tys do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) ; let skol_info = MethSkol meth_name is_vanilla_dm ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ - mkMethIds clas tyvars dfun_ev_vars + mkMethIds dfun_id clas tyvars dfun_ev_vars inst_tys sel_id ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc) @@ -2163,16 +2163,19 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind -- they are all for meth_id ------------------------ -mkMethIds :: Class -> [TcTyVar] -> [EvVar] +mkMethIds :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId) -- returns (poly_id, local_id), but ignoring any instance signature -- See Note [Instance method signatures] -mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id +mkMethIds dfun_id clas tyvars dfun_ev_vars inst_tys sel_id = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) ; local_meth_name <- newName sel_occ -- Base the local_meth_name on the selector name, because -- type errors from tcMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name ManyTy poly_meth_ty + ; let poly_meth_id = + assert (not (isCoVarType poly_meth_ty)) $ + Var.mkLocalVar (InstMethId (idName dfun_id)) + poly_meth_name ManyTy poly_meth_ty vanillaIdInfo local_meth_id = mkLocalId local_meth_name ManyTy local_meth_ty ; return (poly_meth_id, local_meth_id) } ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -158,7 +158,6 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.Var -import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.SrcLoc @@ -532,9 +531,6 @@ data TcGblEnv -- NB. BangPattern is to fix a leak, see #15111 tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances -- NB. BangPattern is to fix a leak, see #15111 - tcg_inst_meths :: IdEnv DFunId, - -- ^ Maps instance method Ids to the DFunId of the instance they belong to. - -- See Note [Instance Method Coverage] in GHC.HsToCore.Ticks. tcg_ann_env :: AnnEnv, -- ^ And for annotations tcg_complete_match_env :: CompleteMatches, -- ^ The complete matches for all /home-package/ modules; ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -409,7 +409,6 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_knot_vars = hsc_type_env_vars hsc_env , tcg_known_key_maps = known_key_maps_var , tcg_inst_env = emptyInstEnv - , tcg_inst_meths = emptyVarEnv , tcg_fam_inst_env = emptyFamInstEnv , tcg_ann_env = emptyAnnEnv , tcg_complete_match_env = [] ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -222,6 +222,9 @@ data IdDetails -- - the [CbvMark] is always empty (and ignored) until after Tidy -- for ids from the current module -- - If non-empty, at least is isMarkedCbbv; see (CBV2) + | InstMethId Name + -- ^ An instance method. The 'Name' identifies the dictionary of the + -- instance it belongs to. data RecSelInfo = RSI { rsi_def :: [ConLike] -- Record selector defined for these @@ -449,6 +452,7 @@ pprIdDetails other = brackets (pp other) ppWhen is_naughty (text "(naughty)") pp CoVarId = text "CoVarId" pp (JoinId arity marks) = text "JoinId" <> parens (int arity) <> parens (ppr marks) + pp (InstMethId name) = text "InstMethId" <> parens (ppr name) {- ************************************************************************ ===================================== testsuite/tests/hpc/instmeths/instmeths.stdout ===================================== @@ -1,10 +1,10 @@ True "Foo (T' a) instance" -(1,"Eq a => Eq (T a)","Eq") -(0,"Foo (T a)","Foo (T a)") -(1,"Foo (T' a)","Foo (T' a)") -(1,"Functor T","Functor") -(0,"Show a => Show (T a)","Show") +(1,"$fEqT","Eq") +(0,"$fFooT","Foo (T a)") +(1,"$fFooT'","Foo (T' a)") +(1,"$fFunctorT","Functor") +(0,"$fShowT","Show") (0,"defMeth","defMeth = const \"class default\"") (0,"defMeth","defMeth = const \"Foo (T' a) instance\"") (0,"defMeth'","defMeth' = const \"class default\"") ===================================== testsuite/tests/simplCore/should_compile/T22375.stderr ===================================== @@ -5,7 +5,7 @@ Result size of Tidy Core -- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0} T22375.$fEqX_$c== :: X -> X -> Bool -[GblId, +[GblId[InstMethId(T22375.$fEqX)], Arity=2, Str=<SL><SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, @@ -27,7 +27,7 @@ T22375.$fEqX_$c== -- RHS size: {terms: 18, types: 9, coercions: 0, joins: 0/0} T22375.$fEqX_$c/= [InlPrag=INLINE (sat-args=2)] :: X -> X -> Bool -[GblId, +[GblId[InstMethId(T22375.$fEqX)], Arity=2, Str=<SL><SL>, Unf=Unf{Src=StableUser, TopLvl=True, ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr ===================================== @@ -5,7 +5,7 @@ Result size of Tidy Core -- RHS size: {terms: 14, types: 11, coercions: 2, joins: 0/0} T22375DataFamily.$fEqX_$c== :: X () -> X () -> Bool -[GblId, +[GblId[InstMethId(T22375DataFamily.$fEqX)], Arity=2, Str=<SL><SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, @@ -36,7 +36,7 @@ T22375DataFamily.$fEqX_$c== -- RHS size: {terms: 18, types: 11, coercions: 2, joins: 0/0} T22375DataFamily.$fEqX_$c/= [InlPrag=INLINE (sat-args=2)] :: X () -> X () -> Bool -[GblId, +[GblId[InstMethId(T22375DataFamily.$fEqX)], Arity=2, Str=<SL><SL>, Unf=Unf{Src=StableUser, TopLvl=True, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e0330f0f9a405717d5739c3ef5f3e0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e0330f0f9a405717d5739c3ef5f3e0... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help