Florian Ragwitz pushed to branch wip/rafl/cover-data at Glasgow Haskell Compiler / GHC Commits: d07db704 by Florian Ragwitz at 2025-07-16T08:47:10-07:00 Extend record-selector usage ticking to all binds using a record field Closes #26191. - - - - - 3 changed files: - compiler/GHC/HsToCore/Ticks.hs - testsuite/tests/hpc/recsel/recsel.hs - testsuite/tests/hpc/recsel/recsel.stdout Changes: ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -251,7 +251,7 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds add_rec_sels env = env{ recSelBinds = recSelBinds env `extendVarEnvList` - [ (abe_mono, abe_poly) + [ (abe_mono, [abe_poly]) | ABE{ abe_poly, abe_mono } <- abs_exports , RecSelId{} <- [idDetails abe_poly] ] } @@ -270,8 +270,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do -- See Note [Record-selector ticks] - selTick <- recSelTick id - case selTick of { Just tick -> tick_rec_sel tick; _ -> do + selTicks <- recSelTick id + case selTicks of { Just ticks -> tick_rec_sel ticks; _ -> do (fvs, mg) <- getFreeVars $ @@ -303,8 +303,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches } } where -- See Note [Record-selector ticks] - tick_rec_sel tick = - pure $ L pos $ funBind { fun_ext = second (tick :) (fun_ext funBind) } + tick_rec_sel ticks = + pure $ L pos $ funBind { fun_ext = second (ticks ++) (fun_ext funBind) } -- Note [Record-selector ticks] @@ -319,9 +319,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches -- coverage purposes to improve the developer experience. -- -- This is done by keeping track of which 'Id's are effectively bound to --- record fields (using NamedFieldPuns or RecordWildCards) in 'TickTransEnv's --- 'recSelBinds', and making 'HsVar's corresponding to those fields tick the --- appropriate box when executed. +-- record fields in 'TickTransEnv's 'recSelBinds', and making 'HsVar's +-- corresponding to those fields tick the appropriate box when executed. -- -- To enable that, we also treat 'FunBind's for record selector functions -- specially. We only create a TopLevelBox for the record selector function, @@ -330,10 +329,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches -- the fun_matches match group for record selector functions. -- -- This scheme could be extended further in the future, making coverage for --- constructor fields (named or even positional) mean that the field was --- accessed at run-time. For the time being, we only cover NamedFieldPuns and --- RecordWildCards binds to cover most practical use-cases while keeping it --- simple. +-- positional constructor fields mean that the field was accessed at run-time. -- TODO: Revisit this addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs @@ -519,7 +515,7 @@ addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -- See Note [Record-selector ticks] addTickHsExpr e@(HsVar _ (L _ id)) = freeVar id >> recSelTick id >>= pure . maybe e wrap - where wrap tick = XExpr . HsTick tick . noLocA $ e + where wrap = foldr (\tick -> XExpr . HsTick tick . noLocA) e addTickHsExpr e@(HsIPVar {}) = return e addTickHsExpr e@(HsOverLit {}) = return e addTickHsExpr e@(HsOverLabel{}) = return e @@ -1086,7 +1082,7 @@ data TickTransEnv = TTE { fileName :: FastString , blackList :: Set RealSrcSpan , this_mod :: Module , tickishType :: TickishType - , recSelBinds :: IdEnv Id + , recSelBinds :: IdEnv [Id] } -- deriving Show @@ -1241,11 +1237,12 @@ allocTickBox boxLabel countEntries topOnly pos m tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) return (this_loc (XExpr $ HsTick tickish $ this_loc e)) -recSelTick :: Id -> TM (Maybe CoreTickish) +recSelTick :: Id -> TM (Maybe [CoreTickish]) recSelTick id = ifDensity TickForCoverage maybe_tick (pure Nothing) where maybe_tick = getEnv >>= - maybe (pure Nothing) tick . (`lookupVarEnv` id) . recSelBinds + maybe (pure Nothing) tick_all . (`lookupVarEnv` id) . recSelBinds + tick_all = fmap (Just . catMaybes) . mapM tick tick sel = getState >>= maybe (alloc sel) (pure . Just) . (`lookupVarEnv` sel) . recSelTicks alloc sel = allocATickBox (box sel) False False (getSrcSpan sel) noFVs @@ -1367,7 +1364,7 @@ class CollectBinders a where -- -- See Note [Record-selector ticks]. class CollectFldBinders a where - collectFldBinds :: a -> IdEnv Id + collectFldBinds :: a -> IdEnv [Id] instance CollectBinders (LocatedA (Pat GhcTc)) where collectBinds = collectPatBinders CollNoDictBinders @@ -1385,41 +1382,39 @@ instance (CollectFldBinders a) => CollectFldBinders [a] where instance (CollectFldBinders e) => CollectFldBinders (GenLocated l e) where collectFldBinds = collectFldBinds . unLoc instance CollectFldBinders (Pat GhcTc) where - collectFldBinds ConPat{ pat_args = RecCon HsRecFields{ rec_flds, rec_dotdot } } = - collectFldBinds rec_flds `plusVarEnv` plusVarEnvList (zipWith fld_bnds [0..] rec_flds) - where n_explicit | Just (L _ (RecFieldsDotDot n)) <- rec_dotdot = n - | otherwise = length rec_flds - fld_bnds n (L _ HsFieldBind{ hfbLHS = L _ FieldOcc{ foLabel = L _ sel } - , hfbRHS = L _ (VarPat _ (L _ var)) - , hfbPun }) - | hfbPun || n >= n_explicit = unitVarEnv var sel - fld_bnds _ _ = emptyVarEnv - collectFldBinds ConPat{ pat_args = PrefixCon pats } = collectFldBinds pats - collectFldBinds ConPat{ pat_args = InfixCon p1 p2 } = collectFldBinds [p1, p2] - collectFldBinds (LazyPat _ pat) = collectFldBinds pat - collectFldBinds (BangPat _ pat) = collectFldBinds pat - collectFldBinds (AsPat _ _ pat) = collectFldBinds pat - collectFldBinds (ViewPat _ _ pat) = collectFldBinds pat - collectFldBinds (ParPat _ pat) = collectFldBinds pat - collectFldBinds (ListPat _ pats) = collectFldBinds pats - collectFldBinds (TuplePat _ pats _) = collectFldBinds pats - collectFldBinds (SumPat _ pats _ _) = collectFldBinds pats - collectFldBinds (SigPat _ pat _) = collectFldBinds pat - collectFldBinds (XPat exp) = collectFldBinds exp - collectFldBinds VarPat{} = emptyVarEnv - collectFldBinds WildPat{} = emptyVarEnv - collectFldBinds OrPat{} = emptyVarEnv - collectFldBinds LitPat{} = emptyVarEnv - collectFldBinds NPat{} = emptyVarEnv - collectFldBinds NPlusKPat{} = emptyVarEnv - collectFldBinds SplicePat{} = emptyVarEnv - collectFldBinds EmbTyPat{} = emptyVarEnv - collectFldBinds InvisPat{} = emptyVarEnv + collectFldBinds = go [] where + go path ConPat{ pat_args = RecCon HsRecFields{ rec_flds } } = + plusVarEnvList (map fld_binds rec_flds) + where fld_binds (L _ HsFieldBind{ hfbLHS = L _ FieldOcc{ foLabel = L _ sel } + , hfbRHS = L _ rhs }) + = go (sel:path) rhs + go path ConPat{ pat_args = PrefixCon ps } = + plusVarEnvList (map (go path . unLoc) ps) + go path ConPat{ pat_args = InfixCon (L _ p1) (L _ p2) } = + go path p1 `plusVarEnv` go path p2 + go [] VarPat{} = emptyVarEnv + go path (VarPat _ (L _ var)) = unitVarEnv var path + go path (LazyPat _ (L _ p)) = go path p + go path (BangPat _ (L _ p)) = go path p + go path (AsPat _ _ (L _ p)) = go path p + go path (ViewPat _ _ (L _ p)) = go path p + go path (ParPat _ (L _ p)) = go path p + go path (SigPat _ (L _ p) _) = go path p + go path (SumPat _ (L _ p) _ _) = go path p + go path (XPat (CoPat _ p _)) = go path p + go path (XPat (ExpansionPat _ p)) = go path p + go path (ListPat _ ps) = plusVarEnvList (map (go path . unLoc) ps) + go path (TuplePat _ ps _) = plusVarEnvList (map (go path . unLoc) ps) + go _ WildPat{} = emptyVarEnv + go _ OrPat{} = emptyVarEnv + go _ LitPat{} = emptyVarEnv + go _ NPat{} = emptyVarEnv + go _ NPlusKPat{} = emptyVarEnv + go _ SplicePat{} = emptyVarEnv + go _ EmbTyPat{} = emptyVarEnv + go _ InvisPat{} = emptyVarEnv instance (CollectFldBinders r) => CollectFldBinders (HsFieldBind l r) where collectFldBinds = collectFldBinds . hfbRHS -instance CollectFldBinders XXPatGhcTc where - collectFldBinds (CoPat _ pat _) = collectFldBinds pat - collectFldBinds (ExpansionPat _ pat) = collectFldBinds pat instance CollectFldBinders (HsLocalBinds GhcTc) where collectFldBinds (HsValBinds _ bnds) = collectFldBinds bnds collectFldBinds HsIPBinds{} = emptyVarEnv @@ -1430,9 +1425,9 @@ instance CollectFldBinders (HsValBinds GhcTc) where instance CollectFldBinders (HsBind GhcTc) where collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) = - mkVarEnv [ (abe_poly, sel) + mkVarEnv [ (abe_poly, sels) | ABE{ abe_poly, abe_mono } <- abs_exports - , Just sel <- [lookupVarEnv monos abe_mono] ] + , Just sels <- [lookupVarEnv monos abe_mono] ] where monos = collectFldBinds abs_binds collectFldBinds VarBind{} = emptyVarEnv collectFldBinds FunBind{} = emptyVarEnv ===================================== testsuite/tests/hpc/recsel/recsel.hs ===================================== @@ -10,7 +10,8 @@ import Trace.Hpc.Tix import Trace.Hpc.Reflect data Foo = Foo { fooA, fooB, fooC, fooD, fooE, fooF, fooG, fooH, fooI - , fooJ, fooK, fooL, fooM, fooN, fooO :: Int } + , fooJ, fooK, fooL, fooM, fooN, fooO :: Int + , fooP :: Maybe Int } data Bar = Bar { barFoo :: Foo } fAB Foo{..} = fooA + fooB @@ -35,14 +36,16 @@ fL = runIdentity . runKleisli (proc f -> do fM f | Foo{..} <- f = fooM fN f = fooN f fO = runIdentity . runKleisli (proc Foo{..} -> returnA -< fooO) +fP Foo{fooP = Just x} = x +fP _ = 0 recSel (n, TopLevelBox [s]) | any (`isPrefixOf` s) ["foo", "bar"] = Just (n, s) recSel _ = Nothing main = do - let foo = Foo 42 23 0 1 2 3 4 5 6 7 0xaffe 9 10 11 12 + let foo = Foo 42 23 0 1 2 3 4 5 6 7 0xaffe 9 10 11 12 (Just 13) mapM_ (print . ($ foo)) - [fAB, fC, fD False, fE . Bar, fF, fG, fH, fI, fJ, fK, fL, fM, fN, fO] + [fAB, fC, fD False, fE . Bar, fF, fG, fH, fI, fJ, fK, fL, fM, fN, fO, fP] (Mix _ _ _ _ mixs) <- readMix [".hpc"] (Left "Main") let sels = mapMaybe recSel . zip [0..] $ map snd mixs (Tix [TixModule "Main" _ _ tix]) <- examineTix ===================================== testsuite/tests/hpc/recsel/recsel.stdout ===================================== @@ -12,13 +12,14 @@ 10 11 12 -(0,"barFoo") +13 +(1,"barFoo") (1,"fooA") (1,"fooB") (1,"fooC") (0,"fooD") (1,"fooE") -(0,"fooF") +(1,"fooF") (1,"fooG") (1,"fooH") (1,"fooI") @@ -28,3 +29,4 @@ (1,"fooM") (1,"fooN") (1,"fooO") +(1,"fooP") View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d07db70451b7477c69f7a32919f2783d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d07db70451b7477c69f7a32919f2783d... You're receiving this email because of your account on gitlab.haskell.org.