Ben Gamari pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC Commits: 43b606bb by Florian Ragwitz at 2025-06-27T16:31:26-04:00 Tick uses of wildcard/pun field binds as if using the record selector function Fixes #17834. See Note [Record-selector ticks] for additional reasoning behind this as well as an overview of the implementation details and future improvements. - - - - - d4952549 by Ben Gamari at 2025-06-27T16:32:08-04:00 testsuite/caller-cc: Make CallerCc[123] less sensitive These were previously sensitive to irrelevant changes in program structure. To avoid this we filter out all by lines emitted by the -fcaller-cc from the profile. - - - - - b6c2d9d8 by Ben Gamari at 2025-06-30T16:14:55-04:00 Bump win32-tarballs to v0.9 - - - - - 4f63e211 by GHC GitLab CI at 2025-06-30T16:14:55-04:00 rts/LoadArchive: Handle null terminated string tables - - - - - 7cc78d40 by Tamar Christina at 2025-06-30T16:14:55-04:00 rts: rename label so name doesn't conflict with param - - - - - 0cf490fe by Tamar Christina at 2025-06-30T16:14:55-04:00 rts: Handle API set symbol versioning conflicts - - - - - e16baf62 by Tamar Christina at 2025-06-30T16:15:44-04:00 rts: Mark API set symbols as HIDDEN and correct symbol type - - - - - 10 changed files: - compiler/GHC/HsToCore/Ticks.hs - docs/users_guide/9.14.1-notes.rst - mk/get-win32-tarballs.py - rts/linker/LoadArchive.c - rts/linker/PEi386.c - + testsuite/tests/hpc/recsel/Makefile - + testsuite/tests/hpc/recsel/recsel.hs - + testsuite/tests/hpc/recsel/recsel.stdout - + testsuite/tests/hpc/recsel/test.T - testsuite/tests/profiling/should_run/caller-cc/all.T Changes: ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -1,12 +1,11 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) Galois, 2006 (c) University of Glasgow, 2007 +(c) Florian Ragwitz, 2025 -} module GHC.HsToCore.Ticks @@ -38,7 +37,9 @@ import GHC.Utils.Logger import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Types.Name.Set hiding (FreeVars) import GHC.Types.Name import GHC.Types.CostCentre @@ -48,6 +49,7 @@ import GHC.Types.ProfAuto import Control.Monad import Data.List (isSuffixOf, intersperse) +import Data.Foldable (toList) import Trace.Hpc.Mix @@ -123,6 +125,7 @@ addTicksToBinds logger cfg , density = mkDensity tickish $ ticks_profAuto cfg , this_mod = mod , tickishType = tickish + , recSelBinds = emptyVarEnv } (binds',_,st') = unTM (addTickLHsBinds binds) env st in (binds', st') @@ -224,8 +227,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds , abs_exports = abs_exports }))) = - withEnv add_exports $ - withEnv add_inlines $ do + withEnv (add_rec_sels . add_inlines . add_exports) $ do binds' <- addTickLHsBinds binds return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } where @@ -247,6 +249,12 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , isInlinePragma (idInlinePragma pid) ] } + add_rec_sels env = + env{ recSelBinds = recSelBinds env `extendVarEnvList` + [ (abe_mono, abe_poly) + | ABE{ abe_poly, abe_mono } <- abs_exports + , RecSelId{} <- [idDetails abe_poly] ] } + addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do let name = getOccString id decl_path <- getPathEntry @@ -261,6 +269,10 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches tickish <- tickishType `liftM` getEnv 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 + (fvs, mg) <- getFreeVars $ addPathEntry name $ @@ -288,7 +300,40 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches let mbCons = maybe Prelude.id (:) return $ L pos $ funBind { fun_matches = mg , fun_ext = second (tick `mbCons`) (fun_ext funBind) } - } + } } + where + -- See Note [Record-selector ticks] + tick_rec_sel tick = + pure $ L pos $ funBind { fun_ext = second (tick :) (fun_ext funBind) } + + +-- Note [Record-selector ticks] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Users expect (see #17834) that accessing a record field by its name using +-- NamedFieldPuns or RecordWildCards will mark it as covered. This is very +-- reasonable, because otherwise the use of those two language features will +-- produce unnecessary noise in coverage reports, distracting from real +-- coverage problems. +-- +-- Because of that, GHC chooses to treat record selectors specially for +-- 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. +-- +-- To enable that, we also treat 'FunBind's for record selector functions +-- specially. We only create a TopLevelBox for the record selector function, +-- skipping the ExpBox that'd normally be created. This simplifies the re-use +-- of ticks for the same record selector, and is done by not recursing into +-- 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. -- TODO: Revisit this addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs @@ -471,7 +516,10 @@ addBinTickLHsExpr boxLabel e@(L pos e0) -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e +-- 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 addTickHsExpr e@(HsIPVar {}) = return e addTickHsExpr e@(HsOverLit {}) = return e addTickHsExpr e@(HsOverLabel{}) = return e @@ -532,7 +580,7 @@ addTickHsExpr (HsMultiIf ty alts) ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts ; return $ HsMultiIf ty alts' } addTickHsExpr (HsLet x binds e) = - bindLocals (collectLocalBinders CollNoDictBinders binds) $ do + bindLocals binds $ do binds' <- addTickHsLocalBinds binds -- to think about: !patterns. e' <- addTickLHsExprLetBody e return (HsLet x binds' e') @@ -580,6 +628,7 @@ addTickHsExpr e@(HsUntypedSplice{}) = return e addTickHsExpr e@(HsGetField {}) = return e addTickHsExpr e@(HsProjection {}) = return e addTickHsExpr (HsProc x pat cmdtop) = + bindLocals pat $ liftM2 (HsProc x) (addTickLPat pat) (traverse (addTickHsCmdTop) cmdtop) @@ -646,19 +695,17 @@ addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (L -> TM (Match GhcTc (LHsExpr GhcTc)) addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats , m_grhss = gRHSs }) = - bindLocals (collectPatsBinders CollNoDictBinders pats) $ do + bindLocals pats $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs return $ match { m_grhss = gRHSs' } addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) = - bindLocals binders $ do + bindLocals local_binds $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded return $ GRHSs x guarded' local_binds' - where - binders = collectLocalBinders CollNoDictBinders local_binds addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) @@ -697,7 +744,7 @@ addTickLStmts isGuard stmts = do addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $ + = bindLocals lstmts $ do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } @@ -710,6 +757,7 @@ addTickStmt _isGuard (LastStmt x e noret ret) = (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) addTickStmt _isGuard (BindStmt xbs pat e) = + bindLocals pat $ liftM4 (\b f -> BindStmt $ XBindStmtTc { xbstc_bindOp = b , xbstc_boundResultType = xbstc_boundResultType xbs @@ -770,17 +818,19 @@ addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where addTickArg (ApplicativeArgOne m_fail pat expr isBody) = - ApplicativeArgOne - <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail - <*> addTickLPat pat - <*> addTickLHsExpr expr - <*> pure isBody + bindLocals pat $ + ApplicativeArgOne + <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail + <*> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = - (ApplicativeArgMany x) - <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) - <*> addTickLPat pat - <*> pure ctxt + bindLocals pat $ + ApplicativeArgMany x + <$> addTickLStmts isGuard stmts + <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) + <*> addTickLPat pat + <*> pure ctxt addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) @@ -871,7 +921,7 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addTickLHsCmd c2) (addTickLHsCmd c3) addTickHsCmd (HsCmdLet x binds c) = - bindLocals (collectLocalBinders CollNoDictBinders binds) $ do + bindLocals binds $ do binds' <- addTickHsLocalBinds binds -- to think about: !patterns. c' <- addTickLHsCmd c return (HsCmdLet x binds' c') @@ -907,18 +957,16 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) = - bindLocals (collectPatsBinders CollNoDictBinders pats) $ do + bindLocals pats $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' } addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs x guarded local_binds) = - bindLocals binders $ do + bindLocals local_binds $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (traverse addTickCmdGRHS) guarded return $ GRHSs x guarded' local_binds' - where - binders = collectLocalBinders CollNoDictBinders local_binds addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is @@ -937,15 +985,14 @@ addTickLCmdStmts stmts = do addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) addTickLCmdStmts' lstmts res - = bindLocals binders $ do + = bindLocals lstmts $ do lstmts' <- mapM (traverse addTickCmdStmt) lstmts a <- res return (lstmts', a) - where - binders = collectLStmtsBinders CollNoDictBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) addTickCmdStmt (BindStmt x pat c) = + bindLocals pat $ liftM2 (BindStmt x) (addTickLPat pat) (addTickLHsCmd c) @@ -1006,11 +1053,13 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) = data TickTransState = TT { ticks :: !(SizedSeq Tick) , ccIndices :: !CostCentreState + , recSelTicks :: !(IdEnv CoreTickish) } initTTState :: TickTransState initTTState = TT { ticks = emptySS , ccIndices = newCostCentreState + , recSelTicks = emptyVarEnv } addMixEntry :: Tick -> TM Int @@ -1021,6 +1070,10 @@ addMixEntry ent = do } return c +addRecSelTick :: Id -> CoreTickish -> TM () +addRecSelTick sel tick = + setState $ \s -> s{ recSelTicks = extendVarEnv (recSelTicks s) sel tick } + data TickTransEnv = TTE { fileName :: FastString , density :: TickDensity , tte_countEntries :: !Bool @@ -1033,6 +1086,7 @@ data TickTransEnv = TTE { fileName :: FastString , blackList :: Set RealSrcSpan , this_mod :: Module , tickishType :: TickishType + , recSelBinds :: IdEnv Id } -- deriving Show @@ -1154,12 +1208,13 @@ ifGoodTickSrcSpan pos then_code else_code = do good <- isGoodTickSrcSpan pos if good then then_code else else_code -bindLocals :: [Id] -> TM a -> TM a -bindLocals new_ids (TM m) - = TM $ \ env st -> - case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') - where occs = [ nameOccName (idName id) | id <- new_ids ] +bindLocals :: (CollectBinders bndr, CollectFldBinders bndr) => bndr -> TM a -> TM a +bindLocals from (TM m) = TM $ \env st -> + case m (with_bnds env) st of + (r, fv, st') -> (r, fv `delListFromOccEnv` (map (nameOccName . idName) new_bnds), st') + where with_bnds e = e{ inScope = inScope e `extendVarSetList` new_bnds + , recSelBinds = recSelBinds e `plusVarEnv` collectFldBinds from } + new_bnds = collectBinds from withBlackListed :: SrcSpan -> TM a -> TM a withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) }) @@ -1186,6 +1241,17 @@ 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 = ifDensity TickForCoverage maybe_tick (pure Nothing) + where + maybe_tick = getEnv >>= + maybe (pure Nothing) tick . (`lookupVarEnv` id) . recSelBinds + tick sel = getState >>= + maybe (alloc sel) (pure . Just) . (`lookupVarEnv` sel) . recSelTicks + alloc sel = allocATickBox (box sel) False False (getSrcSpan sel) noFVs + >>= traverse (\t -> t <$ addRecSelTick sel t) + box sel = TopLevelBox [getOccString sel] + -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars @@ -1288,3 +1354,98 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 matchCount :: LMatch GhcTc body -> Int matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss + +-- | Convenience class used by 'bindLocals' to collect new bindings from +-- various parts of he AST. Just delegates to +-- 'collect{Pat,Pats,Local,LStmts}Binders' from 'GHC.Hs.Utils' as appropriate. +class CollectBinders a where + collectBinds :: a -> [Id] + +-- | Variant of 'CollectBinders' which collects information on which locals +-- are bound to record fields (currently only via 'RecordWildCards' or +-- 'NamedFieldPuns') to enable better coverage support for record selectors. +-- +-- See Note [Record-selector ticks]. +class CollectFldBinders a where + collectFldBinds :: a -> IdEnv Id + +instance CollectBinders (LocatedA (Pat GhcTc)) where + collectBinds = collectPatBinders CollNoDictBinders +instance CollectBinders [LocatedA (Pat GhcTc)] where + collectBinds = collectPatsBinders CollNoDictBinders +instance CollectBinders (HsLocalBinds GhcTc) where + collectBinds = collectLocalBinders CollNoDictBinders +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsExpr GhcTc)))] where + collectBinds = collectLStmtsBinders CollNoDictBinders +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsCmd GhcTc)))] where + collectBinds = collectLStmtsBinders CollNoDictBinders + +instance (CollectFldBinders a) => CollectFldBinders [a] where + collectFldBinds = foldr (flip plusVarEnv . collectFldBinds) emptyVarEnv +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 +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 + collectFldBinds EmptyLocalBinds{} = emptyVarEnv +instance CollectFldBinders (HsValBinds GhcTc) where + collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds + collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds) +instance CollectFldBinders (HsBind GhcTc) where + collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs + collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) = + mkVarEnv [ (abe_poly, sel) + | ABE{ abe_poly, abe_mono } <- abs_exports + , Just sel <- [lookupVarEnv monos abe_mono] ] + where monos = collectFldBinds abs_binds + collectFldBinds VarBind{} = emptyVarEnv + collectFldBinds FunBind{} = emptyVarEnv + collectFldBinds PatSynBind{} = emptyVarEnv +instance CollectFldBinders (Stmt GhcTc e) where + collectFldBinds (BindStmt _ pat _) = collectFldBinds pat + collectFldBinds (LetStmt _ bnds) = collectFldBinds bnds + collectFldBinds (ParStmt _ xs _ _) = collectFldBinds [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss] + collectFldBinds TransStmt{ trS_stmts } = collectFldBinds trS_stmts + collectFldBinds RecStmt{ recS_stmts } = collectFldBinds recS_stmts + collectFldBinds (XStmtLR (ApplicativeStmt _ args _)) = collectFldBinds (map snd args) + collectFldBinds LastStmt{} = emptyVarEnv + collectFldBinds BodyStmt{} = emptyVarEnv +instance CollectFldBinders (ApplicativeArg GhcTc) where + collectFldBinds ApplicativeArgOne{ app_arg_pattern } = collectFldBinds app_arg_pattern + collectFldBinds ApplicativeArgMany{ bv_pattern } = collectFldBinds bv_pattern ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -138,6 +138,11 @@ Compiler uses of the now deprecated ``pattern`` namespace specifier in import/export lists. See `GHC Proposal #581, section 2.3 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0581-na...`_. +- Code coverage (:ghc-flag:`-fhpc`) now treats uses of record fields via + :extension:`RecordWildCards` or :extension:`NamedFieldPuns` as if the fields + were accessed using the generated record selector functions, marking the fields + as covered in coverage reports (:ghc-ticket:`17834`). + GHCi ~~~~ ===================================== mk/get-win32-tarballs.py ===================================== @@ -8,7 +8,7 @@ import argparse import sys from sys import stderr -TARBALL_VERSION = '0.8' +TARBALL_VERSION = '0.9' BASE_URL = "https://downloads.haskell.org/ghc/mingw/{}".format(TARBALL_VERSION) DEST = Path('ghc-tarballs/mingw-w64') ARCHS = ['x86_64', 'sources'] ===================================== rts/linker/LoadArchive.c ===================================== @@ -223,21 +223,22 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, char* gnuFileIndex, pathchar* path, size_t* thisFileNameSize, size_t* fileNameSize) { - int n; char *fileName = *fileName_; if (isdigit(fileName[1])) { - int i; - for (n = 2; isdigit(fileName[n]); n++) - ; - - fileName[n] = '\0'; - n = atoi(fileName + 1); if (gnuFileIndex == NULL) { errorBelch("loadArchive: GNU-variant filename " "without an index while reading from `%" PATH_FMT "'", path); return false; } + + int n; + for (n = 2; isdigit(fileName[n]); n++) + ; + + char *end; + fileName[n] = '\0'; + n = strtol(fileName + 1, &end, 10); if (n < 0 || n > gnuFileIndexSize) { errorBelch("loadArchive: GNU-variant filename " "offset %d out of range [0..%d] " @@ -245,17 +246,27 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, n, gnuFileIndexSize, path); return false; } - if (n != 0 && gnuFileIndex[n - 1] != '\n') { + + // Check that the previous entry ends with the expected + // end-of-string delimiter. +#if defined(mingw32_HOST_OS) +#define IS_SYMBOL_DELIMITER(STR) (STR =='\n' || STR == '\0') +#else +#define IS_SYMBOL_DELIMITER(STR) (STR =='\n') +#endif + if (n != 0 && !IS_SYMBOL_DELIMITER(gnuFileIndex[n - 1])) { errorBelch("loadArchive: GNU-variant filename offset " "%d invalid (range [0..%d]) while reading " "filename from `%" PATH_FMT "'", n, gnuFileIndexSize, path); return false; } - for (i = n; gnuFileIndex[i] != '\n'; i++) + + int i; + for (i = n; !IS_SYMBOL_DELIMITER(gnuFileIndex[i]); i++) ; - size_t FileNameSize = i - n - 1; + size_t FileNameSize = i - n; if (FileNameSize >= *fileNameSize) { /* Double it to avoid potentially continually increasing it by 1 */ ===================================== rts/linker/PEi386.c ===================================== @@ -342,6 +342,98 @@ Finally, we enter `ocResolve`, where we resolve relocations and and allocate jump islands (using the m32 allocator for backing storage) as necessary. + Note [Windows API Set] + ~~~~~~~~~~~~~~~~~~~~~~ + Windows has a concept called API Sets [1][2] which is intended to be Windows's + equivalent to glibc's symbolic versioning. It is also used to handle the API + surface difference between different device classes. e.g. the API might be + handled differently between a desktop and tablet. + + This is handled through two mechanisms: + + 1. Direct Forward: These use import libraries to manage to first level + redirection. So what used to be in ucrt.dll is now redirected based on + ucrt.lib. Every API now points to a possible different set of API sets + each following the API set contract: + + * The name must begin either with the string api- or ext-. + * Names that begin with api- represent APIs that exist on all Windows + editions that satisfy the API's version requirements. + * Names that begin with ext- represent APIs that may not exist on all + Windows editions. + * The name must end with the sequence l<n>-<n>-<n>, where n consists of + decimal digits. + * The body of the name can be alphanumeric characters, or dashes (-). + * The name is case insensitive. + + Here are some examples of API set contract names: + + - api-ms-win-core-ums-l1-1-0 + - ext-ms-win-com-ole32-l1-1-5 + - ext-ms-win-ntuser-window-l1-1-0 + - ext-ms-win-ntuser-window-l1-1-1 + + Forward references don't require anything special from the calling + application in that the Windows loader through "LoadLibrary" will + automatically load the right reference for you if given an API set + name including the ".dll" suffix. For example: + + INFO: DLL api-ms-win-eventing-provider-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-apiquery-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\ntdll.dll by API set + INFO: DLL api-ms-win-core-processthreads-l1-1-3.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-processthreads-l1-1-2.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-processthreads-l1-1-1.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-processthreads-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-registry-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-heap-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-heap-l2-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-memory-l1-1-1.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-memory-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-memory-l1-1-2.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-handle-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + + Which shows how the loader has redirected some of the references used + by ghci. + + Historically though we've treated shared libs lazily. We would load\ + the shared library, but not resolve the symbol immediately and wait until + the symbol is requested to iterate in order through the shared libraries. + + This assumes that you ever only had one version of a symbol. i.e. we had + an assumption that all exported symbols in different shared libraries + should be the same, because most of the time they come from re-exporting + from a base library. This is a bit of a weak assumption and doesn't hold + with API Sets. + + For that reason the loader now resolves symbols immediately, and because + we now resolve using BIND_NOW we must make sure that a symbol loaded + through an OC has precedent because the BIND_NOW refernce was not asked + for. For that reason we load the symbols for API sets with the + SYM_TYPE_DUP_DISCARD flag set. + + 2. Reverse forwarders: This is when the application has a direct reference + to the old name of an API. e.g. if GHC still used "msvcrt.dll" or + "ucrt.dll" we would have had to deal with this case. In this case the + loader intercepts the call and if it exists the dll is loaded. There is + an extra indirection as you go from foo.dll => api-ms-foo-1.dll => foo_imp.dll + + But if the API doesn't exist on the device it's resolved to a stub in the + API set that if called will result in an error should it be called [3]. + + This means that usages of GetProcAddress and LoadLibrary to check for the + existance of a function aren't safe, because they'll always succeed, but may + result in a pointer to the stub rather than the actual function. + + WHat does this mean for the RTS linker? Nothing. We don't have a fallback + for if the function doesn't exist. The RTS is merely just executing what + it was told to run. It's writers of libraries that have to be careful when + doing dlopen()/LoadLibrary. + + + [1] https://learn.microsoft.com/en-us/windows/win32/apiindex/windows-apisets + [2] https://mingwpy.github.io/ucrt.html#api-set-implementation + [3] https://learn.microsoft.com/en-us/windows/win32/apiindex/detect-api-set-avai... + */ #include "Rts.h" @@ -882,7 +974,7 @@ addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded ) goto error; } } else { - goto loaded; /* We're done. DLL has been loaded. */ + goto loaded_ok; /* We're done. DLL has been loaded. */ } } } @@ -890,7 +982,7 @@ addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded ) // We failed to load goto error; -loaded: +loaded_ok: addLoadedDll(&loaded_dll_cache, dll_name, instance); addDLLHandle(buf, instance); if (loaded) { @@ -1055,7 +1147,8 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f // We must call `addDLL_PEi386` directly rather than `addDLL` because `addDLL` // is now a wrapper around `loadNativeObj` which acquires a lock which we // already have here. - const char* result = addDLL_PEi386(dll, NULL); + HINSTANCE instance; + const char* result = addDLL_PEi386(dll, &instance); stgFree(image); @@ -1069,6 +1162,24 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f } stgFree(dll); + + // See Note [Windows API Set] + // We must immediately tie the symbol to the shared library. The easiest + // way is to load the symbol immediately. We already have all the + // information so might as well + SymbolAddr* sym = lookupSymbolInDLL_PEi386 (symbol, instance, dll, NULL); + ASSERT(sym); + // The symbol must have been found, and we can add it to the RTS symbol table + IF_DEBUG(linker, debugBelch("checkAndLoadImportLibrary: resolved symbol %s to %p\n", symbol, sym)); + // Because the symbol has been loaded before we actually need it, if a + // stronger reference wants to add a duplicate we should discard this + // one to preserve link order. + SymType symType = SYM_TYPE_DUP_DISCARD | SYM_TYPE_HIDDEN; + symType |= hdr.Type == IMPORT_OBJECT_CODE ? SYM_TYPE_CODE : SYM_TYPE_DATA; + + if (!ghciInsertSymbolTable(dll, symhash, symbol, sym, false, symType, NULL)) + return false; + return true; } ===================================== testsuite/tests/hpc/recsel/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/hpc/recsel/recsel.hs ===================================== @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns, Arrows #-} + +import Control.Monad.Identity +import Control.Arrow (runKleisli, arr, returnA) +import Data.Maybe +import Data.List +import Data.Bifunctor +import Trace.Hpc.Mix +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 } +data Bar = Bar { barFoo :: Foo } + +fAB Foo{..} = fooA + fooB +fC Foo{fooC} = fooC +fD x Foo{..} = fromMaybe 0 $ if x then Just fooD else Nothing +fE Bar{barFoo = Foo{..}} = fooE +fF Foo{fooF = f} = f +fG f = let Foo{..} = f in fooG +fH f = runIdentity $ do + Foo{..} <- pure f + return fooH +fI f = runIdentity $ do + let Foo{..} = f + return fooI +fJ f = [ fooJ | let Foo{..} = f ] !! 0 +fK = runIdentity . runKleisli (proc f -> do + Foo{..} <- arr id -< f + returnA -< fooK) +fL = runIdentity . runKleisli (proc f -> do + let Foo{..} = f; + returnA -< fooL) +fM f | Foo{..} <- f = fooM +fN f = fooN f +fO = runIdentity . runKleisli (proc Foo{..} -> returnA -< fooO) + +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 + mapM_ (print . ($ foo)) + [fAB, fC, fD False, fE . Bar, fF, fG, fH, fI, fJ, fK, fL, fM, fN, fO] + (Mix _ _ _ _ mixs) <- readMix [".hpc"] (Left "Main") + let sels = mapMaybe recSel . zip [0..] $ map snd mixs + (Tix [TixModule "Main" _ _ tix]) <- examineTix + mapM_ print . sortOn snd $ map (first (tix !!)) sels ===================================== testsuite/tests/hpc/recsel/recsel.stdout ===================================== @@ -0,0 +1,30 @@ +65 +0 +0 +2 +3 +4 +5 +6 +7 +45054 +9 +10 +11 +12 +(0,"barFoo") +(1,"fooA") +(1,"fooB") +(1,"fooC") +(0,"fooD") +(1,"fooE") +(0,"fooF") +(1,"fooG") +(1,"fooH") +(1,"fooI") +(1,"fooJ") +(1,"fooK") +(1,"fooL") +(1,"fooM") +(1,"fooN") +(1,"fooO") ===================================== testsuite/tests/hpc/recsel/test.T ===================================== @@ -0,0 +1,7 @@ +setTestOpts([omit_ghci, when(fast(), skip), js_skip]) + +test('recsel', + [ignore_extension, + when(arch('wasm32'), fragile(23243))], + compile_and_run, ['-fhpc']) + ===================================== testsuite/tests/profiling/should_run/caller-cc/all.T ===================================== @@ -8,6 +8,7 @@ setTestOpts(only_ways(prof_ways)) setTestOpts(extra_files(['Main.hs'])) setTestOpts(extra_run_opts('7')) setTestOpts(grep_prof("Main.hs")) +setTestOpts(grep_prof("calling:")) # N.B. Main.hs is stolen from heapprof001. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac1780b62a270952a983128f385f88f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac1780b62a270952a983128f385f88f... You're receiving this email because of your account on gitlab.haskell.org.