Ticky profiling improvements.

This adds a number of changes to ticky-ticky profiling.

When an executable is profiled with IPE profiling it's now possible to
associate id-related ticky counters to their source location.
This works by emitting the info table address as part of the counter
which can be looked up in the IPE table.

Add a `-ticky-ap-thunk` flag. This flag prevents the use of some standard thunks
which are precompiled into the RTS. This means reduced cache locality
and increased code size. But it allows better attribution of execution
cost to specific source locations instead of simple attributing it to
the standard thunk.

ticky-ticky now uses the `arg` field to emit additional information
about counters in json format. When ticky-ticky is used in combination
with the eventlog eventlog2html can be used to generate a html table
from the eventlog similar to the old text output for ticky-ticky.

6 files changed, 150 insertions, 45 deletions

diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 17d8556b15..5507173dc7 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -212,7 +212,7 @@ cgRhs :: Id
                )
 
 cgRhs id (StgRhsCon cc con mn _ts args)
-  = withNewTickyCounterCon (idName id) con $
+  = withNewTickyCounterCon id con mn $
     buildDynCon id mn True cc con (assertNonVoidStgArgs args)
       -- con args are always non-void,
       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
@@ -223,14 +223,16 @@ cgRhs id (StgRhsClosure fvs cc upd_flag args body)
     checkFunctionArgTags (text "TagCheck Failed: Rhs of" <> ppr id) id args
     profile <- getProfile
     check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
-    mkRhsClosure profile check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
-
+    use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig
+    mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
 
 ------------------------------------------------------------------------
 --              Non-constructor right hand sides
 ------------------------------------------------------------------------
 
-mkRhsClosure :: Profile -> Bool
+mkRhsClosure :: Profile
+             -> Bool                            -- Omit AP Thunks to improve profiling
+             -> Bool                            -- Lint tag inference checks
              -> Id -> CostCentreStack
              -> [NonVoid Id]                    -- Free vars
              -> UpdateFlag
@@ -274,7 +276,7 @@ for semi-obvious reasons.
 -}
 
 ---------- See Note [Selectors] ------------------
-mkRhsClosure    profile _check_tags bndr _cc
+mkRhsClosure    profile _ _check_tags bndr _cc
                 [NonVoid the_fv]                -- Just one free var
                 upd_flag                -- Updatable thunk
                 []                      -- A thunk
@@ -307,7 +309,7 @@ mkRhsClosure    profile _check_tags bndr _cc
     in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
 
 ---------- See Note [Ap thunks] ------------------
-mkRhsClosure    profile check_tags bndr _cc
+mkRhsClosure    profile use_std_ap check_tags bndr _cc
                 fvs
                 upd_flag
                 []                      -- No args; a thunk
@@ -316,7 +318,8 @@ mkRhsClosure    profile check_tags bndr _cc
   -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure
   -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)
   -- So the xi will all be free variables
-  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and
+  | use_std_ap
+  , args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and
                                -- args are all distinct local variables
                                -- The "-1" is for fun_id
     -- Missed opportunity:   (f x x) is not detected
@@ -340,7 +343,7 @@ mkRhsClosure    profile check_tags bndr _cc
     payload = StgVarArg fun_id : args
 
 ---------- Default case ------------------
-mkRhsClosure profile _check_tags bndr cc fvs upd_flag args body
+mkRhsClosure profile _use_ap _check_tags bndr cc fvs upd_flag args body
   = do  { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args
         ; (id_info, reg) <- rhsIdInfo bndr lf_info
         ; return (id_info, gen_code lf_info reg) }
@@ -404,13 +407,13 @@ cgRhsStdThunk bndr lf_info payload
        }
  where
  gen_code reg  -- AHA!  A STANDARD-FORM THUNK
-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $
+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) payload $
     do
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
-  ; cfg      <- getStgToCmmConfig
-  ; let profile  = stgToCmmProfile  cfg
-  ; let platform = stgToCmmPlatform cfg
+  ; profile  <- getProfile
+  ; platform <- getPlatform
+  ; let
         header = if isLFThunk lf_info then ThunkHeader else StdHeader
         (tot_wds, ptr_wds, payload_w_offsets)
             = mkVirtHeapOffsets profile header
@@ -476,7 +479,8 @@ closureCodeBody top_lvl bndr cl_info cc [] body fv_details
   = withNewTickyCounterThunk
         (isStaticClosure cl_info)
         (closureUpdReqd cl_info)
-        (closureName cl_info) $
+        (closureName cl_info)
+        (map fst fv_details) $
     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node body
    where
@@ -488,7 +492,7 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
         arity = length args
     in
     -- See Note [OneShotInfo overview] in GHC.Types.Basic.
