GitLab

Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC

Commits:

45b0ad9f

by Florian Ragwitz at 2026-09-25T07:19:54-07:00

hpc: Do not create top-level boxes for generated instance methods

Users care about which of their written methods are or aren't covered, not
whether all of the inherited methods are covered as well. Those should be
covered where they are implemented.

We achieve that by stopping to generate top-level boxes which will often appear
as uncovered with no clear indication as to why, and no way to fix other than
excercising code the user has not written.

Fixes #17155, #15932.

439a0561

by Florian Ragwitz at 2026-09-25T07:19:54-07:00

hpc: Provide coverage information for class instances

After fixing #17155, we no longer create top-level boxes for the source spans
of instance heads (previously that was the source span used for
inherited/generated instance methods).

With those boxes gone, we can introduce a new top-level box for each class
instance with that instance head source span, and provide more meaningful
coverage semantics for it.

We make the use of any of the instance's methods (user-written or generated)
tick this box, providing the programmer with useful information about whether
or not the instance was exercised at run-time, and whether the instance might
be unnecessary.

fe978c11

by Florian Ragwitz at 2026-09-25T07:19:54-07:00

hpc: Don't allocate boxes for methodless classes

With the plumbing we currently have, these could never be covered, which is not
helpful to hpc users. This could be improved upon further.

f6d6ed5b
by Florian Ragwitz at 2026-09-25T07:19:54-07:00
```
Add a changelog entry for new HPC features
```

Changes:

changelog.d/hpc-classinsts

 +section: compiler
 +synopsis: Improve coverage reporting for class instances and their methods
 +description:
++
 +  Coverage reporting (:ghc-flag:`-fhpc`) now treats class instances more
 +  naturally.
++
 +  Compiler-generated instance methods, such as inherited default methods, no
 +  longer receive separate top-level coverage boxes. Explicitly implemented
 +  instance methods retain their own declaration coverage.
++
 +  This means that it is no longer necessary to exercise all of a class' methods
 +  in order for it to appear "covered".
++
 +  Additionally, top-level coverage boxes are now created for all instances of
 +  classes with methods, and ticked by the use of *any* of the class' methods.
 +  This indicates that an instance was in fact used at run-time.
++
 +  Note that classes without any instance methods are currently excluded from
 +  this, and won't have any coverage boxes created.
++
 +mrs: !16632
 +issues: #17155 #15932

compiler/GHC/HsToCore.hs

@@ -147,6 +147,7 @@ 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
@@ -170,7 +171,8 @@ deSugar hsc_env
                                         (hsc_logger hsc_env)
                                         (initTicksConfig (hsc_dflags hsc_env))
                                         mod mod_loc
 -                                       export_set (typeEnvTyCons type_env) binds
 +                                       export_set (typeEnvTyCons type_env)
 +                                       insts inst_meths binds
                                else return (binds, Nothing)
          ; let modBreaks
                  | Just (_, _, breakpointSpecs) <- m_tickInfo

compiler/GHC/HsToCore/Ticks.hs

@@ -5,7 +5,7 @@
  {-
  (c) Galois, 2006
  (c) University of Glasgow, 2007
 -(c) Florian Ragwitz, 2025
 +(c) Florian Ragwitz, 2025-2026
  -}
  module GHC.HsToCore.Ticks
@@ -24,6 +24,8 @@ import GHC.Unit
  import GHC.Core.Type
  import GHC.Core.TyCon
 +import GHC.Core.InstEnv
 +import GHC.Core.Class
  import GHC.Data.Maybe
  import GHC.Data.FastString
@@ -48,6 +50,7 @@ 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)
@@ -56,6 +59,7 @@ import Data.Foldable (toList)
  import Trace.Hpc.Mix
  import Data.Bifunctor (second)
 +import Data.Functor
  import Data.List.NonEmpty (NonEmpty (..))
  import Data.Set (Set)
  import qualified Data.Set as Set
@@ -100,11 +104,15 @@ addTicksToBinds
                                  -- isExportedId doesn't work yet (the desugarer
                                  -- 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 binds
 +                mod mod_loc exports tyCons insts inst_meths binds
    | let passes = ticks_passes cfg
    , not (null passes)
    , Just orig_file <- ml_hs_file mod_loc = do
@@ -129,8 +137,13 @@ addTicksToBinds logger cfg
                        , this_mod     = mod
                        , tickishType  = tickish
                        , recSelBinds  = emptyVarEnv
 +                      , instMeths    = inst_meths
 +                      , instTicks    = emptyVarEnv
+                       }
 -                (binds',_,st') = unTM (addTickLHsBinds binds) env st
 +                addTick = do
 +                  instTicks <- allocInstTicks insts
 +                  withEnv (\e -> e{ instTicks }) $ addTickLHsBinds binds
 +                (binds',_,st') = unTM addTick env st
              in (binds', st')
            (binds1,st) = foldr tickPass (binds, initTTState) passes
