eventlog-live 0.5.0.0 → 0.6.0.0

raw patch · 19 files changed

+743/−468 lines, 19 filesdep +ipedbdep ~containersdep ~ghc-stack-profiler-coredep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: ipedb

Dependency ranges changed: containers, ghc-stack-profiler-core, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• eventlog-live.cabal +22/−5
• src/GHC/Eventlog/Live/Data/Attribute.hs +8/−1
• src/GHC/Eventlog/Live/Data/Capability.hs +49/−0
• src/GHC/Eventlog/Live/Data/Group.hs +1/−1
• src/GHC/Eventlog/Live/Data/HeapProfBreakdown.hs +93/−0
• src/GHC/Eventlog/Live/Data/LogRecord.hs +1/−1
• src/GHC/Eventlog/Live/Data/Metric.hs +4/−3
• src/GHC/Eventlog/Live/Data/Severity.hs +1/−1
• src/GHC/Eventlog/Live/Data/Span.hs +1/−1
• src/GHC/Eventlog/Live/Data/Thread.hs +28/−0
• src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs +53/−187
• src/GHC/Eventlog/Live/Machine/Analysis/Log.hs +2/−2
• src/GHC/Eventlog/Live/Machine/Analysis/Profile.hs +274/−233
• src/GHC/Eventlog/Live/Machine/Core.hs +26/−0
• src/GHC/Eventlog/Live/Options.hs +27/−4
• src/GHC/Eventlog/Live/Source.hs +30/−26
• src/GHC/Eventlog/Live/Source/Core.hs +23/−3
• vendor/base-compat-0.15.0/Data/Traversable/Compat.hs +94/−0

