GitLab

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

Commits:

45019587
by Florian Ragwitz at 2026-10-07T18:54:05-07:00
```
Revert back to just using getOccString for DFunIds
```

100074ba

by Florian Ragwitz at 2026-10-07T18:54:05-07:00

Limit instance and instance method coverage to HPC only

It's not useful for SourceNotes, which is the other tickishType included in
TickForCoverage.

a9c4f52b
by Florian Ragwitz at 2026-10-07T18:54:05-07:00
```
Limit record selector ticking to HPC
```

3 changed files:

compiler/GHC/HsToCore/Ticks.hs
testsuite/tests/hpc/instmeths/instmeths.hs
testsuite/tests/hpc/instmeths/instmeths.stdout

Changes:

compiler/GHC/HsToCore/Ticks.hs

@@ -51,7 +51,6 @@ 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)
@@ -313,7 +312,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
        exported = idName id `elemNameSet` exported_names
    -- See Note [Instance Method Coverage].
 -  let generatedInstMeth = density == TickForCoverage
 +  let generatedInstMeth = tickishType env == HpcTicks
          && id `elemVarEnv` instMeths env
          && isGenerated (mg_origin (mg_ext matches))
@@ -1236,6 +1235,9 @@ getDensity = TM $ \env st -> (density env, noFVs, st)
  ifDensity :: TickDensity -> TM a -> TM a -> TM a
  ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
 +ifTickish :: TickishType -> TM a -> TM a -> TM a
 +ifTickish want th el = tickishType <$> getEnv >>= \got -> if want == got then th else el
++
  getFreeVars :: TM a -> TM (FreeVars, a)
  getFreeVars (TM m)
    = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
@@ -1295,13 +1297,12 @@ isBlackListed UnhelpfulSpan{} = return False
  -- See Note [Instance Method Coverage].
  allocInstTicks :: [ClsInst] -> TM (NameEnv CoreTickish)
  allocInstTicks insts =
 -    ifDensity TickForCoverage (mkNameEnv . catMaybes <$> mapM alloc insts) (pure emptyNameEnv)
 +    ifTickish HpcTicks (mkNameEnv . catMaybes <$> mapM alloc insts) (pure emptyNameEnv)
    where
      alloc ClsInst{ is_dfun, is_cls }
        | null (classMethods is_cls) = pure Nothing
 -      | otherwise = fmap (idName is_dfun,) <$> allocATickBox (TopLevelBox [s])
 +      | otherwise = fmap (idName is_dfun,) <$> allocATickBox (TopLevelBox [getOccString is_dfun])
                                                               False True (getSrcSpan is_dfun) noFVs
 -      where s = showSDocOneLine defaultSDocContext (pprSigmaType (idType is_dfun))
  -- See Note [Instance Method Coverage].
  instMethTick :: Id -> TM (Maybe CoreTickish)
@@ -1325,7 +1326,7 @@ allocTickBox boxLabel countEntries topOnly pos m
        return (this_loc (XExpr $ HsTick tickish $ this_loc e))
  recSelTick :: Id -> TM (Maybe [CoreTickish])
 -recSelTick id = ifDensity TickForCoverage maybe_tick (pure Nothing)
 +recSelTick id = ifTickish HpcTicks maybe_tick (pure Nothing)
    where
      maybe_tick = getEnv >>=
        maybe (pure Nothing) tick_all . (`lookupVarEnv` id) . recSelBinds

testsuite/tests/hpc/instmeths/instmeths.hs

@@ -27,7 +27,7 @@ instance Marker (T Bool)
  interesting :: (Int, MixEntry) -> Maybe (Int, HpcPos, String)
  interesting (n, (pos, TopLevelBox [name])) | isInteresting name = Just (n, pos, name)
    where isInteresting = (||) <$> isInst <*> isMeth
 -        isInst = ("T" `isInfixOf`)
 +        isInst = ("$f" `isPrefixOf`)
          isMeth = (||) <$> (`elem` ["(==)", "(/=)", "show", "showList", "showsPrec", "fmap", "(<$)"])
                        <*> ("Meth" `isInfixOf`)
  interesting _ = Nothing

testsuite/tests/hpc/instmeths/instmeths.stdout

  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\"")