@@ -231,7 +244,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
  addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
                                                   , abs_exports = abs_exports
                                                   }))) =
 -  withEnv (add_rec_sels . add_inlines . add_exports) $ do
 +  withEnv (add_inst_meths . add_rec_sels . add_inlines . add_exports) $ do
        binds' <- addTickLHsBinds binds
        return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }
    where
@@ -259,19 +272,24 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
                            | ABE{ abe_poly, abe_mono } <- abs_exports
                            , RecSelId{} <- [idDetails abe_poly] ] }
 +   add_inst_meths env =
 +     env{ instMeths = instMeths env `extendVarEnvList`
 +                        [ (abe_mono, dfun)
 +                        | ABE{ abe_poly, abe_mono } <- abs_exports
 +                        , Just dfun <- [lookupVarEnv (instMeths env) abe_poly] ] }
++
  addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do
    let name = getOccString id
    decl_path <- getPathEntry
    density <- getDensity
 +  env <- getEnv
 -  inline_ids <- liftM inlines getEnv
    -- See Note [inline sccs]
    let inline   = isInlinePragma (idInlinePragma id)
 -                 || id `elemVarSet` inline_ids
 +                 || id `elemVarSet` inlines env
    -- See Note [inline sccs]
 -  tickish <- tickishType `liftM` getEnv
 -  case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do
 +  case tickishType env of { ProfNotes | inline -> return (L pos funBind); _ -> do
    -- See Note [Record-selector ticks]
    selTicks <- recSelTick id
@@ -294,16 +312,26 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
        toplev = null decl_path
        exported = idName id `elemNameSet` exported_names
 -  tick <- if not blackListed &&
 -               shouldTickBind density toplev exported simple inline
 +  -- See Note [Instance Method Coverage].
 +  let generatedInstMeth = density == TickForCoverage
 +        && id `elemVarEnv` instMeths env
 +        && isGenerated (mg_origin (mg_ext matches))
++
 +  tick <- if not generatedInstMeth
 +               && not blackListed
 +               && shouldTickBind density toplev exported simple inline
               then
                  bindTick density name (locA pos) fvs
               else
                  return Nothing
 +  -- See Note [Instance Method Coverage].
 +  instTick <- instMethTick id
++
    let mbCons = maybe Prelude.id (:)
    return $ L pos $ funBind { fun_matches = mg
 -                           , fun_ext = second (tick `mbCons`) (fun_ext funBind) }
 +                           , fun_ext = second ((instTick `mbCons`) . (tick `mbCons`))
 +                                              (fun_ext funBind) }
    } }
    where
      -- See Note [Record-selector ticks]
@@ -338,6 +366,32 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
  -- This scheme could be extended further in the future, making coverage for
  -- positional constructor fields mean that the field was accessed at run-time.
 +-- Note [Instance Method Coverage]
 +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +-- Users expect source-level semantics for coverage reports (see #17155,
 +-- #15932). That is, code they've written themselves should be marked as covered
 +-- iff it is evaluated at run-time. Given that the implementation of class
 +-- instances creates top-level bindings for all methods of an instance,
 +-- 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.
 +--
 +-- 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
 +-- tick box at the instance head and tick that box when any method of that
 +-- instance is evaluated.
 +--
 +-- As marker/tag-like class instances without any methods would always appear
 +-- as uncovered using the above mechanism, we exclude them when creating
 +-- instance tick boxes. This could potentially be improved in the future by
 +-- tracking if any functions requiring an instance of an empty class have been
 +-- evaluated.
++
  -- TODO: Revisit this
  addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
                                      , pat_rhs = rhs
@@ -1098,6 +1152,8 @@ data TickTransEnv = TTE { fileName     :: FastString
                          , this_mod     :: Module
                          , tickishType  :: TickishType
                          , recSelBinds  :: IdEnv DVarSet
 +                        , instMeths    :: IdEnv DFunId
 +                        , instTicks    :: IdEnv CoreTickish
+                         }
  --      deriving Show
@@ -1238,6 +1294,21 @@ isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList
  isBlackListed GeneratedSrcSpan{} = return False
  isBlackListed UnhelpfulSpan{} = return False
 +-- See Note [Instance Method Coverage].
 +allocInstTicks :: [ClsInst] -> TM (IdEnv CoreTickish)
 +allocInstTicks insts =
 +    ifDensity TickForCoverage (mkVarEnv . catMaybes <$> mapM alloc insts) (pure emptyVarEnv)
 +  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))
++
 +-- See Note [Instance Method Coverage].
 +instMethTick :: Id -> TM (Maybe CoreTickish)
 +instMethTick id = getEnv <&> \e -> lookupVarEnv (instMeths e) id >>= lookupVarEnv (instTicks e)
++
  -- the tick application inherits the source position of its
  -- expression argument to support nested box allocations
  allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)

compiler/GHC/Tc/Types.hs

@@ -533,6 +533,7 @@ data TcGblEnv
            -- 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;