@@ -1,3 +1,9 @@+### 0.6.0.0++- Add support for `ipedb` databases for IPE and cost-centre information.+- **BREAKING**: Refactor profiles processors.+- **BREAKING**: Use `InfoProv`, `CostCentre`, and `SrcLoc` types from `ipedb`.+ ### 0.5.0.0  - Overhaul documentation for `GHC.Eventlog.Live.Machine.Core`.

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: eventlog-live-version: 0.5.0.0+version: 0.6.0.0 synopsis: Live processing of eventlog data. description:   This package provides [machines](https://hackage.haskell.org/package/machines) for processing live eventlog data.@@ -33,7 +33,7 @@ source-repository this   type: git   location: https://github.com/well-typed/eventlog-live.git-  tag: eventlog-live-0.5.0.0+  tag: eventlog-live-v0.6.0.0   subdir: eventlog-live  -- 2025-12-09:@@ -64,6 +64,7 @@     DeriveGeneric     DeriveTraversable     DerivingStrategies+    DerivingVia     DuplicateRecordFields     FlexibleContexts     FlexibleInstances@@ -92,14 +93,19 @@  library   import: language-  hs-source-dirs: src+  hs-source-dirs:+    src+   exposed-modules:     GHC.Eventlog.Live.Data.Attribute+    GHC.Eventlog.Live.Data.Capability     GHC.Eventlog.Live.Data.Group+    GHC.Eventlog.Live.Data.HeapProfBreakdown     GHC.Eventlog.Live.Data.LogRecord     GHC.Eventlog.Live.Data.Metric     GHC.Eventlog.Live.Data.Severity     GHC.Eventlog.Live.Data.Span+    GHC.Eventlog.Live.Data.Thread     GHC.Eventlog.Live.Logger     GHC.Eventlog.Live.Machine.Analysis.Capability     GHC.Eventlog.Live.Machine.Analysis.Heap@@ -121,10 +127,12 @@     bytestring >=0.11 && <0.13,     clock >=0.8 && <0.9,     co-log-core >=0.3 && <0.4,+    containers >=0.6 && <0.9,     dlist >=1.0 && <1.1,     ghc-events >=0.20 && <0.21,-    ghc-stack-profiler-core >=0.2 && <0.3,+    ghc-stack-profiler-core >=0.3 && <0.4,     hashable >=1.4 && <1.6,+    ipedb >=0.2 && <0.3,     machines >=0.7.4 && <0.8,     monad-control >=1.0 && <1.1,     network >=3.2.7 && <3.3,@@ -133,7 +141,16 @@     text >=1.2 && <2.2,     transformers >=0.2 && <0.7,     unordered-containers >=0.2.20 && <0.3,-    vector >=0.11 && <0.14,+    vector >=0.12.2 && <0.14,++  -- 2026-07-17:+  -- This includes a vendored copy of mapAccumM from the base-compat+  -- package version 0.15.0.+  hs-source-dirs:+    vendor/base-compat-0.15.0++  other-modules:+    Data.Traversable.Compat    -- 2025-12-09:   -- This configures the build requirements for the vendored copy of

@@ -1,10 +1,11 @@ {- | Module      : GHC.Eventlog.Live.Attribute-Description : Representation for attributes.+Description : Representation for OTLP attributes. Stability   : experimental Portability : portable -} module GHC.Eventlog.Live.Data.Attribute (+  HasAttrs (..),   Attrs,   lookup,   toList,@@ -25,6 +26,12 @@ import GHC.Generics (Generic) import GHC.IsList (IsList (..)) import Prelude hiding (lookup)++{- |+A class for types that have attributes.+-}+class HasAttrs a where+  getAttrs :: a -> Attrs  {- | A set of attributes is a t`HashMap`

@@ -0,0 +1,49 @@+{- |+Module      : GHC.Eventlog.Live.Data.Capability+Description : Reprsentation for capability data.+Stability   : experimental+Portability : portable+-}+module GHC.Eventlog.Live.Data.Capability (+  CapNo (..),+  evCapNo,+  fromCapabilityId,+) where++import Data.Word (Word16)+import GHC.Eventlog.Live.Data.Attribute (IsAttrValue)+import GHC.RTS.Events (Event (..))+import GHC.Stack.Profiler.Core.Eventlog (CapabilityId (..))++{- |+A capability number.++In the GHC RTS, all capabilities are assigned a `Word16` identifier.++In @ghc-events@, the event capability number is received as a `Word16`,+if present, and converted to an `Int`, using @-1@ for global events.++In @ghc-stack-profiler@, the capability number is added to the event,+and upcast to `Word64`.+-}+newtype CapNo = CapNo+  { value :: Word16+  }+  deriving (Show, Eq, Ord)+  deriving newtype (IsAttrValue)++{- |+Get the capability number from a @ghc-events@ `Event`.+-}+evCapNo :: Event -> Maybe CapNo+evCapNo ev+  | Just cap <- ev.evCap+  , 0 <= cap && cap <= fromIntegral @Word16 maxBound =+      Just (CapNo $ fromIntegral cap)+  | otherwise = Nothing++{- |+Get the capability number from a @ghc-stack-profiler@ `CapabilityId`.+-}+fromCapabilityId :: CapabilityId -> CapNo+fromCapabilityId (MkCapabilityId cap) = CapNo $ fromIntegral cap

@@ -1,6 +1,6 @@ {- | Module      : GHC.Eventlog.Live.Data.Group-Description : Core machines for processing data in batches.+Description : Reprsentation for grouped data. Stability   : experimental Portability : portable -}

@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : GHC.Eventlog.Live.Data.HeapProfBreakdown+Description : Utilities for GHC heap profiling breakdowns.+Stability   : experimental+Portability : portable+-}+module GHC.Eventlog.Live.Data.HeapProfBreakdown (+  HeapProfBreakdown (..),+  heapProfBreakdownEitherReader,+  heapProfBreakdownShow,+  findHeapProfBreakdown,+) where++import Data.Maybe (listToMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.RTS.Events (HeapProfBreakdown (..))++{- |+Parses the `HeapProfBreakdown` command-line arguments:++> heapProfBreakdownEitherReader "T" == Left HeapProfBreakdownClosureType+> heapProfBreakdownEitherReader "c" == Left HeapProfBreakdownCostCentre+> heapProfBreakdownEitherReader "m" == Left HeapProfBreakdownModule+> heapProfBreakdownEitherReader "d" == Left HeapProfBreakdownClosureDescr+> heapProfBreakdownEitherReader "y" == Left HeapProfBreakdownTypeDescr+> heapProfBreakdownEitherReader "e" == Left HeapProfBreakdownEra+> heapProfBreakdownEitherReader "r" == Left HeapProfBreakdownRetainer+> heapProfBreakdownEitherReader "b" == Left HeapProfBreakdownBiography+> heapProfBreakdownEitherReader "i" == Left HeapProfBreakdownInfoTable+-}+heapProfBreakdownEitherReader :: String -> Either String HeapProfBreakdown+heapProfBreakdownEitherReader =+  \case+    "T" -> Right HeapProfBreakdownClosureType+    "c" -> Right HeapProfBreakdownCostCentre+    "m" -> Right HeapProfBreakdownModule+    "d" -> Right HeapProfBreakdownClosureDescr+    "y" -> Right HeapProfBreakdownTypeDescr+    "e" -> Right HeapProfBreakdownEra+    "r" -> Right HeapProfBreakdownRetainer+    "b" -> Right HeapProfBreakdownBiography+    "i" -> Right HeapProfBreakdownInfoTable+    str -> Left $ "Unsupported heap profile breakdown -h" <> str++{- |+Shows a `HeapProfBreakdown` as its corresponding command-line flag:++> heapProfBreakdownShow HeapProfBreakdownClosureType == "-hT"+> heapProfBreakdownShow HeapProfBreakdownCostCentre == "-hc"+> heapProfBreakdownShow HeapProfBreakdownModule == "-hm"+> heapProfBreakdownShow HeapProfBreakdownClosureDescr == "-hd"+> heapProfBreakdownShow HeapProfBreakdownTypeDescr == "-hy"+> heapProfBreakdownShow HeapProfBreakdownEra == "-he"+> heapProfBreakdownShow HeapProfBreakdownRetainer == "-hr"+> heapProfBreakdownShow HeapProfBreakdownBiography == "-hb"+> heapProfBreakdownShow HeapProfBreakdownInfoTable == "-hi"+-}+heapProfBreakdownShow :: HeapProfBreakdown -> String+heapProfBreakdownShow =+  ("-h" <>) . \case+    HeapProfBreakdownClosureType -> "T"+    HeapProfBreakdownCostCentre -> "c"+    HeapProfBreakdownModule -> "m"+    HeapProfBreakdownClosureDescr -> "d"+    HeapProfBreakdownTypeDescr -> "y"+    HeapProfBreakdownEra -> "e"+    HeapProfBreakdownRetainer -> "r"+    HeapProfBreakdownBiography -> "b"+    HeapProfBreakdownInfoTable -> "i"++{- |+Determine the `HeapProfBreakdown` from the list of program arguments.++__Warning__: This scan is not fully correct. It merely scans for the presence+of arguments that, as a whole, parse with `heapProfBreakdownEitherReader`.+It does not handle @-with-rtsopts@ and does not restrict its search to those+arguments between @+RTS@ and @-RTS@ tags.+-}+findHeapProfBreakdown :: [Text] -> Maybe HeapProfBreakdown+findHeapProfBreakdown = listToMaybe . mapMaybe parseHeapProfBreakdown+ where+  parseHeapProfBreakdown :: Text -> Maybe HeapProfBreakdown+  parseHeapProfBreakdown arg+    | "-h" `T.isPrefixOf` arg =+        either (const Nothing) Just+          . heapProfBreakdownEitherReader+          . T.unpack+          . T.drop 2+          $ arg+    | otherwise = Nothing

@@ -1,6 +1,6 @@ {- | Module      : GHC.Eventlog.Live.LogRecord-Description : Representation for metrics.+Description : Representation for OTLP log records. Stability   : experimental Portability : portable -}

@@ -1,6 +1,6 @@ {- | Module      : GHC.Eventlog.Live.Metric-Description : Representation for metrics.+Description : Representation for OTLP metrics. Stability   : experimental Portability : portable -}@@ -33,8 +33,9 @@   , maybeTimeUnixNano :: !(Maybe Timestamp)   -- ^ The time at which the measurement was taken.   , maybeStartTimeUnixNano :: !(Maybe Timestamp)-  -- ^ The earliest time at which any measurement could have been taken.-  --   Usually, this represents the start time of a process.+  {- ^ The earliest time at which any measurement could have been taken.+  Usually, this represents the start time of a process.+  -}   , attrs :: Attrs   -- ^ A set of attributes.   }

@@ -1,6 +1,6 @@ {- | Module      : GHC.Eventlog.Live.Severity-Description : Representation for metrics.+Description : Representation for OTLP log record severities. Stability   : experimental Portability : portable -}

@@ -1,6 +1,6 @@ {- | Module      : GHC.Eventlog.Live.Span-Description : Representation for spans.+Description : Representation for OTLP spans. Stability   : experimental Portability : portable -}

@@ -0,0 +1,28 @@+{- |+Module      : GHC.Eventlog.Live.Data.Thread+Description : Reprsentation for thread data.+Stability   : experimental+Portability : portable+-}+module GHC.Eventlog.Live.Data.Thread (+  ThreadId (..),+) where++import Data.Word (Word64)+import GHC.Eventlog.Live.Data.Attribute (IsAttrValue)++{- |+A thread ID.++In the GHC RTS, all threads are assigned a `Word64` identifier.+However, thread IDs are posted to the eventlog as `Word32` values.++In @ghc-events@, the thread ID is received and represented as a `Word32` value.++In @ghc-stack-profiler@, the thread ID is retrieved and posted as a `Word64` value.+-}+newtype ThreadId = ThreadId+  { value :: Word64+  }+  deriving stock (Show, Eq, Ord)+  deriving newtype (IsAttrValue)

@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}  {- | Module      : GHC.Eventlog.Live.Machine.Analysis.Heap@@ -19,45 +18,35 @@   HeapProfSampleData,   heapProfSamples,   processHeapProfSampleData,--  -- ** Heap Profile Breakdown-  heapProfBreakdownEitherReader,-  heapProfBreakdownShow,--  -- ** Things fendor doesn't want to reimplement-  InfoTable (..),-  InfoTablePtr (..),-  HeapProfBreakdown,-  metric, ) where  import Control.Monad (unless, when)+import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (MonadTrans (..)) import Data.Either (isLeft) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as M-import Data.Hashable (Hashable (..)) import Data.List qualified as L import Data.Machine (Process, ProcessT, await, construct, repeatedly, yield)-import Data.Maybe (isJust, listToMaybe, mapMaybe)+import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T import Data.Word (Word32, Word64) import GHC.Eventlog.Live.Data.Attribute (Attrs, (~=)) import GHC.Eventlog.Live.Data.Group (GroupBy (..))+import GHC.Eventlog.Live.Data.HeapProfBreakdown (findHeapProfBreakdown, heapProfBreakdownShow) import GHC.Eventlog.Live.Data.Metric (Metric (..)) import GHC.Eventlog.Live.Data.Severity (Severity (..)) import GHC.Eventlog.Live.Logger (Logger, writeLog) import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano) import GHC.RTS.Events (Event (..), HeapProfBreakdown (..)) import GHC.RTS.Events qualified as E-import Numeric (showHex)-import Text.ParserCombinators.ReadP (readP_to_S)-import Text.ParserCombinators.ReadP qualified as P+import IpeDB.Database (Table)+import IpeDB.Database qualified as DB+import IpeDB.Types.InfoProv (InfoProv (..), InfoProvId (..)) import Text.Printf (printf) import Text.Read (readMaybe)-import Text.Read.Lex (readHexP)  ------------------------------------------------------------------------------- -- Heap events@@ -207,7 +196,7 @@   Metric Word64 ->   HeapProfSampleData ->   m HeapProfSampleData-insertHeapProfSampleString logger heapProfLabel heapProfSample heapProfSamples = do+insertHeapProfSampleString logger heapProfLabel heapProfSample heapProfSampleData = do   let insert :: Maybe (Metric Word64) -> m (Maybe (Metric Word64))       insert heapProfSample' = do         when (isJust heapProfSample') $ do@@ -215,75 +204,21 @@           writeLog logger WARN $ msg          pure (Just heapProfSample)-  heapProfSampleMap' <- M.alterF insert heapProfLabel heapProfSamples.heapProfSampleMap+  heapProfSampleMap' <- M.alterF insert heapProfLabel heapProfSampleData.heapProfSampleMap   pure HeapProfSampleData{heapProfSampleMap = heapProfSampleMap'}  {- | Internal helper.-The type of info table pointers.--}-newtype InfoTablePtr = InfoTablePtr Word64-  deriving newtype (Eq, Hashable, Ord)--instance Show InfoTablePtr where-  showsPrec :: Int -> InfoTablePtr -> ShowS-  showsPrec _ (InfoTablePtr ptr) =-    showString "0x" . showHex ptr--instance Read InfoTablePtr where-  readsPrec :: Int -> ReadS InfoTablePtr-  readsPrec _ = readP_to_S (InfoTablePtr <$> (P.string "0x" *> readHexP))--{- |-Internal helper.-The type of an info table entry, as produced by the `E.InfoTableProv` event.--}-data InfoTable = InfoTable-  { infoTablePtr :: !InfoTablePtr-  , infoTableName :: !Text-  , infoTableClosureDesc :: !Int-  , infoTableTyDesc :: !Text-  , infoTableLabel :: !Text-  , infoTableModule :: !Text-  , infoTableSrcLoc :: !Text-  }-  deriving (Show, Eq, Ord)--{- |-Internal helper. The type of the state kept by `processHeapProfSampleData`. -} data HeapProfSampleState = HeapProfSampleState   { eitherShouldWarnOrHeapProfBreakdown :: !(Either Bool HeapProfBreakdown)-  , infoTableMap :: !(HashMap InfoTablePtr InfoTable)   , heapProfSampleEraStack :: ![Word64]   , maybeHeapProfSampleData :: !(Maybe HeapProfSampleData)   }   deriving (Show)  {- |-Internal helper.-Decides whether or not `processHeapProfSampleData` should track info tables.-We track info tables until (1) we learn that the RTS is not run with @-hi@,-or (2) we see the first heap profiling sample and don't yet know for sure-that the RTS is run with @-hi@.--}-shouldTrackInfoTableMap :: Either Bool HeapProfBreakdown -> Bool-shouldTrackInfoTableMap (Left _shouldWarn) = True-shouldTrackInfoTableMap (Right HeapProfBreakdownInfoTable) = True-shouldTrackInfoTableMap _ = False--{- |-Internal helper.-Checks whether a `HeapProfBreakdown` is `HeapProfBreakdownInfoTable`.-This is needed because the ghc-events package does not define an `Eq`-instance for the `HeapProfBreakdown` type.--}-isHeapProfBreakdownInfoTable :: HeapProfBreakdown -> Bool-isHeapProfBreakdownInfoTable HeapProfBreakdownInfoTable = True-isHeapProfBreakdownInfoTable _ = False--{- | This machine processes `E.HeapProfSampleString` events into metrics. Furthermore, it processes the `E.HeapProfBegin` and `E.ProgramArgs` events to determine the heap profile breakdown, processes `E.InfoTableProv` events to@@ -291,16 +226,16 @@ and `E.HeapProfSampleEnd` events to maintain an era stack. -} processHeapProfSampleData ::-  (Monad m) =>+  (MonadIO m) =>   Logger m ->+  Maybe (Table InfoProvId InfoProv) ->   Maybe HeapProfBreakdown ->   ProcessT m (WithStartTime Event) HeapProfSampleData-processHeapProfSampleData logger maybeHeapProfBreakdown =+processHeapProfSampleData logger maybeInfoProvTable maybeHeapProfBreakdown =   construct $     go       HeapProfSampleState         { eitherShouldWarnOrHeapProfBreakdown = maybe (Left True) Right maybeHeapProfBreakdown-        , infoTableMap = mempty         , heapProfSampleEraStack = mempty         , maybeHeapProfSampleData = mempty         }@@ -320,21 +255,6 @@         | isLeft eitherShouldWarnOrHeapProfBreakdown         , Just heapProfBreakdown <- findHeapProfBreakdown args ->             go st{eitherShouldWarnOrHeapProfBreakdown = Right heapProfBreakdown}-      -- Announces an info table entry.-      E.InfoTableProv{..}-        | shouldTrackInfoTableMap eitherShouldWarnOrHeapProfBreakdown -> do-            let infoTablePtr = InfoTablePtr itInfo-                infoTable =-                  InfoTable-                    { infoTablePtr = infoTablePtr-                    , infoTableName = itTableName-                    , infoTableClosureDesc = itClosureDesc-                    , infoTableTyDesc = itTyDesc-                    , infoTableLabel = itLabel-                    , infoTableModule = itModule-                    , infoTableSrcLoc = itSrcLoc-                    }-            go st{infoTableMap = M.insert infoTablePtr infoTable infoTableMap}       -- Announces the beginning of a heap profile sample.       E.HeapProfSampleBegin{..} -> do         -- Check that maybeHeapProfSampleData is Nothing.@@ -392,24 +312,47 @@                   \         you must also pass the heap profile type to this executable.\n\                   \         See: https://gitlab.haskell.org/ghc/ghc/-/commit/76d392a"             lift $ writeLog logger WARN $ msg-            go st{eitherShouldWarnOrHeapProfBreakdown = Left False, infoTableMap = mempty}+            go st{eitherShouldWarnOrHeapProfBreakdown = Left False}+        -- If the heap profile breakdown is by info table, but the shared info+        -- prov table was not provided, issue a warning, then disable warnings.+        | Right HeapProfBreakdownInfoTable <- eitherShouldWarnOrHeapProfBreakdown+        , Nothing <- maybeInfoProvTable -> do+            let msg =+                  "Heap profile breakdown is "+                    <> heapProfBreakdownShow HeapProfBreakdownInfoTable+                    <> ", but no shared InfoProv table was provided."+            lift $ writeLog logger WARN $ T.pack msg+            go st{eitherShouldWarnOrHeapProfBreakdown = Left False}         -- If the heap profile breakdown is biographical, issue a warning, then disable warnings.         | Right HeapProfBreakdownBiography <- eitherShouldWarnOrHeapProfBreakdown -> do             let msg =-                  T.pack $-                    printf-                      "Unsupported heap profile breakdown %s"-                      (heapProfBreakdownShow HeapProfBreakdownBiography)-            lift $ writeLog logger WARN $ msg-            go st{eitherShouldWarnOrHeapProfBreakdown = Left False, infoTableMap = mempty}+                  "Unsupported heap profile breakdown "+                    <> heapProfBreakdownShow HeapProfBreakdownBiography+            lift $ writeLog logger WARN $ T.pack msg+            go st{eitherShouldWarnOrHeapProfBreakdown = Left False}         -- If there is a heap profile breakdown, handle it appropriately.         | Right heapProfBreakdown <- eitherShouldWarnOrHeapProfBreakdown -> do             -- If the heap profile breakdown is by info table, add the info table.-            let maybeInfoTable-                  | isHeapProfBreakdownInfoTable heapProfBreakdown = do-                      !infoTablePtr <- readMaybe (T.unpack heapProfLabel)-                      M.lookup infoTablePtr infoTableMap-                  | otherwise = Nothing+            maybeInfoProv <-+              case heapProfBreakdown of+                -- NOTE: The case where maybeInfoProvTable is Nothing is handled above.+                HeapProfBreakdownInfoTable | Just infoProvTable <- maybeInfoProvTable ->+                  case readMaybe (T.unpack heapProfLabel) of+                    Nothing -> do+                      lift . writeLog logger WARN $+                        "Expected InfoProv ID, found '" <> heapProfLabel <> "' for HeapProfSampleString."+                      pure Nothing+                    Just infoProvPtr -> do+                      maybeInfoProv <- liftIO $ DB.lookup infoProvTable infoProvPtr+                      case maybeInfoProv of+                        Nothing ->+                          when (infoProvPtr /= InfoProvId 0) . lift . writeLog logger WARN $+                            "Could not resolve IPE for " <> T.pack (show infoProvPtr) <> "."+                        Just infoProv ->+                          lift . writeLog logger TRACE $+                            "Resolved IPE for " <> T.pack (show infoProvPtr) <> " to " <> infoProv.ipName <> "."+                      pure maybeInfoProv+                _otherwise -> pure Nothing             -- Get the HeapProfSampleData             heapProfSampleData <-               case st.maybeHeapProfSampleData of@@ -429,99 +372,22 @@                     , "heapProfId" ~= heapProfId                     , "heapProfLabel" ~= heapProfLabel                     , "heapProfSampleEra" ~= (fst <$> L.uncons heapProfSampleEraStack)-                    , "infoTableName" ~= fmap (.infoTableName) maybeInfoTable-                    , "infoTableClosureDesc" ~= fmap (.infoTableClosureDesc) maybeInfoTable-                    , "infoTableTyDesc" ~= fmap (.infoTableTyDesc) maybeInfoTable-                    , "infoTableLabel" ~= fmap (.infoTableLabel) maybeInfoTable-                    , "infoTableModule" ~= fmap (.infoTableModule) maybeInfoTable-                    , "infoTableSrcLoc" ~= fmap (.infoTableSrcLoc) maybeInfoTable+                    , "ipName" ~= fmap (.ipName) maybeInfoProv+                    , "ipClosureDesc" ~= fmap (.ipClosureDesc) maybeInfoProv+                    , "ipTyDesc" ~= fmap (.ipTyDesc) maybeInfoProv+                    , "ipLabel" ~= fmap (.ipLabel) maybeInfoProv+                    , "ipModule" ~= fmap (.ipModule) maybeInfoProv+                    , "ipSrcLoc" ~= fmap (show . (.ipSrcLoc)) maybeInfoProv                     ]             heapProfSampleData' <-               lift $ insertHeapProfSampleString logger heapProfLabel heapProfSample heapProfSampleData             -- Continue with the updated HeapProfSampleState             go               st-                { -- If we're not profiling with -hi, discard the info table map-                  infoTableMap = if isHeapProfBreakdownInfoTable heapProfBreakdown then st.infoTableMap else mempty-                , -- Add the update HeapProfSampleData+                { -- Add the update HeapProfSampleData                   maybeHeapProfSampleData = Just heapProfSampleData'                 }       _otherwise -> go st--{- |-Parses the `HeapProfBreakdown` command-line arguments:--> heapProfBreakdownEitherReader "T" == Left HeapProfBreakdownClosureType-> heapProfBreakdownEitherReader "c" == Left HeapProfBreakdownCostCentre-> heapProfBreakdownEitherReader "m" == Left HeapProfBreakdownModule-> heapProfBreakdownEitherReader "d" == Left HeapProfBreakdownClosureDescr-> heapProfBreakdownEitherReader "y" == Left HeapProfBreakdownTypeDescr-> heapProfBreakdownEitherReader "e" == Left HeapProfBreakdownEra-> heapProfBreakdownEitherReader "r" == Left HeapProfBreakdownRetainer-> heapProfBreakdownEitherReader "b" == Left HeapProfBreakdownBiography-> heapProfBreakdownEitherReader "i" == Left HeapProfBreakdownInfoTable--}-heapProfBreakdownEitherReader :: String -> Either String HeapProfBreakdown-heapProfBreakdownEitherReader =-  \case-    "T" -> Right HeapProfBreakdownClosureType-    "c" -> Right HeapProfBreakdownCostCentre-    "m" -> Right HeapProfBreakdownModule-    "d" -> Right HeapProfBreakdownClosureDescr-    "y" -> Right HeapProfBreakdownTypeDescr-    "e" -> Right HeapProfBreakdownEra-    "r" -> Right HeapProfBreakdownRetainer-    "b" -> Right HeapProfBreakdownBiography-    "i" -> Right HeapProfBreakdownInfoTable-    str -> Left $ "Unsupported heap profile breakdown -h" <> str--{- |-Shows a `HeapProfBreakdown` as its corresponding command-line flag:--> heapProfBreakdownShow HeapProfBreakdownClosureType == "-hT"-> heapProfBreakdownShow HeapProfBreakdownCostCentre == "-hc"-> heapProfBreakdownShow HeapProfBreakdownModule == "-hm"-> heapProfBreakdownShow HeapProfBreakdownClosureDescr == "-hd"-> heapProfBreakdownShow HeapProfBreakdownTypeDescr == "-hy"-> heapProfBreakdownShow HeapProfBreakdownEra == "-he"-> heapProfBreakdownShow HeapProfBreakdownRetainer == "-hr"-> heapProfBreakdownShow HeapProfBreakdownBiography == "-hb"-> heapProfBreakdownShow HeapProfBreakdownInfoTable == "-hi"--}-heapProfBreakdownShow :: HeapProfBreakdown -> String-heapProfBreakdownShow =-  ("-h" <>) . \case-    HeapProfBreakdownClosureType -> "T"-    HeapProfBreakdownCostCentre -> "c"-    HeapProfBreakdownModule -> "m"-    HeapProfBreakdownClosureDescr -> "d"-    HeapProfBreakdownTypeDescr -> "y"-    HeapProfBreakdownEra -> "e"-    HeapProfBreakdownRetainer -> "r"-    HeapProfBreakdownBiography -> "b"-    HeapProfBreakdownInfoTable -> "i"--{- |-Internal helper.-Determine the `HeapProfBreakdown` from the list of program arguments.--__Warning__: This scan is not fully correct. It merely scans for the presence-of arguments that, as a whole, parse with `heapProfBreakdownEitherReader`.-It does not handle @-with-rtsopts@ and does not restrict its search to those-arguments between @+RTS@ and @-RTS@ tags.--}-findHeapProfBreakdown :: [Text] -> Maybe HeapProfBreakdown-findHeapProfBreakdown = listToMaybe . mapMaybe parseHeapProfBreakdown- where-  parseHeapProfBreakdown :: Text -> Maybe HeapProfBreakdown-  parseHeapProfBreakdown arg-    | "-h" `T.isPrefixOf` arg =-        either (const Nothing) Just-          . heapProfBreakdownEitherReader-          . T.unpack-          . T.drop 2-          $ arg-    | otherwise = Nothing  ------------------------------------------------------------------------------- -- Internal Helpers

@@ -24,8 +24,8 @@ {- | This machine processes `E.UserMessage` events into logs. -}-processUserMessageData :: Process (WithStartTime Event) LogRecord-processUserMessageData =+processStackFrame'Message :: Process (WithStartTime Event) LogRecord+processStackFrame'Message =   repeatedly $     await >>= \case       i

@@ -1,274 +1,315 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+ module GHC.Eventlog.Live.Machine.Analysis.Profile (-  StackProfSampleData (..),-  ThreadId (..),-  CapabilityId (..),-  CallStackData (..),-  StackItemData (..),-  CostCentreId (..),-  CostCentre (..),-  processStackProfSampleData,-  processCostCentreProfSampleData,-  stackProfSamples,+  -- * Call-stack profiling+  CallStack (..),+  CallStackFrame (..),+  processGhcStackProfilerData,++  -- * Cost-centre profiling+  CostCentreStack (..),+  CostCentreStackFrame (..),+  processProfSampleCostCentreData, ) where +import Control.Applicative (Alternative (..))+import Control.Exception (Exception (..))+import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (MonadTrans (..))-import Data.ByteString.Lazy qualified as LBS-import Data.Foldable (for_)-import Data.HashMap.Strict (HashMap)-import Data.HashMap.Strict qualified as HashMap-import Data.HashMap.Strict qualified as M-import Data.Hashable qualified as Hashable-import Data.List qualified as List+import Data.ByteString.Lazy qualified as BSL import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.List.NonEmpty qualified as NonEmpty-import Data.Machine (ProcessT, await, construct, yield)-import Data.Maybe (mapMaybe)+import Data.List.NonEmpty qualified as NE+import Data.Machine (Is, PlanT, ProcessT, await, construct, repeatedly, yield)+import Data.Map.Strict qualified as M+import Data.Maybe (catMaybes, isNothing, mapMaybe)+import Data.Set qualified as S import Data.Text (Text)+import Data.Text qualified as T import Data.Text qualified as Text-import Data.Vector.Unboxed qualified as UVector-import Data.Word-import GHC.Eventlog.Live.Data.Metric-import GHC.Eventlog.Live.Logger (Logger, writeException)-import GHC.Eventlog.Live.Machine.Analysis.Heap (InfoTable (..), InfoTablePtr (..), metric)-import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..))-import GHC.Generics (Generic)-import GHC.RTS.Events (Event (..))+import Data.Traversable.Compat (mapAccumM)+import Data.Vector (Vector)+import Data.Vector qualified as V+import GHC.Eventlog.Live.Data.Attribute (Attrs, HasAttrs (..), (~=))+import GHC.Eventlog.Live.Data.Capability (CapNo (..), fromCapabilityId)+import GHC.Eventlog.Live.Data.Severity (Severity (..))+import GHC.Eventlog.Live.Data.Thread (ThreadId (..))+import GHC.Eventlog.Live.Logger (Logger, writeLog)+import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano)+import GHC.RTS.Events (Event (..), Timestamp) import GHC.RTS.Events qualified as E-import GHC.Stack.Profiler.Core.Eventlog qualified as SPCE-import GHC.Stack.Profiler.Core.SymbolTable qualified as SPCS-import GHC.Stack.Profiler.Core.ThreadSample qualified as SPCT+import GHC.Stack.Profiler.Core.Eventlog qualified as GSP+import GHC.Stack.Profiler.Core.SymbolTable qualified as GSP+import GHC.Stack.Profiler.Core.ThreadSample qualified as GSP+import IpeDB.Database qualified as DB+import IpeDB.Types.CostCentre (CostCentre (..), CostCentreId (..))+import IpeDB.Types.InfoProv (InfoProv (..), InfoProvId (..))+import IpeDB.Types.SrcLoc (Range (..), SrcLoc (..)) -data StackProfSampleState = StackProfSampleState-  { infoTableMap :: !(HashMap InfoTablePtr InfoTable)-  , -- TODO: this should probably be a maybe?-    -- We could report when interleaved messages are present-    stackProfSampleChunk :: ![SPCE.BinaryCallStackMessage]-  , stackProfSymbolTableReader :: !SPCS.IntMapTable-  , maybeStackProfSampleData :: !(Maybe StackProfSampleData)-  }-  deriving (Generic)+--------------------------------------------------------------------------------+-- Processor for `ghc-stack-profiler` call-stack samples+-------------------------------------------------------------------------------- -newtype CostCentreProfSampleState = CostCentreProfSampleState-  { costCentreMap :: HashMap CostCentreId CostCentre+{- |+A GHC call-stack as produced by @ghc-stack-profiler@.+-}+data CallStack = CallStack+  { capNo :: !CapNo+  , threadId :: !ThreadId+  , callStack :: !(Vector CallStackFrame)+  , maybeTimeUnixNano :: !(Maybe Timestamp)   }-  deriving (Generic)+  deriving stock (Show) -newtype StackProfSampleData = StackProfSampleData-  { stackProfSample :: Metric CallStackData-  }-  deriving (Show, Generic)+instance HasAttrs CallStack where+  getAttrs :: CallStack -> Attrs+  getAttrs callStack =+    [ "capability" ~= callStack.capNo+    , "thread" ~= callStack.threadId+    ] -newtype ThreadId = ThreadId-  { value :: Word64-  }-  deriving (Show, Eq, Ord, Generic)+{- |+A GHC call-stack frame as produced by @ghc-stack-profiler@.+-}+data CallStackFrame+  = CallStackFrame !InfoProvId !(Maybe InfoProv)+  | CallStackMessage !Text !SrcLoc+  deriving stock (Show) -newtype CapabilityId = CapabilityId-  { value :: Word64-  }-  deriving (Show, Eq, Ord, Generic)+{- |+Internal helper. -data CallStackData = CallStackData-  { threadId :: !(Maybe ThreadId)-  , capabilityId :: !CapabilityId-  , stack :: [StackItemData]+The internal state for `processGhcStackProfilerData`.+-}+data GhcStackProfilerState = GhcStackProfilerState+  { warnOnDeserializeError :: !Bool+  , callStackChunksRev :: ![GSP.BinaryCallStackMessage]+  , maybeTimeUnixNano :: !(Maybe Timestamp)+  , symbolTable :: !GSP.IntMapTable   }-  deriving (Show, Eq, Ord, Generic) -newtype CostCentreId = CostCentreId-  { id :: Word64-  }-  deriving (Show, Eq, Ord, Generic)-  deriving newtype (Hashable.Hashable)+{- |+Internal helper. -data CostCentre = CostCentre-  { costCentreId :: !CostCentreId-  , costCentreLabel :: !Text-  , costCentreModule :: !Text-  , costCentreSrcLoc :: !Text-  -- , heapProfFlags :: !HeapProfFlags-  }-  deriving (Show, Eq, Ord, Generic)+The initial state for `processGhcStackProfilerData`.+-}+emptyGhcStackProfilerState :: GhcStackProfilerState+emptyGhcStackProfilerState =+  GhcStackProfilerState+    { warnOnDeserializeError = True+    , callStackChunksRev = []+    , maybeTimeUnixNano = Nothing+    , symbolTable = GSP.emptyIntMapTable+    } -data StackItemData-  = IpeData !InfoTable-  | UserMessageData !Text-  | SourceLocationData !SPCT.SourceLocation-  | CostCentreData !CostCentre-  deriving (Show, Eq, Ord, Generic)+{- |+This machine processes the `E.UserBinaryMessage` events produced by+@ghc-stack-profiler@ into `CallStack` samples.+-}+processGhcStackProfilerData ::+  forall m.+  (MonadIO m) =>+  Logger m ->+  DB.Table InfoProvId InfoProv ->+  ProcessT m (WithStartTime Event) CallStack+processGhcStackProfilerData logger infoProvTable =+  construct $ go emptyGhcStackProfilerState+ where+  go :: GhcStackProfilerState -> PlanT (Is (WithStartTime Event)) CallStack m ()+  go st =+    await >>= \i -> do+      case i.value.evSpec of+        E.UserBinaryMessage{..} -> do+          case GSP.deserializeEventlogMessage (BSL.fromStrict payload) of+            Left errMsg+              | st.warnOnDeserializeError -> do+                  lift . writeLog logger WARN . T.unlines $+                    [ "Could not parse UserBinaryMessage as ghc-stack-profiler message:"+                    , T.pack errMsg+                    , "If other plugins are communicating via binary eventlog messages, this is expected."+                    ]+                  go st{warnOnDeserializeError = False}+              | otherwise -> go st+            -- If we receive the final call-stack chunk, decode and yield the call-stack, the restart...+            Right (GSP.CallStackFinal callStackChunk) -> do+              let symbolTableReader = GSP.mkIntMapSymbolTableReader st.symbolTable+              let callStackChunks = NE.reverse (callStackChunk :| st.callStackChunksRev)+              let !maybeTimeUnixNano = st.maybeTimeUnixNano <|> tryGetTimeUnixNano i+              callStack <- lift $ decodeCallStack maybeTimeUnixNano symbolTableReader callStackChunks+              unless (V.null callStack.callStack) $ yield callStack+              go+                st+                  { callStackChunksRev = []+                  , maybeTimeUnixNano = Nothing+                  }+            -- If we receive a call-stack chunk, add it to the list of chunks and continue...+            Right (GSP.CallStackChunk callStackChunk) ->+              go+                st+                  { callStackChunksRev = callStackChunk : st.callStackChunksRev+                  , maybeTimeUnixNano = st.maybeTimeUnixNano <|> tryGetTimeUnixNano i+                  }+            -- If we receive a string definition, update the symbol table and continue...+            Right (GSP.StringDef string) -> do+              let !symbolTable' = GSP.insertTextMessage string st.symbolTable+              go st{symbolTable = symbolTable'}+            -- If we receive a source location definition, update the symbol table and continue...+            Right (GSP.SourceLocationDef sourceLocation) ->+              case GSP.insertSourceLocationMessage sourceLocation st.symbolTable of+                Left errMsg -> do+                  lift . writeLog logger WARN . T.unlines $+                    [ "Could not decode source location from ghc-stack-profiler message:"+                    , T.pack (displayException errMsg)+                    ]+                  go st+                Right symbolTable' ->+                  go st{symbolTable = symbolTable'}+        _otherwise -> go st -shouldTrackInfoTableMap :: Bool-shouldTrackInfoTableMap = True+  decodeCallStack ::+    Maybe Timestamp ->+    GSP.SymbolTableReader ->+    NonEmpty GSP.BinaryCallStackMessage ->+    m CallStack+  decodeCallStack maybeTimeUnixNano symbolTableReader callStackChunks = do+    -- Concatenate the chunks into a full binary call-stack message.+    let !gspBinaryCallStack = GSP.catCallStackMessage callStackChunks -shouldTrackCostCentreMap :: Bool-shouldTrackCostCentreMap = True+    -- Decode the binary call-stack and log any decoding errors.+    let !(gspCallStackMessage, decodeErrors) =+          GSP.hydrateEventlogCallStackMessage symbolTableReader gspBinaryCallStack+    let !gspCallStack = GSP.callStack gspCallStackMessage+    unless (null decodeErrors) $+      writeLog logger WARN . T.unlines $+        ["Encountered errors while decoding binary call-stack from ghc-stack-profiler message:"]+          <> [T.pack (displayException decodeError) | decodeError <- decodeErrors] --- ------------------------------------------------------------------------------- `cost centre stack` processor--- ----------------------------------------------------------------------------+    -- Extract the IPE IDs and look them up in a single batched database query.+    let getMaybeInfoProvId :: GSP.StackItem -> Maybe InfoProvId+        getMaybeInfoProvId = \case GSP.IpeId iid -> Just (toInfoProvId iid); _otherwise -> Nothing+    let infoProvIds = V.fromList . mapMaybe getMaybeInfoProvId $ gspCallStack+    maybeInfoProvs <- liftIO $ lookups infoProvTable infoProvIds +    -- Convert each `GSP.StackItem` to a `CallStackFrame`.+    let toCallStackFrame :: [Maybe InfoProv] -> GSP.StackItem -> m ([Maybe InfoProv], Maybe CallStackFrame)+        toCallStackFrame (maybeInfoProv : acc) (GSP.IpeId iid) = do+          when (isNothing maybeInfoProv) $+            writeLog logger WARN $+              "Could not resolve IPE ID " <> T.pack (show (toInfoProvId iid))+          pure (acc, Just $! CallStackFrame (toInfoProvId iid) maybeInfoProv)+        toCallStackFrame acc (GSP.UserAnnotation msg maybeSourceLocation) =+          pure (acc, Just $! CallStackMessage (T.pack msg) (toSrcLoc maybeSourceLocation))+        toCallStackFrame [] (GSP.IpeId _iid) = do+          writeLog logger ERROR $+            "Did not receive enough IPEs to annotate each call-stack item. Please report this as a bug."+          pure ([], Nothing)+    callStack <-+      V.fromList . catMaybes . snd+        <$> mapAccumM toCallStackFrame (V.toList maybeInfoProvs) gspCallStack++    let !capNo = fromCapabilityId . GSP.callCapabilityId $ gspCallStackMessage+    let !threadId = ThreadId . GSP.callThreadId $ gspCallStackMessage+    pure CallStack{..}+ {- |-This machine processes `E.UserBinaryMessage` events into metrics.-Furthermore, it processes the `E.InfoTableProv` events to+Internal helper.++Convert a @ghc-stack-profiler@ `GSP.IpeID` to an `InfoProvId`. -}-processCostCentreProfSampleData ::-  (MonadIO m) =>-  Logger m ->-  ProcessT m (WithStartTime Event) StackProfSampleData-processCostCentreProfSampleData _logger =-  construct $-    go-      CostCentreProfSampleState-        { costCentreMap = mempty-        }- where-  go st = do-    await >>= \i -> case i.value.evSpec of-      -- Announces an info table entry.-      E.HeapProfCostCentre{..}-        | shouldTrackCostCentreMap -> do-            let costCentreId = CostCentreId $ fromIntegral heapProfCostCentreId-                costCentre =-                  CostCentre-                    { costCentreId = costCentreId-                    , costCentreLabel = heapProfLabel-                    , costCentreModule = heapProfModule-                    , costCentreSrcLoc = heapProfSrcLoc-                    }-            go st{costCentreMap = M.insert costCentreId costCentre st.costCentreMap}-      E.ProfSampleCostCentre{..} -> do-        let lookupCostCentreStackById :: Word32 -> Maybe StackItemData-            lookupCostCentreStackById costCentreId32 =-              CostCentreData <$> HashMap.lookup (CostCentreId $ fromIntegral costCentreId32) st.costCentreMap+toInfoProvId :: GSP.IpeId -> InfoProvId+toInfoProvId (GSP.MkIpeId x) = InfoProvId x -            callStackMessage =-              CallStackData-                { threadId = Nothing-                , capabilityId = CapabilityId $ fromIntegral profCap-                , stack =-                    -- TODO: log if we are encountering unknown cost centre ids-                    mapMaybe lookupCostCentreStackById (UVector.toList profCcsStack)-                }+{- |+Internal helper. -            stackProfSample =-              metric i callStackMessage mempty+Convert a `GSP.SourceLocation` to a `SrcLoc`.+-}+toSrcLoc :: Maybe GSP.SourceLocation -> SrcLoc+toSrcLoc = \case+  Nothing ->+    UnhelpfulSrcLoc+  Just GSP.MkSourceLocation{fileName, column, line} ->+    SrcLoc (Text.unpack fileName) (Just $! Range'Point column line) -        yield $ StackProfSampleData stackProfSample-        go st-      _otherwise -> go st+--------------------------------------------------------------------------------+-- Processor for cost-centre stack samples+-------------------------------------------------------------------------------- --- ------------------------------------------------------------------------------- `ghc-stack-profiler` processor--- ----------------------------------------------------------------------------+{- |+A GHC cost-centre stack.+-}+data CostCentreStack = CostCentreStack+  { capNo :: !CapNo+  , costCentreStack :: !(Vector CostCentreStackFrame)+  , maybeTimeUnixNano :: !(Maybe Timestamp)+  }+  deriving stock (Show) +instance HasAttrs CostCentreStack where+  getAttrs :: CostCentreStack -> Attrs+  getAttrs costCentreStack =+    [ "capability" ~= costCentreStack.capNo+    ]+ {- |-This machine processes `E.UserBinaryMessage` events into metrics.-Furthermore, it processes the `E.InfoTableProv` events to+A GHC cost-centre stack frame. -}-processStackProfSampleData ::+data CostCentreStackFrame+  = CostCentreStackFrame !CostCentreId !(Maybe CostCentre)+  deriving stock (Show)++{- |+This machine processes `E.ProfSampleCostCentre` events into `CostCentreStack` samples.+-}+processProfSampleCostCentreData ::+  forall m.   (MonadIO m) =>   Logger m ->-  ProcessT m (WithStartTime Event) StackProfSampleData-processStackProfSampleData logger =-  construct $-    go-      StackProfSampleState-        { infoTableMap = mempty-        , stackProfSampleChunk = mempty-        , stackProfSymbolTableReader = SPCS.emptyIntMapTable-        , maybeStackProfSampleData = Nothing-        }- where-  go st = do-    await >>= \i -> case i.value.evSpec of-      -- Announces an info table entry.-      E.InfoTableProv{..}-        | shouldTrackInfoTableMap -> do-            let infoTablePtr = InfoTablePtr itInfo-                infoTable =-                  InfoTable-                    { infoTablePtr = infoTablePtr-                    , infoTableName = itTableName-                    , infoTableClosureDesc = itClosureDesc-                    , infoTableTyDesc = itTyDesc-                    , infoTableLabel = itLabel-                    , infoTableModule = itModule-                    , infoTableSrcLoc = itSrcLoc-                    }-            go st{infoTableMap = M.insert infoTablePtr infoTable st.infoTableMap}-      E.UserBinaryMessage{payload} ->-        case SPCT.deserializeEventlogMessage $ LBS.fromStrict payload of-          Left _err ->-            go st-          Right evMsg -> case evMsg of-            SPCE.CallStackFinal msg -> do-              let (callStackMessage, st', callStackDecodeErrors) = hydrateBinaryEventlog st msg-              for_ callStackDecodeErrors (lift . writeException logger)-              let stackProfSample = metric i callStackMessage mempty-              yield $ StackProfSampleData stackProfSample-              go st'-            SPCE.CallStackChunk msg ->-              go st{stackProfSampleChunk = msg : st.stackProfSampleChunk}-            SPCE.StringDef msg ->-              go st{stackProfSymbolTableReader = SPCS.insertTextMessage msg st.stackProfSymbolTableReader}-            SPCE.SourceLocationDef msg -> do-              let old = st.stackProfSymbolTableReader-              let errOrnew = SPCS.insertSourceLocationMessage msg old-              new <- either (\err -> lift $ writeException logger err >> pure old) pure errOrnew-              go st{stackProfSymbolTableReader = new}-      _otherwise -> go st+  DB.Table CostCentreId CostCentre ->+  ProcessT m (WithStartTime Event) CostCentreStack+processProfSampleCostCentreData logger costCentreTable =+  repeatedly $+    await >>= \i ->+      case i.value.evSpec of+        E.ProfSampleCostCentre{..} -> do+          -- Look up all cost centre IDs in the cost centre stack.+          let !costCentreIds = CostCentreId <$> V.convert profCcsStack+          !maybeCostCentres <- liftIO $ lookups costCentreTable costCentreIds+          -- NOTE: The following is equivalent to `CostCentreStackFrame`, but+          --       logs a warning if the cost centre was not resolved.+          let warnIfNotFound costCentreId maybeCostCentre = do+                lift . when (isNothing maybeCostCentre) $ do+                  writeLog logger WARN . T.pack $+                    "Could not resolve cost centre ID " <> show costCentreId+                pure $ CostCentreStackFrame costCentreId maybeCostCentre+          costCentreStack <- V.zipWithM warnIfNotFound costCentreIds maybeCostCentres -hydrateBinaryEventlog ::-  StackProfSampleState ->-  SPCE.BinaryCallStackMessage ->-  (CallStackData, StackProfSampleState, [SPCT.BinaryCallStackDecodeError])-hydrateBinaryEventlog spst msg = (callStackData, spst{stackProfSampleChunk = []}, callStackDecodeErrors)- where-  chunks = spst.stackProfSampleChunk-  -- Why reverse?-  -- When decoding the stack, we walk the stack from the top down.-  -- Afterwards, the stack is chunked to fit into a single eventlog line,-  -- and the chunks are written in ascending order to the eventlog.-  -- When we pick up these messages one after another, they are prepended to-  -- 'stackProfSampleChunk', thus we are essentially storing the chunks in reverse-  -- order, as the first chunk we encounter is the top of the stack, etc...-  ---  -- Concrete example, assuming a stack @[1,2,3,4,5,6]@ and chunk size of 2:-  ---  -- 1. Chunk it: @[1,2] [3,4] [5,6]@-  -- 2. Write it to the eventlog in this order, so the messages are:-  --    [1,2]-  --    [3,4]-  --    [5,6]-  -- 3. When reading the eventlog, we store prepend later messages, resulting in:-  --    [5,6] [3,4] [1,2]-  -- 4. One reverse later: @[1,2] [3,4] [5,6]@-  -- 5. Now we can finally concat the stack frame chunks.-  orderedChunks = NonEmpty.reverse $ msg :| chunks-  fullBinaryCallStackMessage = SPCT.catCallStackMessage orderedChunks-  (callStackMessage, callStackDecodeErrors) =-    SPCT.hydrateEventlogCallStackMessage-      (SPCS.mkIntMapSymbolTableReader spst.stackProfSymbolTableReader)-      fullBinaryCallStackMessage-  callStackData =-    CallStackData-      { threadId = Just $ ThreadId $ SPCT.callThreadId callStackMessage-      , capabilityId = CapabilityId $ SPCE.getCapabilityId $ SPCT.callCapabilityId callStackMessage-      , stack =-          -- TODO: log if we are encountering unknown ipe ids-          mapMaybe (toStackItemData spst.infoTableMap) $ SPCT.callStack callStackMessage-      }+          -- Yield the cost centre stack.+          let !capNo = CapNo profCap+          let !maybeTimeUnixNano = tryGetTimeUnixNano i+          yield CostCentreStack{..}+        _otherwise -> pure () -toStackItemData :: HashMap InfoTablePtr InfoTable -> SPCT.StackItem -> Maybe StackItemData-toStackItemData tbl = \case-  SPCT.IpeId iid -> IpeData <$> HashMap.lookup (InfoTablePtr $ SPCE.getIpeId iid) tbl-  SPCT.UserMessage msg -> Just $ UserMessageData $ Text.pack msg-  SPCT.SourceLocation srcLoc -> Just $ SourceLocationData srcLoc+--------------------------------------------------------------------------------+-- Internal helpers+--------------------------------------------------------------------------------  {- |-Get the elements of a heap profile sample collection.+Variant of `DB.lookups` that deduplicates keys before performing the database lookup. -}-stackProfSamples :: StackProfSampleData -> [Metric CallStackData]-stackProfSamples = List.singleton . (.stackProfSample)+lookups :: (Ord k, DB.Key k, DB.Value v) => DB.Table k v -> Vector k -> IO (Vector (Maybe v))+lookups table keys = do+  -- Build a set of keys:+  let !keysSet = S.fromList (V.toList keys)+  if S.size keysSet == V.length keys+    then do+      -- If all keys are unique, we can just perform the database lookup...+      DB.lookups table keys+    else do+      -- Otherwise, we perform the database lookup with the unique keys and resolve them via a map...+      let !keysUniq = V.fromList (S.toAscList keysSet)+      maybeValues <- DB.lookups table keysUniq+      let !keyValueMap = M.fromAscList . V.toList . V.mapMaybe sequence $ V.zip keysUniq maybeValues+      pure $ V.map (`M.lookup` keyValueMap) keys