-    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info)
+    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) (map fst fv_details)
         nv_args $ do {
 
         ; let
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index 2609606292..7c1b5250e4 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -65,6 +65,7 @@ module GHC.StgToCmm.Closure (
         cafBlackHoleInfoTable,
         indStaticInfoTable,
         staticClosureNeedsLink,
+        mkClosureInfoTableLabel
     ) where
 
 import GHC.Prelude
@@ -642,7 +643,7 @@ getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
 
 data ClosureInfo
   = ClosureInfo {
-        closureName :: !Name,           -- The thing bound to this closure
+        closureName :: !Id,           -- The thing bound to this closure
            -- we don't really need this field: it's only used in generating
            -- code for ticky and profiling, and we could pass the information
            -- around separately, but it doesn't do much harm to keep it here.
@@ -679,13 +680,12 @@ mkClosureInfo :: Profile
               -> String         -- String descriptor
               -> ClosureInfo
 mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr
-  = ClosureInfo { closureName      = name
+  = ClosureInfo { closureName      = id
                 , closureLFInfo    = lf_info
                 , closureInfoLabel = info_lbl   -- These three fields are
                 , closureSMRep     = sm_rep     -- (almost) an info table
                 , closureProf      = prof }     -- (we don't have an SRT yet)
   where
-    name       = idName id
     sm_rep     = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     prof       = mkProfilingInfo profile id val_descr
     nonptr_wds = tot_wds - ptr_wds
@@ -839,6 +839,7 @@ closureLocalEntryLabel platform
   | platformTablesNextToCode platform = toInfoLbl  platform . closureInfoLabel
   | otherwise                         = toEntryLbl platform . closureInfoLabel
 
+-- | Get the info table label for a *thunk*.
 mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel
 mkClosureInfoTableLabel platform id lf_info
   = case lf_info of
diff --git a/compiler/GHC/StgToCmm/Config.hs b/compiler/GHC/StgToCmm/Config.hs
index 623a7b8f0a..b3014fd302 100644
--- a/compiler/GHC/StgToCmm/Config.hs
+++ b/compiler/GHC/StgToCmm/Config.hs
@@ -61,6 +61,7 @@ data StgToCmmConfig = StgToCmmConfig
   , stgToCmmAllowExtendedAddSubInstrs :: !Bool   -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc.
   , stgToCmmAllowIntMul2Instr         :: !Bool   -- ^ Allowed to generate IntMul2 instruction
   , stgToCmmAllowFabsInstrs           :: !Bool   -- ^ Allowed to generate Fabs instructions
+  , stgToCmmTickyAP                   :: !Bool   -- ^ Disable use of precomputed standard thunks.
   ------------------------------ SIMD flags ------------------------------------
   -- Each of these flags checks vector compatibility with the backend requested
   -- during compilation. In essence, this means checking for @-fllvm@ which is
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index eef1420a72..4d1fff30df 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -17,7 +17,7 @@ module GHC.StgToCmm.Env (
 
         bindArgsToRegs, bindToReg, rebindToReg,
         bindArgToReg, idToReg,
-        getCgIdInfo,
+        getCgIdInfo, getCgInfo_maybe,
         maybeLetNoEscape,
         ) where
 
@@ -44,6 +44,9 @@ import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 
+import GHC.Builtin.Names (getUnique)
+
+
 -------------------------------------
 --        Manipulating CgIdInfo
 -------------------------------------
@@ -150,6 +153,12 @@ getCgIdInfo id
               cgLookupPanic id -- Bug
         }}}
 
+-- | Retrieve cg info for a name if it already exists.
+getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)
+getCgInfo_maybe name
+  = do  { local_binds <- getBinds -- Try local bindings first
+        ; return $ lookupVarEnv_Directly local_binds (getUnique name) }
+
 cgLookupPanic :: Id -> FCode a
 cgLookupPanic id
   = do  local_binds <- getBinds
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 5129a45b1c..55892b8789 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -216,7 +216,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
   = do platform <- getPlatform
        return ( lneIdInfo platform bndr args, code )
   where
