GitLab

Matthew Pickering pushed to branch wip/stable-ipe-info 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.

9b299678

by Matthew Pickering at 2025-07-03T11:36:32+01:00

ipe: Place strings and metadata into specific .ipe section

By placing the .ipe metadata into a specific section it can be stripped
from the final binary if desired.

```
objcopy --remove-section .ipe <binary>
upx <binary>
```

Towards #21766

fec3fd0a

by Matthew Pickering at 2025-07-03T11:36:32+01:00

ipe: Place magic word at the start of entries in the .ipe section

The magic word "IPE\nIPE\n" is placed at the start of .ipe sections,
then if the section is stripped, we can check whether the section starts
with the magic word or not to determine whether there is metadata
present or not.

Towards #21766

eefb8f46

by Matthew Pickering at 2025-07-03T14:55:35+01:00

ipe: Use stable IDs for IPE entries

IPEs have historically been indexed and reported by their address.
This makes it impossible to compare profiles between runs, since the
addresses may change (due to ASLR) and also makes it tricky to separate
out the IPE map from the binary.

This small patch adds a stable identifier for each IPE entry.

The stable identifier is a single 64 bit word. The high-bits are a
per-module identifier and the low bits identify which entry in each
module.

1. When a node is added into the IPE buffer it is assigned a unique
   identifier from an incrementing global counter.
2. Each entry already has an index by it's position in the
   `IpeBufferListNode`.

The two are combined together by the `IPE_ENTRY_KEY` macro.

Info table profiling uses the stable identifier rather than the address
of the info table.

The benefits of this change are:

* Profiles from different runs can be easily compared
* The metadata can be extracted from the binary (via the eventlog for
  example) and then stripped from the executable.

Fixes #21766

18 changed files:

compiler/GHC/Cmm.hs
compiler/GHC/CmmToAsm/PPC/Ppr.hs
compiler/GHC/CmmToAsm/Ppr.hs
compiler/GHC/CmmToLlvm/Data.hs
compiler/GHC/HsToCore/Ticks.hs
compiler/GHC/StgToCmm/InfoTableProv.hs
docs/users_guide/9.14.1-notes.rst
rts/IPE.c
rts/ProfHeap.c
rts/eventlog/EventLog.c
rts/include/rts/IPE.h
+ 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
testsuite/tests/rts/ipe/ipeMap.c
testsuite/tests/rts/ipe/ipe_lib.c

Changes:

compiler/GHC/Cmm.hs

@@ -278,6 +278,7 @@ data SectionType
    | InitArray           -- .init_array on ELF, .ctor on Windows
    | FiniArray           -- .fini_array on ELF, .dtor on Windows
    | CString
 +  | IPE
    | OtherSection String
    deriving (Show)