@@ -23,6 +23,10 @@   onlyTick,   liftTick, +  -- * Machine combinators+  (&>),+  embed,+   -- * Routers   liftRouter, @@ -368,6 +372,28 @@ ------------------------------------------------------------------------------- -- Machine combinators -------------------------------------------------------------------------------++infixl 7 &>++{- |+Run two machines in sequence.+-}+(&>) :: (Monad m) => MachineT m k a -> MachineT m k a -> MachineT m k a+m &> n =+  MachineT $+    runMachineT m >>= \case+      Stop ->+        runMachineT n+      Yield o k ->+        pure (Yield o (k &> n))+      Await onNext k onStop ->+        pure (Await (\t -> onNext t &> n) k (onStop &> n))++{- |+Run a monadic action as a machine.+-}+embed :: (Monad m) => m () -> MachineT m k a+embed action = MachineT $! action >> pure Stop  -------------------------------------------------------------------------------- -- Lift a machine to a machine that passes on ticks unchanged

@@ -16,9 +16,9 @@ ) where  import Control.Applicative (asum)+import GHC.Eventlog.Live.Data.HeapProfBreakdown (heapProfBreakdownEitherReader) import GHC.Eventlog.Live.Data.Severity (Severity (..), fromSeverityString)-import GHC.Eventlog.Live.Machine.Analysis.Heap (heapProfBreakdownEitherReader)-import GHC.Eventlog.Live.Source.Core (EventlogSourceOptions (..))+import GHC.Eventlog.Live.Source.Core (EventlogSocketAddr (..), EventlogSourceOptions (..)) import GHC.RTS.Events (HeapProfBreakdown (..)) import Options.Applicative qualified as O import Options.Applicative.Help.Pretty qualified as OP@@ -34,7 +34,7 @@   asum     [ stdinParser     , fileParser-    , socketUnixParser+    , socketParser     ]  where   stdinParser =@@ -51,13 +51,36 @@             <> O.metavar "FILE"             <> O.help "Read the eventlog from a file."         )+  socketParser =+    EventlogSourceOptionsSocket+      <$> asum+        [ socketUnixParser+        , socketInetParser+        ]   socketUnixParser =-    EventlogSourceOptionsSocketUnix+    EventlogSocketUnixAddr       <$> O.strOption         ( O.long "eventlog-socket"             <> O.metavar "SOCKET"             <> O.help "Read the eventlog from a Unix socket."         )+  socketInetParser =+    EventlogSocketInetAddr+      <$> socketInetHostParser+      <*> socketInetPortParser++  socketInetHostParser =+    O.strOption+      ( O.long "eventlog-socket-host"+          <> O.metavar "HOST"+          <> O.help "Read the eventlog from a TCP/IP socket."+      )+  socketInetPortParser =+    O.strOption+      ( O.long "eventlog-socket-port"+          <> O.metavar "PORT"+          <> O.help "Read the eventlog from a TCP/IP socket."+      )  {- | Parser for the intial timeout for exponential backoff.

@@ -8,7 +8,6 @@ -} module GHC.Eventlog.Live.Source (   Tick (..),-  tryConnect,   withEventlogSourceHandle,   runWithEventlogSourceHandle,   runWithEventlogSourceOptions,@@ -18,6 +17,7 @@ import Control.Exception (Exception (..)) import Control.Exception qualified as E import Data.Foldable (traverse_)+import Data.List.NonEmpty qualified as NE import Data.Machine (ProcessT, runT_, (~>)) import Data.Machine.Fanout (fanout) import Data.Maybe (fromMaybe)@@ -127,11 +127,11 @@         "Reading eventlog from " <> T.pack eventlogFile       IO.withBinaryFile eventlogFile IO.ReadMode $ \handle ->         action $ EventlogSourceHandleFile handle-    EventlogSourceOptionsSocketUnix eventlogSocketUnix -> do+    EventlogSourceOptionsSocket eventlogSocketAddr -> do       writeLog logger INFO $-        "Waiting to connect on " <> prettyEventlogSocketUnix eventlogSocketUnix-      E.bracket (connectRetry logger initialTimeoutS timeoutExponent eventlogSocketUnix) S.close $ \socket ->-        action $ EventlogSourceHandleSocketUnix socket+        "Waiting to connect on " <> prettyEventlogSocketAddr eventlogSocketAddr+      E.bracket (connectRetry logger initialTimeoutS timeoutExponent eventlogSocketAddr) S.close $ \socket ->+        action $ EventlogSourceHandleSocket socket  {- | Connect to the eventlog described by `EventlogSourceOptions` with retries and non-randomised exponential backoff.@@ -143,10 +143,10 @@   Double ->   -- | The timeout exponent for exponential backoff.   Double ->-  -- | The eventlog socket.-  FilePath ->+  -- | The eventlog socket address.+  EventlogSocketAddr ->   IO Socket-connectRetry logger initialTimeoutS timeoutExponent eventlogSocketUnix =+connectRetry logger initialTimeoutS timeoutExponent eventlogSocketAddr =   connectLoop initialTimeoutS  where   waitFor :: Double -> IO ()@@ -156,15 +156,15 @@   connectLoop timeoutS = do     let connect = do           writeLog logger DEBUG $-            "Trying to connect on " <> prettyEventlogSocketUnix eventlogSocketUnix-          handle <- tryConnect eventlogSocketUnix+            "Trying to connect on " <> prettyEventlogSocketAddr eventlogSocketAddr+          socket <- tryConnect eventlogSocketAddr           writeLog logger DEBUG $-            "Connected on " <> prettyEventlogSocketUnix eventlogSocketUnix-          pure handle+            "Connected on " <> prettyEventlogSocketAddr eventlogSocketAddr+          pure socket     let cleanup (e :: E.IOException) = do           writeLog logger DEBUG $             "Failed to connect on "-              <> prettyEventlogSocketUnix eventlogSocketUnix+              <> prettyEventlogSocketAddr eventlogSocketAddr               <> ": "               <> T.pack (displayException e)           writeLog logger DEBUG $@@ -175,16 +175,18 @@           connectLoop (timeoutS * timeoutExponent)     E.catch connect cleanup -{- |-Try to connect to a Unix socket.--}-tryConnect :: FilePath -> IO Socket-tryConnect eventlogSocketUnix =-  E.bracketOnError (S.socket S.AF_UNIX S.Stream S.defaultProtocol) S.close $ \socket -> do-    S.connect socket (S.SockAddrUnix eventlogSocketUnix)-    -- handle <- S.socketToHandle socket IO.ReadMode-    -- IO.hSetBuffering handle IO.NoBuffering-    pure socket+tryConnect :: EventlogSocketAddr -> IO Socket+tryConnect = \case+  EventlogSocketUnixAddr{..} -> do+    E.bracketOnError (S.socket S.AF_UNIX S.Stream S.defaultProtocol) S.close $ \socket -> do+      S.connect socket (S.SockAddrUnix esaUnixPath)+      pure socket+  EventlogSocketInetAddr{..} -> do+    let addrInfo = S.defaultHints{S.addrFamily = S.AF_UNSPEC, S.addrSocketType = S.Stream}+    addr <- NE.head <$> S.getAddrInfo (Just addrInfo) (Just esaInetHost) (Just $ esaInetPort)+    E.bracketOnError (S.socket (S.addrFamily addr) (S.addrSocketType addr) (S.addrProtocol addr)) S.close $ \socket -> do+      S.connect socket (S.addrAddress addr)+      pure socket  {- | Interal helper. Pretty-printer for timeout values in microseconds.@@ -201,7 +203,9 @@   | otherwise = T.pack $ printf "%.2f seconds" timeoutS  {- |-Internal helper. Pretty-printer for eventlog sockets.+Internal helper. Pretty-printer for eventlog socket addresses. -}-prettyEventlogSocketUnix :: FilePath -> Text-prettyEventlogSocketUnix eventlogSocketUnix = "Unix socket " <> T.pack eventlogSocketUnix+prettyEventlogSocketAddr :: EventlogSocketAddr -> Text+prettyEventlogSocketAddr = \case+  EventlogSocketUnixAddr{..} -> "Unix socket " <> T.pack esaUnixPath+  EventlogSocketInetAddr{..} -> "Inet socket " <> T.pack (esaInetHost <> ":" <> esaInetPort)

@@ -1,5 +1,6 @@ module GHC.Eventlog.Live.Source.Core (   EventlogSourceOptions (..),+  EventlogSocketAddr (..),   EventlogSourceHandle (..),   EventlogSourceData (..),   recv,@@ -22,15 +23,34 @@ data EventlogSourceOptions   = EventlogSourceOptionsStdin   | EventlogSourceOptionsFile FilePath-  | EventlogSourceOptionsSocketUnix FilePath+  | EventlogSourceOptionsSocket EventlogSocketAddr  {- |+The options for different kinds of eventlog sockets.+-}+data EventlogSocketAddr+  = EventlogSocketUnixAddr+      { esaUnixPath :: FilePath+      {- ^ Unix socket path, e.g., @"\/tmp\/ghc_eventlog.sock"@.++      __Warning:__ Unix domain socket paths are often limited to 107 characters or less.+      -}+      }+  | EventlogSocketInetAddr+      { esaInetHost :: String+      -- ^ TCP host or interface, e.g. @"127.0.0.1"@.+      , esaInetPort :: String+      -- ^ TCP port, e.g., @"4242"@.+      }+  deriving (Eq, Show)++{- | The handles for different kinds of eventlog sources. -} data EventlogSourceHandle   = EventlogSourceHandleStdin   | EventlogSourceHandleFile Handle-  | EventlogSourceHandleSocketUnix Socket+  | EventlogSourceHandleSocket Socket  data EventlogSourceData   = EventlogSourceData ByteString@@ -53,7 +73,7 @@ recv = \case   EventlogSourceHandleStdin -> recvFromHandle IO.stdin   EventlogSourceHandleFile h -> recvFromHandle h-  EventlogSourceHandleSocketUnix s -> recvFromSocket s+  EventlogSourceHandleSocket s -> recvFromSocket s  -- Permit a timeout and wrap the result appropriately. 

@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}++{- |+Module      : Data.Traversable.Compat+Description : Compatibility module for `mapAccumM`.+Copyright   : (c) 2012-2018 Simon Hengel,+              (c) 2014-2018 João Cristóvão,+              (c) 2015-2018 Ryan Scott+License     : MIT+Stability   : experimental+Portability : portable+-}+module Data.Traversable.Compat (+  mapAccumM,+) where++#if MIN_VERSION_base(4,18,0)+import Data.Traversable (mapAccumM)++#else+-- !MIN_VERSION_base(4,18,0)++import Control.Monad (liftM)+import Data.Coerce (Coercible, coerce)++-- | A state transformer monad parameterized by the state and inner monad.+-- The implementation is copied from the transformers package with the+-- return tuple swapped.+--+-- /Since: 4.18.0.0/+newtype StateT s m a = StateT { runStateT :: s -> m (s, a) }++-- | /Since: 4.18.0.0/+instance Monad m => Functor (StateT s m) where+    fmap = liftM+    {-# INLINE fmap #-}++-- | /Since: 4.18.0.0/+instance Monad m => Applicative (StateT s m) where+    pure a = StateT $ \ s -> return (s, a)+    {-# INLINE pure #-}+    StateT mf <*> StateT mx = StateT $ \ s -> do+        (s', f) <- mf s+        (s'', x) <- mx s'+        return (s'', f x)+    {-# INLINE (<*>) #-}+    m *> k = m >> k+    {-# INLINE (*>) #-}++(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)+(#.) _f = coerce++-- | /Since: 4.18.0.0/+instance (Monad m) => Monad (StateT s m) where+    m >>= k  = StateT $ \ s -> do+        (s', a) <- (.runStateT) m s+        (.runStateT) (k a) s'+    {-# INLINE (>>=) #-}+# if !(MIN_VERSION_base(4,11,0))+    return = pure+# endif++-- | The `mapAccumM` function behaves like a combination of `mapM` and+-- `mapAccumL` that traverses the structure while evaluating the actions+-- and passing an accumulating parameter from left to right.+-- It returns a final value of this accumulator together with the new structure.+-- The accummulator is often used for caching the intermediate results of a computation.+--+--  @since 4.18.0.0+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> let expensiveDouble a = putStrLn ("Doubling " <> show a) >> pure (2 * a)+-- >>> :{+-- mapAccumM (\cache a -> case lookup a cache of+--     Nothing -> expensiveDouble a >>= \double -> pure ((a, double):cache, double)+--     Just double -> pure (cache, double)+--     ) [] [1, 2, 3, 1, 2, 3]+-- :}+-- Doubling 1+-- Doubling 2+-- Doubling 3+-- ([(3,6),(2,4),(1,2)],[2,4,6,2,4,6])+--+mapAccumM+  :: forall m t s a b. (Monad m, Traversable t)+  => (s -> a -> m (s, b))+  -> s -> t a -> m (s, t b)+mapAccumM f s t = (.runStateT) (mapM (StateT #. flip f) t) s++-- !MIN_VERSION_base(4,18,0)+#endif