-   code = forkLneBody $ withNewTickyCounterLNE (idName bndr) args $ do
+   code = forkLneBody $ withNewTickyCounterLNE bndr args $ do
             { restoreCurrentCostCentre cc_slot
             ; arg_regs <- bindArgsToRegs args
             ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index 4aec817412..a538ff2f4d 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -135,6 +135,7 @@ import GHC.Cmm.Utils
 import GHC.Cmm.CLabel
 import GHC.Runtime.Heap.Layout
 
+
 import GHC.Types.Name
 import GHC.Types.Id
 import GHC.Types.Basic
@@ -154,6 +155,11 @@ import GHC.Core.Predicate
 import Data.Maybe
 import qualified Data.Char
 import Control.Monad ( when, unless )
+import GHC.Types.Id.Info
+import GHC.Utils.Trace
+import GHC.StgToCmm.Env (getCgInfo_maybe)
+import Data.Coerce (coerce)
+import GHC.Utils.Json
 
 -----------------------------------------------------------------------------
 --
@@ -161,23 +167,73 @@ import Control.Monad ( when, unless )
 --
 -----------------------------------------------------------------------------
 
+-- | Number of arguments for a ticky counter.
+--
+-- Ticky currently treats args to constructor allocations differently than those for functions/LNE bindings.
+tickyArgArity :: TickyClosureType -> Int
+tickyArgArity (TickyFun _ _fvs args) = length args
+tickyArgArity (TickyLNE args) = length args
+tickyArgArity (TickyCon{}) = 0
+tickyArgArity (TickyThunk{}) = 0
+
+tickyArgDesc :: TickyClosureType -> String
+tickyArgDesc arg_info =
+  case arg_info of
+    TickyFun _ _fvs args -> map (showTypeCategory . idType . fromNonVoid) args
+    TickyLNE args -> map (showTypeCategory . idType . fromNonVoid) args
+    TickyThunk{} -> ""
+    TickyCon{} -> ""
+
+tickyFvDesc :: TickyClosureType -> String
+tickyFvDesc arg_info =
+  case arg_info of
+    TickyFun _ fvs _args -> map (showTypeCategory . idType . fromNonVoid) fvs
+    TickyLNE{} -> ""
+    TickyThunk _ _ fvs -> map (showTypeCategory . stgArgType) fvs
+    TickyCon{} -> ""
+
+instance ToJson TickyClosureType where
+    json info = case info of
+      (TickyFun {})   -> mkInfo (tickyFvDesc info) (tickyArgDesc info) "fun"
+      (TickyLNE {})   -> mkInfo []                 (tickyArgDesc info) "lne"
+      (TickyThunk uf _ _) -> mkInfo (tickyFvDesc info) []              ("thk" ++ if uf then "_u" else "")
+      (TickyCon{})    -> mkInfo []                 []                  "con"
+      where
+        mkInfo :: String -> String -> String -> JsonDoc
+        mkInfo fvs args ty =
+          JSObject
+              [("type", json "entCntr")
+              ,("subTy", json ty)
+              ,("fvs_c", json (length fvs))
+              ,("fvs" , json fvs)
+              ,("args", json args)
+              ]
+
+tickyEntryDesc :: (SDocContext -> TickyClosureType -> String)
+tickyEntryDesc ctxt = renderWithContext ctxt . renderJSON . json
+
 data TickyClosureType
     = TickyFun
         Bool -- True <-> single entry
+        [NonVoid Id] -- ^ FVs
+        [NonVoid Id] -- ^ Args
     | TickyCon
         DataCon -- the allocated constructor
+        ConstructorNumber
     | TickyThunk
         Bool -- True <-> updateable
         Bool -- True <-> standard thunk (AP or selector), has no entry counter
+        [StgArg] -- ^ FVS, StgArg because for thunks these can also be literals.
     | TickyLNE
+        [NonVoid Id] -- ^ Args
 
-withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a
-withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)
+withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterFun single_entry f fvs args = withNewTickyCounter (TickyFun single_entry fvs args) f
 
-withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterLNE :: Id  ->  [NonVoid Id] -> FCode a -> FCode a
 withNewTickyCounterLNE nm args code = do
   b <- isEnabled stgToCmmTickyLNE
-  if not b then code else withNewTickyCounter TickyLNE nm args code
+  if not b then code else withNewTickyCounter (TickyLNE args) nm code
 
 thunkHasCounter :: Bool -> FCode Bool
 thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk
@@ -185,46 +241,50 @@ thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk
 withNewTickyCounterThunk
   :: Bool -- ^ static
   -> Bool -- ^ updateable
-  -> Name
+  -> Id
+  -> [NonVoid Id] -- ^ Free vars
   -> FCode a
   -> FCode a
-withNewTickyCounterThunk isStatic isUpdatable name code = do
+withNewTickyCounterThunk isStatic isUpdatable name fvs code = do
     has_ctr <- thunkHasCounter isStatic
     if not has_ctr
       then code
-      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
+      else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code
 
 withNewTickyCounterStdThunk
   :: Bool -- ^ updateable
-  -> Name
+  -> Id
+  -> [StgArg] -- ^ Free vars + function
   -> FCode a
   -> FCode a