@@ -298,6 +299,7 @@ sectionProtection (Section t _) = case t of
      CString                 -> ReadOnlySection
      Data                    -> ReadWriteSection
      UninitialisedData       -> ReadWriteSection
 +    IPE                     -> ReadWriteSection
      (OtherSection _)        -> ReadWriteSection
  {-
@@ -557,4 +559,5 @@ pprSectionType s = doubleQuotes $ case s of
    InitArray               -> text "initarray"
    FiniArray               -> text "finiarray"
    CString                 -> text "cstring"
 +  IPE                     -> text "ipe"
    OtherSection s'         -> text s'

compiler/GHC/CmmToAsm/PPC/Ppr.hs

@@ -285,6 +285,9 @@ pprAlignForSection platform seg = line $
         Data
          | ppc64          -> text ".align 3"
          | otherwise      -> text ".align 2"
 +       IPE
 +        | ppc64          -> text ".align 3"
 +        | otherwise      -> text ".align 2"
         ReadOnlyData
          | ppc64          -> text ".align 3"
          | otherwise      -> text ".align 2"

compiler/GHC/CmmToAsm/Ppr.hs

@@ -236,6 +236,10 @@ pprGNUSectionHeader config t suffix =
          | OSMinGW32 <- platformOS platform
                      -> text ".rdata"
          | otherwise -> text ".rodata.str"
 +      IPE
 +        | OSMinGW32 <- platformOS platform
 +                    -> text ".rdata"
 +        | otherwise -> text ".ipe"
        OtherSection _ ->
          panic "PprBase.pprGNUSectionHeader: unknown section type"
      flags = case t of
@@ -248,6 +252,10 @@ pprGNUSectionHeader config t suffix =
          | OSMinGW32 <- platformOS platform
                      -> empty
          | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1"
 +      IPE
 +        | OSMinGW32 <- platformOS platform
 +                    -> empty
 +        | otherwise -> text ",\"a\"," <> sectionType platform "progbits"
        _ -> empty
  {-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-}
  {-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
@@ -262,6 +270,7 @@ pprXcoffSectionHeader t = case t of
    RelocatableReadOnlyData -> text ".csect .text[PR] # RelocatableReadOnlyData"
    CString                 -> text ".csect .text[PR] # CString"
    UninitialisedData       -> text ".csect .data[BS]"
 +  IPE                     -> text ".csect .text[PR] #IPE"
    _                       -> panic "pprXcoffSectionHeader: unknown section type"
  {-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> SDoc #-}
  {-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
@@ -276,6 +285,7 @@ pprDarwinSectionHeader t = case t of
    InitArray               -> text ".section\t__DATA,__mod_init_func,mod_init_funcs"
    FiniArray               -> panic "pprDarwinSectionHeader: fini not supported"
    CString                 -> text ".section\t__TEXT,__cstring,cstring_literals"
 +  IPE                     -> text ".const"
    OtherSection _          -> panic "pprDarwinSectionHeader: unknown section type"
  {-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-}
  {-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable

compiler/GHC/CmmToLlvm/Data.hs

@@ -145,7 +145,7 @@ llvmSectionType p t = case t of
      CString                 -> case platformOS p of
                                   OSMinGW32 -> fsLit ".rdata$str"
                                   _         -> fsLit ".rodata.str"
+-
 +    IPE                     -> fsLit ".ipe"
      InitArray               -> panic "llvmSectionType: InitArray"
      FiniArray               -> panic "llvmSectionType: FiniArray"
      OtherSection _          -> panic "llvmSectionType: unknown section type"

compiler/GHC/HsToCore/Ticks.hs

 -{-# 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

compiler/GHC/StgToCmm/InfoTableProv.hs

@@ -66,6 +66,28 @@ construction, the 'compressed' field of each IPE buffer list node is examined.
  If the field indicates that the data has been compressed, the entry data and
  strings table are decompressed before continuing with the normal IPE map
  construction.
++
 +Note [IPE Stripping and magic words]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
++
 +For systems which support ELF executables:
++
 +The metadata part of IPE info is placed into a separate ELF section (.ipe).
 +This can then be stripped afterwards if you don't require the metadata
++
 +```
 +-- Remove the section
 +objcopy --remove-section .ipe <your-exe>
 +-- Repack and compress the executable
 +upx <your-exe>
 +```
++
 +The .ipe section starts with a magic 64-bit word "IPE\nIPE\n`, encoded as ascii.
++
 +The RTS checks to see if the .ipe section starts with the magic word. If the
 +section has been stripped then it won't start with the magic word and the
 +metadata won't be accessible for the info tables.
++
  -}
  emitIpeBufferListNode ::
@@ -124,11 +146,21 @@ emitIpeBufferListNode this_mod ents dus0 = do
          ipe_buffer_lbl :: CLabel
          ipe_buffer_lbl = mkIPELabel this_mod
 +        -- A magic word we can use to see if the IPE information has been stripped
 +        -- or not
 +        -- See Note [IPE Stripping and magic words]
 +        -- "IPE\nIPE\n", null terminated.
 +        ipe_header :: CmmStatic
 +        ipe_header = CmmStaticLit (CmmInt 0x4950450049504500 W64)
++
          ipe_buffer_node :: [CmmStatic]
          ipe_buffer_node = map CmmStaticLit
            [ -- 'next' field
              zeroCLit platform
 +            -- 'node_id' field
 +          , zeroCLit platform
++
              -- 'compressed' field
            , int do_compress
@@ -164,13 +196,13 @@ emitIpeBufferListNode this_mod ents dus0 = do
      -- Emit the strings table
      emitDecl $ CmmData
 -      (Section Data strings_lbl)
 -      (CmmStaticsRaw strings_lbl strings)
 +      (Section IPE strings_lbl)
 +      (CmmStaticsRaw strings_lbl (ipe_header : strings))
      -- Emit the list of IPE buffer entries
      emitDecl $ CmmData
 -      (Section Data entries_lbl)
 -      (CmmStaticsRaw entries_lbl entries)
 +      (Section IPE entries_lbl)
 +      (CmmStaticsRaw entries_lbl (ipe_header : entries))
      -- Emit the IPE buffer list node
      emitDecl $ CmmData

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-namespace-specified-imports.rst#deprecate-use-of-pattern-in-import-export-lists>`_.
 +- 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
  ~~~~

rts/IPE.c

@@ -62,6 +62,22 @@ entry's containing IpeBufferListNode and its index in that node.
  When the user looks up an IPE entry, we convert it to the user-facing
  InfoProvEnt representation.
 +Note [Stable identifiers for IPE entries]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
++
 +Each IPE entry is given a stable identifier which remains the same across
 +different runs of the executable (unlike the address of the info table).
++
 +The identifier is a 64-bit word which consists of two parts.
++
 +* The high 32-bits are a per-node identifier.
 +* The low 32-bits are the index of the entry in the node.
++
 +When a node is queued in the pending list by `registerInfoProvList` it is
 +given a unique identifier from an incrementing global variable.
++
 +The unique key can be computed by using the `IPE_ENTRY_KEY` macro.
++
  */
  typedef struct {
@@ -69,6 +85,13 @@ typedef struct {
      uint32_t idx;
  } IpeMapEntry;
 +// See Note [Stable identifiers for IPE entries]
 +#define IPE_ENTRY_KEY(entry) \
 +    MAKE_IPE_KEY((entry).node->node_id, (entry).idx)
++
 +#define MAKE_IPE_KEY(module_id, idx) \
 +    ((((uint64_t)(module_id)) << 32) | ((uint64_t)(idx)))
++
  #if defined(THREADED_RTS)
  static Mutex ipeMapLock;
  #endif
@@ -78,9 +101,22 @@ static HashTable *ipeMap = NULL;
  // Accessed atomically
  static IpeBufferListNode *ipeBufferList = NULL;
 +// A global counter which is used to give an IPE entry a unique value across runs.
 +static StgWord next_module_id = 1; // Start at 1 to reserve 0 as "invalid"
++
  static void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode*);
  static void updateIpeMap(void);
 +// Check whether the IpeBufferListNode has the relevant magic words.
 +// See Note [IPE Stripping and magic words]
 +static inline bool ipe_node_valid(const IpeBufferListNode *node) {
 +    return node &&
 +           node->entries_block &&
 +           node->string_table_block &&
 +           node->entries_block->magic == IPE_MAGIC_WORD &&
 +           node->string_table_block->magic == IPE_MAGIC_WORD;
 +}
++
  #if defined(THREADED_RTS)
  void initIpe(void) { initMutex(&ipeMapLock); }
@@ -99,11 +135,12 @@ static InfoProvEnt ipeBufferEntryToIpe(const IpeBufferListNode *node, uint32_t i
+ {
      CHECK(idx < node->count);
      CHECK(!node->compressed);
 -    const char *strings = node->string_table;
 -    const IpeBufferEntry *ent = &node->entries[idx];
 +    const char *strings = node->string_table_block->string_table;
 +    const IpeBufferEntry *ent = &node->entries_block->entries[idx];
      return (InfoProvEnt) {
              .info = node->tables[idx],
              .prov = {
 +                .info_prov_id  = MAKE_IPE_KEY(node->node_id, idx),
                  .table_name = &strings[ent->table_name],
                  .closure_desc = ent->closure_desc,
                  .ty_desc = &strings[ent->ty_desc],
@@ -121,19 +158,23 @@ static InfoProvEnt ipeBufferEntryToIpe(const IpeBufferListNode *node, uint32_t i
  static void traceIPEFromHashTable(void *data STG_UNUSED, StgWord key STG_UNUSED,
                                    const void *value) {
      const IpeMapEntry *map_ent = (const IpeMapEntry *)value;
 -    const InfoProvEnt ipe = ipeBufferEntryToIpe(map_ent->node, map_ent->idx);
 -    traceIPE(&ipe);
 +    if (ipe_node_valid(map_ent->node)){
 +      const InfoProvEnt ipe = ipeBufferEntryToIpe(map_ent->node, map_ent->idx);
 +      traceIPE(&ipe);
 +    }
+ }
  void dumpIPEToEventLog(void) {
      // Dump pending entries
      IpeBufferListNode *node = RELAXED_LOAD(&ipeBufferList);
      while (node != NULL) {
 -        decompressIPEBufferListNodeIfCompressed(node);
 +        if (ipe_node_valid(node)){
 +          decompressIPEBufferListNodeIfCompressed(node);
 -        for (uint32_t i = 0; i < node->count; i++) {
 -            const InfoProvEnt ent = ipeBufferEntryToIpe(node, i);
 -            traceIPE(&ent);
 +          for (uint32_t i = 0; i < node->count; i++) {
 +              const InfoProvEnt ent = ipeBufferEntryToIpe(node, i);
 +              traceIPE(&ent);
 +          }
+         }
          node = node->next;
+     }
@@ -167,9 +208,22 @@ A performance test for IPE registration and lookup can be found here:
  https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5724#note_370806
  */
  void registerInfoProvList(IpeBufferListNode *node) {
++
 +        // Grab a fresh module_id
 +    uint32_t module_id;
 +    StgWord temp_module_id;
 +    while (true) {
 +        temp_module_id = next_module_id;
 +        if (cas(&next_module_id, temp_module_id, temp_module_id+1) == temp_module_id) {
 +            module_id = (uint32_t) temp_module_id;
 +            break;
 +        }
++
 +    }
      while (true) {
          IpeBufferListNode *old = RELAXED_LOAD(&ipeBufferList);
          node->next = old;
 +        node->node_id = module_id;
          if (cas_ptr((volatile void **) &ipeBufferList, old, node) == (void *) old) {
              return;
+         }
@@ -183,7 +237,7 @@ void formatClosureDescIpe(const InfoProvEnt *ipe_buf, char *str_buf) {
  bool lookupIPE(const StgInfoTable *info, InfoProvEnt *out) {
      updateIpeMap();
      IpeMapEntry *map_ent = (IpeMapEntry *) lookupHashTable(ipeMap, (StgWord)info);
 -    if (map_ent) {
 +    if (map_ent && ipe_node_valid(map_ent->node)) {
          *out = ipeBufferEntryToIpe(map_ent->node, map_ent->idx);
          return true;
      } else {
@@ -191,6 +245,18 @@ bool lookupIPE(const StgInfoTable *info, InfoProvEnt *out) {
+     }
+ }
 +// Returns 0 when the info table is not present in the info table map.
 +// See Note [Stable identifiers for IPE entries]
 +uint64_t lookupIPEId(const StgInfoTable *info) {
 +    updateIpeMap();
 +    IpeMapEntry *map_ent = (IpeMapEntry *) lookupHashTable(ipeMap, (StgWord)(info));
 +    if (map_ent){
 +        return IPE_ENTRY_KEY(*map_ent);
 +    } else {
 +        return 0;
 +    }
 +}
++
  void updateIpeMap(void) {
      // Check if there's any work at all. If not so, we can circumvent locking,
      // which decreases performance.

rts/ProfHeap.c

@@ -23,6 +23,7 @@
  #include "Printer.h"
  #include "Trace.h"
  #include "sm/GCThread.h"
 +#include "IPE.h"
  #include <fs_rts.h>
  #include <string.h>
@@ -230,9 +231,10 @@ closureIdentity( const StgClosure *p )
              return closure_type_names[info->type];
+         }
+     }
 -    case HEAP_BY_INFO_TABLE: {
 -        return get_itbl(p);
 -        }
 +    case HEAP_BY_INFO_TABLE:
 +    {
 +        return (void *) (p->header.info);
 +    }
      default:
          barf("closureIdentity");
@@ -853,6 +855,20 @@ aggregateCensusInfo( void )
+ }
  #endif
 +static void
 +recordIPEHeapSample(FILE *hp_file, uint64_t table_id, size_t count)
 +{
 +    // Print to heap profile file
 +    fprintf(hp_file, "0x%" PRIx64, table_id);
++
 +    // Create label string for tracing
 +    char str[100];
 +    sprintf(str, "0x%" PRIx64, table_id);
++
 +    // Emit the profiling sample (convert count to bytes)
 +    traceHeapProfSampleString(0, str, count * sizeof(W_));
 +}
++
  /* -----------------------------------------------------------------------------
   * Print out the results of a heap census.
   * -------------------------------------------------------------------------- */
@@ -915,6 +931,11 @@ dumpCensus( Census *census )
+     }
  #endif
 +    // Census entries which we need to group together.
 +    // Used by IPE profiling to group together bands which don't have IPE information.
 +    // Printing at the end in the 0 band
 +    uint64_t uncategorised_count = 0;
++
      for (ctr = census->ctrs; ctr != NULL; ctr = ctr->next) {
  #if defined(PROFILING)
@@ -945,10 +966,13 @@ dumpCensus( Census *census )
                                        count * sizeof(W_));
              break;
          case HEAP_BY_INFO_TABLE:
 -            fprintf(hp_file, "%p", ctr->identity);
 -            char str[100];
 -            sprintf(str, "%p", ctr->identity);
 -            traceHeapProfSampleString(0, str, count * sizeof(W_));
++
 +            uint64_t table_id = lookupIPEId(ctr->identity);
 +            if (! table_id) {
 +              uncategorised_count += count;
 +              continue;
 +            }
 +            recordIPEHeapSample(hp_file, table_id, count);
              break;
  #if defined(PROFILING)
          case HEAP_BY_CCS:
@@ -999,9 +1023,21 @@ dumpCensus( Census *census )
              barf("dumpCensus; doHeapProfile");
+         }
++
++
          fprintf(hp_file, "\t%" FMT_Word "\n", (W_)count * sizeof(W_));
+     }
 +    // Print the unallocated data into the 0 band for info table profiling.
 +    switch (RtsFlags.ProfFlags.doHeapProfile) {
 +        case HEAP_BY_INFO_TABLE:
 +            recordIPEHeapSample(hp_file, 0, uncategorised_count);
 +            break;
 +        default:
 +            ASSERT(uncategorised_count == 0);
 +            break;
 +    }
++
      traceHeapProfSampleEnd(era);
      printSample(false, census->time);

rts/eventlog/EventLog.c

@@ -1472,7 +1472,7 @@ void postIPE(const InfoProvEnt *ipe)
      CHECK(!ensureRoomForVariableEvent(&eventBuf, len));
      postEventHeader(&eventBuf, EVENT_IPE);
      postPayloadSize(&eventBuf, len);
 -    postWord64(&eventBuf, (StgWord) INFO_PTR_TO_STRUCT(ipe->info));
 +    postWord64(&eventBuf, (StgWord) (ipe->prov.info_prov_id));
      postStringLen(&eventBuf, ipe->prov.table_name, table_name_len);
      postStringLen(&eventBuf, closure_desc_buf, closure_desc_len);
      postStringLen(&eventBuf, ipe->prov.ty_desc, ty_desc_len);

rts/include/rts/IPE.h

@@ -14,6 +14,7 @@
  #pragma once
  typedef struct InfoProv_ {
 +    uint64_t   info_prov_id;
      const char *table_name;
      uint32_t closure_desc; // closure type
      const char *ty_desc;
@@ -63,9 +64,37 @@ typedef struct {
  GHC_STATIC_ASSERT(sizeof(IpeBufferEntry) % (WORD_SIZE_IN_BITS / 8) == 0, "sizeof(IpeBufferEntry) must be a multiple of the word size");
 +// The magic word is IPE\nIPE\n, which occupies the full 64 bit width of a word.
 +// See Note [IPE Stripping and magic words]
 +#define IPE_MAGIC_WORD 0x4950450049504500UL
++
 +// Heap profiling currently requires a 32 bit pointer.. so for now just truncate
 +// the key to fit. It should still be big enough.
 +#if SIZEOF_VOID_P == 4
 +// On 32-bit systems: keep lower 16 bits of module_id and idx
 +#define IPE_PROF_KEY(key64) \
 +    (uint32_t)((((key64) >> 16) & 0xFFFF0000) | ((key64) & 0x0000FFFF))
 +#else
 +// On 64-bit systems: use full key
 +#define IPE_PROF_KEY(key64) (key64)
 +#endif
++
 +typedef struct {
 +    StgWord64 magic;          // Must be IPE_MAGIC_WORD
 +    IpeBufferEntry entries[]; // Flexible array member
 +} IpeBufferEntryBlock;
++
 +typedef struct {
 +    StgWord64 magic;          // Must be IPE_MAGIC_WORD
 +    char string_table[];    // Flexible array member for string table
 +} IpeStringTableBlock;
++
  typedef struct IpeBufferListNode_ {
      struct IpeBufferListNode_ *next;
 +    // This field is filled in when the node is registered.
 +    uint32_t node_id;
++
      // Everything below is read-only and generated by the codegen
      // This flag should be treated as a boolean
@@ -76,10 +105,10 @@ typedef struct IpeBufferListNode_ {
      // When TNTC is enabled, these will point to the entry code
      // not the info table itself.
      const StgInfoTable **tables;
 -    IpeBufferEntry *entries;
 +    IpeBufferEntryBlock *entries_block;
      StgWord entries_size; // decompressed size
 -    const char *string_table;
 +    const IpeStringTableBlock *string_table_block;
      StgWord string_table_size; // decompressed size
      // Shared by all entries
@@ -98,6 +127,8 @@ void formatClosureDescIpe(const InfoProvEnt *ipe_buf, char *str_buf);
  // Returns true on success, initializes `out`.
  bool lookupIPE(const StgInfoTable *info, InfoProvEnt *out);
 +uint64_t lookupIPEId(const StgInfoTable *info);
++
  #if defined(DEBUG)
  void printIPE(const StgInfoTable *info);
  #endif

testsuite/tests/hpc/recsel/Makefile

 +TOP=../../..
 +include $(TOP)/mk/boilerplate.mk
 +include $(TOP)/mk/test.mk

testsuite/tests/hpc/recsel/recsel.hs

 +{-# 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

 +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

 +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.

testsuite/tests/rts/ipe/ipeMap.c

@@ -48,7 +48,8 @@ HaskellObj shouldFindOneIfItHasBeenRegistered(Capability *cap) {
      // Allocate buffers for IPE buffer list node
      IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode));
      node->tables = malloc(sizeof(StgInfoTable *));
 -    node->entries = malloc(sizeof(IpeBufferEntry));
 +    node->entries_block = malloc(sizeof(StgWord64) + sizeof(IpeBufferEntry));
 +    node->entries_block->magic = IPE_MAGIC_WORD;
      StringTable st;
      init_string_table(&st);
@@ -61,9 +62,13 @@ HaskellObj shouldFindOneIfItHasBeenRegistered(Capability *cap) {
      node->compressed = 0;
      node->count = 1;
      node->tables[0] = get_itbl(fortyTwo);
 -    node->entries[0] = makeAnyProvEntry(cap, &st, 42);
 +    node->entries_block->entries[0] = makeAnyProvEntry(cap, &st, 42);
      node->entries_size = sizeof(IpeBufferEntry);
 -    node->string_table = st.buffer;
++
 +    IpeStringTableBlock *string_table_block = malloc(sizeof(StgWord64) + st.size);
 +    string_table_block->magic = IPE_MAGIC_WORD;
 +    memcpy(string_table_block->string_table, st.buffer, st.size);
 +    node->string_table_block = string_table_block;
      node->string_table_size = st.size;
      registerInfoProvList(node);
@@ -90,7 +95,8 @@ void shouldFindTwoIfTwoHaveBeenRegistered(Capability *cap,
      // Allocate buffers for IPE buffer list node
      IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode));
      node->tables = malloc(sizeof(StgInfoTable *));
 -    node->entries = malloc(sizeof(IpeBufferEntry));
 +    node->entries_block = malloc(sizeof(StgWord64) + sizeof(IpeBufferEntry));
 +    node->entries_block->magic = IPE_MAGIC_WORD;
      StringTable st;
      init_string_table(&st);
@@ -103,9 +109,12 @@ void shouldFindTwoIfTwoHaveBeenRegistered(Capability *cap,
      node->compressed = 0;
      node->count = 1;
      node->tables[0] = get_itbl(twentyThree);
 -    node->entries[0] = makeAnyProvEntry(cap, &st, 23);
 +    node->entries_block->entries[0] = makeAnyProvEntry(cap, &st, 23);
      node->entries_size = sizeof(IpeBufferEntry);
 -    node->string_table = st.buffer;
 +    IpeStringTableBlock *string_table_block = malloc(sizeof(StgWord64) + st.size);
 +    string_table_block->magic = IPE_MAGIC_WORD;
 +    memcpy(string_table_block->string_table, st.buffer, st.size);
 +    node->string_table_block = string_table_block;
      node->string_table_size = st.size;
      registerInfoProvList(node);
@@ -121,7 +130,8 @@ void shouldFindTwoFromTheSameList(Capability *cap) {
      // Allocate buffers for IPE buffer list node
      IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode));
      node->tables = malloc(sizeof(StgInfoTable *) * 2);
 -    node->entries = malloc(sizeof(IpeBufferEntry) * 2);
 +    node->entries_block = malloc(sizeof(StgWord64) + sizeof(IpeBufferEntry) * 2);
 +    node->entries_block->magic = IPE_MAGIC_WORD;
      StringTable st;
      init_string_table(&st);
@@ -133,10 +143,13 @@ void shouldFindTwoFromTheSameList(Capability *cap) {
      node->count = 2;
      node->tables[0] = get_itbl(one);
      node->tables[1] = get_itbl(two);
 -    node->entries[0] = makeAnyProvEntry(cap, &st, 1);
 -    node->entries[1] = makeAnyProvEntry(cap, &st, 2);
 +    node->entries_block->entries[0] = makeAnyProvEntry(cap, &st, 1);
 +    node->entries_block->entries[1] = makeAnyProvEntry(cap, &st, 2);
      node->entries_size = sizeof(IpeBufferEntry) * 2;
 -    node->string_table = st.buffer;
 +    IpeStringTableBlock *string_table_block = malloc(sizeof(StgWord64) + st.size);
 +    string_table_block->magic = IPE_MAGIC_WORD;
 +    memcpy(string_table_block->string_table, st.buffer, st.size);
 +    node->string_table_block = string_table_block;
      node->string_table_size = st.size;
      registerInfoProvList(node);
@@ -152,7 +165,11 @@ void shouldDealWithAnEmptyList(Capability *cap, HaskellObj fortyTwo) {
      IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode));
      node->count = 0;
      node->next = NULL;
 -    node->string_table = "";
 +    IpeStringTableBlock *string_table_block = malloc(sizeof(StgWord64));
 +    string_table_block->magic = IPE_MAGIC_WORD;
++
 +    node->entries_block = malloc(sizeof(StgWord64));
 +    node->entries_block->magic = IPE_MAGIC_WORD;
      registerInfoProvList(node);

testsuite/tests/rts/ipe/ipe_lib.c

@@ -64,7 +64,8 @@ IpeBufferListNode *makeAnyProvEntries(Capability *cap, int start, int end) {
      // Allocate buffers for IpeBufferListNode
      IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode));
      node->tables = malloc(sizeof(StgInfoTable *) * n);
 -    node->entries = malloc(sizeof(IpeBufferEntry) * n);
 +    node->entries_block = malloc(sizeof(StgWord64) + sizeof(IpeBufferEntry) * n);
 +    node->entries_block->magic = IPE_MAGIC_WORD;
      StringTable st;
      init_string_table(&st);
@@ -83,14 +84,19 @@ IpeBufferListNode *makeAnyProvEntries(Capability *cap, int start, int end) {
      for (int i=start; i < end; i++) {
          HaskellObj closure = rts_mkInt(cap, 42);
          node->tables[i]  = get_itbl(closure);
 -        node->entries[i] = makeAnyProvEntry(cap, &st, i);
 +        node->entries_block->entries[i] = makeAnyProvEntry(cap, &st, i);
+     }
      // Set the rest of the fields
      node->next = NULL;
      node->compressed = 0;
      node->count = n;
 -    node->string_table = st.buffer;
++
 +    IpeStringTableBlock *string_table_block =
 +      malloc(sizeof(StgWord64) + st.size);
 +    string_table_block->magic = IPE_MAGIC_WORD;
 +    memcpy(string_table_block->string_table, st.buffer, st.size);
 +    node->string_table_block = string_table_block;
      return node;
+ }