-withNewTickyCounterStdThunk isUpdatable name code = do
+withNewTickyCounterStdThunk isUpdatable name fvs code = do
     has_ctr <- thunkHasCounter False
     if not has_ctr
       then code
-      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
+      else withNewTickyCounter (TickyThunk isUpdatable True fvs) name code
 
 withNewTickyCounterCon
-  :: Name
+  :: Id
   -> DataCon
+  -> ConstructorNumber
   -> FCode a
   -> FCode a
-withNewTickyCounterCon name datacon code = do
+withNewTickyCounterCon name datacon info code = do
     has_ctr <- thunkHasCounter False
     if not has_ctr
       then code
-      else withNewTickyCounter (TickyCon datacon) name [] code
+      else withNewTickyCounter (TickyCon datacon info) name code
 
 -- args does not include the void arguments
-withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
-withNewTickyCounter cloType name args m = do
-  lbl <- emitTickyCounter cloType name args
+withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a
+withNewTickyCounter cloType name m = do
+  lbl <- emitTickyCounter cloType name
   setTickyCtrLabel lbl m
 
-emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
-emitTickyCounter cloType name args
-  = let ctr_lbl = mkRednCountsLabel name in
+emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel
+emitTickyCounter cloType tickee
+  = let name = idName tickee in
+    let ctr_lbl = mkRednCountsLabel name in
     (>> return ctr_lbl) $
     ifTicky $ do
         { cfg    <- getStgToCmmConfig
@@ -239,23 +299,52 @@ emitTickyCounter cloType name args
               ppr_for_ticky_name :: SDoc
               ppr_for_ticky_name =
                 let ext = case cloType of
-                              TickyFun single_entry -> parens $ hcat $ punctuate comma $
+                              TickyFun single_entry _ _-> parens $ hcat $ punctuate comma $
                                   [text "fun"] ++ [text "se"|single_entry]
-                              TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon))
-                              TickyThunk upd std -> parens $ hcat $ punctuate comma $
+                              TickyCon datacon _cn -> parens (text "con:" <+> ppr (dataConName datacon))
+                              TickyThunk upd std _-> parens $ hcat $ punctuate comma $
                                   [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]
-                              TickyLNE | isInternalName name -> parens (text "LNE")
-                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
+                              TickyLNE _ | isInternalName name -> parens (text "LNE")
+                                         | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
                     p = case hasHaskellName parent of
                             -- NB the default "top" ticky ctr does not
                             -- have a Haskell name
                           Just pname -> text "in" <+> ppr (nameUnique pname)
                           _ -> empty
                 in pprTickyName mod_name name <+> ext <+> p
+        ; this_mod <- getModuleName
+        ; let t = case cloType of
+                    TickyCon {} -> "C"
+                    TickyFun {} -> "F"
+                    TickyThunk {} -> "T"
+                    TickyLNE {} -> "L"
+        ; info_lbl <- case cloType of
+                            TickyCon dc mn -> case mn of
+                                               NoNumber -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) DefinitionSite
+                                               (Numbered n) -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) (UsageSite this_mod n)
+                            TickyFun {} ->
+                              return $! CmmLabel $ mkInfoTableLabel name NoCafRefs
+
+                            TickyThunk _ std_thunk _fvs
+                              | not std_thunk
+                              -> return $! CmmLabel $ mkInfoTableLabel name NoCafRefs
+                              -- IPE Maps have no entry for std thunks.
+                              | otherwise
+                              -> do
+                                    lf_info <- getCgInfo_maybe name
+                                    profile <- getProfile
+                                    case lf_info of
+                                      Just (CgIdInfo { cg_lf = cg_lf })
+                                          | isLFThunk cg_lf
+                                          -> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf
+                                      _   -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs))
+                                            return $! zeroCLit platform
+
+                            TickyLNE {} -> return $! zeroCLit platform
 
         ; let ctx = defaultSDocContext {sdocPprDebug = True}
         ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name
-        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
+        ; arg_descr_lit <- newStringCLit $ tickyEntryDesc ctx cloType
         ; emitDataLits ctr_lbl
         -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter
         --
@@ -263,10 +352,11 @@ emitTickyCounter cloType name args
         -- before, but the code generator wasn't handling that
         -- properly and it led to chaos, panic and disorder.
             [ mkIntCLit platform 0,               -- registered?
-              mkIntCLit platform (length args),   -- Arity
+              mkIntCLit platform (tickyArgArity cloType),   -- Arity
               mkIntCLit platform 0,               -- Heap allocated for this thing
               fun_descr_lit,
               arg_descr_lit,
+              info_lbl,
               zeroCLit platform,          -- Entries into this thing
               zeroCLit platform,          -- Heap allocated by this thing
               zeroCLit platform           -- Link to next StgEntCounter