diff --git a/.gitignore b/.gitignore index c6e22175..87d00d01 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,8 @@ .env dist-newstyle/ *.eventlog +*.eventlog.json *.hp *.prof /nix/*/result +cabal.project.local diff --git a/cabal.project b/cabal.project index 53dca4fb..a5daa7be 100644 --- a/cabal.project +++ b/cabal.project @@ -13,6 +13,9 @@ packages: examples/oddball packages: examples/parfib packages: examples/spectral-norm +if impl(ghc >=9.10) + packages: examples/ecosim + source-repository-package type: git location: https://github.com/well-typed/eventlog-socket @@ -43,3 +46,28 @@ if impl(ghc >=9.4) allow-newer: , concurrent-machines-0.3.1.5:base , concurrent-machines-0.3.1.5:containers + +if impl(ghc >=9.12) + allow-newer: + , proto-lens-runtime:base + , proto-lens-runtime:containers + , proto-lens:base + , proto-lens:ghc-prim + +source-repository-package + type: git + location: https://github.com/fendor/hs-opentelemetry.git + tag: bc65d8a2e7d31f51226590d22af2a531b9363e2b + subdir: otlp + +if impl(ghc >=9.10) + source-repository-package + type: git + location: https://github.com/well-typed/ghc-stack-profiler.git + tag: 2fb2410b1abffa6be7b1d5e993ae089f5a61d2c9 + subdir: ghc-stack-profiler + + source-repository-package + type: git + location: https://github.com/well-typed/ghc-stack-annotations.git + tag: 0667af1cec1b20ba7fed4a5de675afe81a8ae07d diff --git a/dockerfiles/Dockerfile.ecosim b/dockerfiles/Dockerfile.ecosim new file mode 100644 index 00000000..59c6a295 --- /dev/null +++ b/dockerfiles/Dockerfile.ecosim @@ -0,0 +1,43 @@ +# syntax=docker/dockerfile:1.7-labs + +# To build this image, run: +# docker build --tag well-typed/eventlog-live-example-ecosim:0.1.0.0 --file ./dockerfiles/Dockerfile.ecosim . + +# Use the Haskell image with GHC 9.10 +# See: https://hub.docker.com/_/haskell +FROM haskell:9.10-slim-bullseye AS build + +# Configure eventlog-live +ARG GHC_EVENTLOG_SOCKET="/tmp/ghc_eventlog.sock" +ENV GHC_EVENTLOG_SOCKET=${GHC_EVENTLOG_SOCKET} + +# Copy required packages to container +WORKDIR "/eventlog-live" +COPY --parents \ + "./eventlog-live/" \ + "./examples/ecosim/" \ + "/eventlog-live/" + +# Create cabal.project file +COPY <=1.1 && <1.2 - , base >=4.16 && <4.22 - , bytestring >=0.11 && <0.13 - , data-default >=0.2 && <0.9 - , dlist >=1.0 && <1.1 - , eventlog-live >=0.5 && <0.6 - , eventlog-socket >=0.1.0 && <0.2 - , file-embed >=0.0.16 && <0.1 - , ghc-events >=0.20 && <0.21 - , grapesy >=1.0.0 && <1.2 - , hashable >=1.4 && <1.6 - , hs-opentelemetry-otlp >=0.1.0 && <0.2 - , HsYAML >=0.2 && <0.3 - , lens-family >=2.1.3 && <2.2 - , machines >=0.7.4 && <0.8 - , optparse-applicative >=0.17 && <0.20 - , proto-lens >=0.7.1 && <0.8 - , random >=1.2 && <1.4 - , stm >=2.5 && <2.6 - , strict-list >=0.1 && <0.2 - , table-layout >=1.0 && <1.1 - , text >=1.2 && <2.2 - , unordered-containers >=0.2.20 && <0.3 - , vector >=0.11 && <0.14 + , ansi-terminal >=1.1 && <1.2 + , base >=4.16 && <4.22 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.8 + , data-default >=0.2 && <0.9 + , dlist >=1.0 && <1.1 + , eventlog-live >=0.5 && <0.6 + , eventlog-socket >=0.1.0 && <0.2 + , file-embed >=0.0.16 && <0.1 + , ghc-events >=0.20 && <0.21 + , ghc-stack-profiler-core >=0.1 && <0.2 + , grapesy >=1.0.0 && <1.2 + , hashable >=1.4 && <1.6 + , hs-opentelemetry-otlp >=0.1.0 && <0.2 + , HsYAML >=0.2 && <0.3 + , lens-family >=2.1.3 && <2.2 + , machines >=0.7.4 && <0.8 + , optparse-applicative >=0.17 && <0.20 + , proto-lens >=0.7.1 && <0.8 + , random >=1.2 && <1.4 + , stm >=2.5 && <2.6 + , strict-list >=0.1 && <0.2 + , table-layout >=1.0 && <1.1 + , text >=1.2 && <2.2 + , transformers ^>=0.6.1 + , unordered-containers >=0.2.20 && <0.3 + , vector >=0.11 && <0.14 if flag(use-ghc-debug-stub) build-depends: ghc-debug-stub >=0.1 && <1.0 diff --git a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol.hs b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol.hs index c57e95b5..55b78438 100644 --- a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol.hs +++ b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol.hs @@ -52,6 +52,7 @@ import GHC.Eventlog.Live.Machine.Analysis.Capability qualified as M import GHC.Eventlog.Live.Machine.Analysis.Heap (MemReturnData (..)) import GHC.Eventlog.Live.Machine.Analysis.Heap qualified as M import GHC.Eventlog.Live.Machine.Analysis.Log qualified as M +import GHC.Eventlog.Live.Machine.Analysis.Profile qualified as M import GHC.Eventlog.Live.Machine.Analysis.Thread (ThreadStateSpan (..)) import GHC.Eventlog.Live.Machine.Analysis.Thread qualified as M import GHC.Eventlog.Live.Machine.Core (Tick) @@ -64,14 +65,16 @@ import GHC.Eventlog.Live.Otelcol.Config qualified as C import GHC.Eventlog.Live.Otelcol.Config.Default.Raw (defaultConfigJSONSchemaString, defaultConfigString) import GHC.Eventlog.Live.Otelcol.Exporter.Logs (exportResourceLogs) import GHC.Eventlog.Live.Otelcol.Exporter.Metrics (exportResourceMetrics) +import GHC.Eventlog.Live.Otelcol.Exporter.Profiles (exportResourceProfiles) import GHC.Eventlog.Live.Otelcol.Exporter.Traces (exportResourceSpans) +import GHC.Eventlog.Live.Otelcol.Processor.Profiles (processCallStackData) import GHC.Eventlog.Live.Otelcol.Stats (Stat (..), eventCountTick, processStats) import GHC.Eventlog.Live.Socket (runWithEventlogSource) import GHC.Eventlog.Socket qualified as Eventlog.Socket import GHC.RTS.Events (Event (..), HeapProfBreakdown (..), ThreadId) import GHC.Records (HasField (..)) import GHC.TypeLits (Symbol) -import Lens.Family2 ((&), (.~)) +import Lens.Family2 ((&), (.~), (^.)) import Network.GRPC.Client qualified as G import Network.GRPC.Common qualified as G import Options.Applicative qualified as O @@ -80,6 +83,8 @@ import Options.Applicative.Extra qualified as OE import Paths_eventlog_live_otelcol qualified as EventlogLive import Proto.Opentelemetry.Proto.Collector.Logs.V1.LogsService qualified as OLS import Proto.Opentelemetry.Proto.Collector.Metrics.V1.MetricsService qualified as OMS +import Proto.Opentelemetry.Proto.Collector.Profiles.V1development.ProfilesService qualified as OPS +import Proto.Opentelemetry.Proto.Collector.Profiles.V1development.ProfilesService_Fields qualified as OPS import Proto.Opentelemetry.Proto.Collector.Trace.V1.TraceService qualified as OTS import Proto.Opentelemetry.Proto.Collector.Trace.V1.TraceService_Fields qualified as OTS import Proto.Opentelemetry.Proto.Common.V1.Common qualified as OC @@ -88,6 +93,7 @@ import Proto.Opentelemetry.Proto.Logs.V1.Logs qualified as OL import Proto.Opentelemetry.Proto.Logs.V1.Logs_Fields qualified as OL import Proto.Opentelemetry.Proto.Metrics.V1.Metrics qualified as OM import Proto.Opentelemetry.Proto.Metrics.V1.Metrics_Fields qualified as OM +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles qualified as OP import Proto.Opentelemetry.Proto.Resource.V1.Resource qualified as OR import Proto.Opentelemetry.Proto.Trace.V1.Trace qualified as OT import Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields qualified as OT @@ -163,6 +169,9 @@ main = do , -- Process the thread events. processThreadEvents logger fullConfig ~> mapping (fmap (fmap (either TelemetryData'Metric TelemetryData'Span))) + , -- Process the thread events. + processProfileEvents logger fullConfig + ~> mapping (fmap (fmap TelemetryData'Profile)) ] ~> M.liftTick (asResourceTelemetryData eventlogResource eventlogLiveScope) @@ -225,11 +234,13 @@ data TelemetryData = TelemetryData'Log OL.LogRecord | TelemetryData'Metric OM.Metric | TelemetryData'Span OT.Span + | TelemetryData'Profile M.CallStackData data ResourceTelemetryData = ResourceTelemetryData'Log OL.ResourceLogs | ResourceTelemetryData'Metric OM.ResourceMetrics | ResourceTelemetryData'Span OT.ResourceSpans + | ResourceTelemetryData'Profile OP.ProfilesData {- | Internal helper. @@ -267,6 +278,12 @@ exportResourceTelemetryData fullConfig connection = ~> M.liftTick (mapping D.toList ~> asExportTracesServiceRequest) ~> exportResourceSpans connection ~> M.liftTick (mapping (D.singleton . ExportTraceResultStat)) + , -- Export profiles. + runIf (C.shouldExportProfiles fullConfig) $ + M.liftTick (mapping getResourceProfiles ~> asParts) + ~> M.liftTick asExportProfileServiceRequest + ~> exportResourceProfiles connection + ~> M.liftTick (mapping (D.singleton . ExportProfileResultStat)) ] getResourceLogs :: ResourceTelemetryData -> Maybe OL.ResourceLogs @@ -284,6 +301,11 @@ getResourceSpans = \case (ResourceTelemetryData'Span resourceSpans) -> Just resourceSpans _otherwise -> Nothing +getResourceProfiles :: ResourceTelemetryData -> Maybe OP.ProfilesData +getResourceProfiles = \case + (ResourceTelemetryData'Profile profilesData) -> Just profilesData + _otherwise -> Nothing + {- | Internal helper. Repack a stream of `TelemetryData` to batched `ResourceTelemetryData`. @@ -300,9 +322,9 @@ asResourceTelemetryData resource instrumentationScope = [TelemetryData] -> [ResourceTelemetryData] toResourceTelemetryData telemetryData = - catMaybes [maybeResourceLogs, maybeResourceMetrics, maybeResourceSpans] + catMaybes [maybeResourceLogs, maybeResourceMetrics, maybeResourceSpans, maybeProfiles] where - (logRecords, metrics, spans) = partitionTelemetryData telemetryData + (logRecords, metrics, spans, profiles) = partitionTelemetryData telemetryData maybeResourceLogs = do scopeLogs <- toScopeLogs instrumentationScope logRecords @@ -316,19 +338,31 @@ asResourceTelemetryData resource instrumentationScope = scopeSpans <- toScopeSpans instrumentationScope spans resourceSpans <- toResourceSpans resource [scopeSpans] pure $ ResourceTelemetryData'Span resourceSpans + maybeProfiles = do + (resourceProfile, dictionary) <- + ifNonEmpty + profiles + (processCallStackData resource instrumentationScope profiles) + pure $ + ResourceTelemetryData'Profile $ + messageWith + [ OPS.dictionary .~ dictionary + , OPS.resourceProfiles .~ [resourceProfile] + ] {- | Partition a stream of `TelemetryData` batches to individual batches for each kind of telemetry data. -} -partitionTelemetryData :: [TelemetryData] -> ([OL.LogRecord], [OM.Metric], [OT.Span]) -partitionTelemetryData = go ([], [], []) +partitionTelemetryData :: [TelemetryData] -> ([OL.LogRecord], [OM.Metric], [OT.Span], [M.CallStackData]) +partitionTelemetryData = go ([], [], [], []) where - go :: ([OL.LogRecord], [OM.Metric], [OT.Span]) -> [TelemetryData] -> ([OL.LogRecord], [OM.Metric], [OT.Span]) - go (logs, metrics, spans) = \case - [] -> (reverse logs, reverse metrics, reverse spans) - (TelemetryData'Log log : rest) -> go (log : logs, metrics, spans) rest - (TelemetryData'Metric metric : rest) -> go (logs, metric : metrics, spans) rest - (TelemetryData'Span span : rest) -> go (logs, metrics, span : spans) rest + go :: ([OL.LogRecord], [OM.Metric], [OT.Span], [M.CallStackData]) -> [TelemetryData] -> ([OL.LogRecord], [OM.Metric], [OT.Span], [M.CallStackData]) + go (logs, metrics, spans, profiles) = \case + [] -> (reverse logs, reverse metrics, reverse spans, reverse profiles) + (TelemetryData'Log log : rest) -> go (log : logs, metrics, spans, profiles) rest + (TelemetryData'Metric metric : rest) -> go (logs, metric : metrics, spans, profiles) rest + (TelemetryData'Span span : rest) -> go (logs, metrics, span : spans, profiles) rest + (TelemetryData'Profile profile : rest) -> go (logs, metrics, spans, profile : profiles) rest {- | Internal helper. @@ -729,10 +763,48 @@ runMetricProcessor MetricProcessor{..} fullConfig = ) {-# INLINE runMetricProcessor #-} +-------------------------------------------------------------------------------- +-- processProfileEvents +-------------------------------------------------------------------------------- + +processProfileEvents :: + (MonadIO m) => + Logger m -> + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList M.CallStackData)) +processProfileEvents logger config = + M.fanoutTick + [ processStackProfSample logger config + ] + +-------------------------------------------------------------------------------- +-- StackProfSample + +processStackProfSample :: + (MonadIO m) => + Logger m -> + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList M.CallStackData)) +processStackProfSample logger config = do + let + postProcessor = mapping M.stackProfSamples ~> asParts + dataProcessor = M.processStackProfSampleData logger + -- aggregators = viaLast + runIf (C.processorEnabled (.profiles) (.stackSample) config) $ + M.liftTick dataProcessor + -- ~> aggregate aggregators (C.processorAggregationBatches (.profiles) (.stackSample) config) + ~> M.liftTick postProcessor + -- TODO: do something with the Metric value, right now it is completely unused + ~> M.liftTick (mapping (D.singleton . (.value))) + ~> M.batchByTicks (C.processorExportBatches (.profiles) (.stackSample) config) + -------------------------------------------------------------------------------- -- Aggregation -------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Metric Aggregation + data Aggregators a b = Aggregators { nothing :: Process (Tick a) (Tick b) , byBatches :: Int -> Process (Tick a) (Tick b) @@ -820,6 +892,13 @@ asExportMetricsServiceRequest = mapping $ (defMessage &) . (OM.resourceMetrics . asExportTracesServiceRequest :: Process [OT.ResourceSpans] OTS.ExportTraceServiceRequest asExportTracesServiceRequest = mapping $ (defMessage &) . (OTS.resourceSpans .~) +asExportProfileServiceRequest :: Process OP.ProfilesData OPS.ExportProfilesServiceRequest +asExportProfileServiceRequest = mapping $ \profilesData -> + messageWith + [ OPS.resourceProfiles .~ profilesData ^. OPS.resourceProfiles + , OPS.dictionary .~ profilesData ^. OPS.dictionary + ] + toResourceLogs :: OR.Resource -> [OL.ScopeLogs] -> Maybe OL.ResourceLogs toResourceLogs resource scopeLogs = ifNonEmpty scopeLogs $ diff --git a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Config.hs b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Config.hs index d4c6bbae..19c0efe7 100644 --- a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Config.hs +++ b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Config.hs @@ -53,6 +53,12 @@ module GHC.Eventlog.Live.Otelcol.Config ( CapabilityUsageSpan (..), ThreadStateSpan (..), + -- *** Profiler processor configuration types + Profiles (..), + IsProfileProcessorConfig, + shouldExportProfiles, + StackSampleProfile (..), + -- ** Property types -- *** Aggregation strategy @@ -166,6 +172,10 @@ instance Default Traces where def :: Traces def = $(getDefault @'["processors", "traces"] defaultConfig) +instance Default Profiles where + def :: Profiles + def = $(getDefault @'["processors", "profiles"] defaultConfig) + -- NOTE: This should be kept in sync with the list of logs. -- Specifically, there should be a `Default` instance for every log. @@ -235,6 +245,13 @@ instance Default ThreadStateSpan where def :: ThreadStateSpan def = $(getDefault @'["processors", "traces", "threadState"] defaultConfig) +-- NOTE: This should be kept in sync with the list of profiles. +-- Specifically, there should be a `Default` instance for every profile. + +instance Default StackSampleProfile where + def :: StackSampleProfile + def = $(getDefault @'["processors", "profiles", "stackSample"] defaultConfig) + ------------------------------------------------------------------------------- -- Accessors ------------------------------------------------------------------------------- @@ -509,6 +526,17 @@ shouldExportTraces = ) . (.config) +shouldExportProfiles :: FullConfig -> Bool +shouldExportProfiles = + getAny + . with + (.processors) + ( with + (.profiles) + (mconcat . forEachProfileProcessor (Any . isEnabled . (.export))) + ) + . (.config) + ------------------------------------------------------------------------------- -- Functors for processor configurations ------------------------------------------------------------------------------- @@ -519,7 +547,8 @@ Apply a function to each processor. forEachProcessor :: ( forall processorConfig. (IsProcessorConfig processorConfig) => - processorConfig -> a + processorConfig -> + a ) -> Processors -> [a] @@ -528,6 +557,7 @@ forEachProcessor f processors = [ forEachLogProcessor f (fromMaybe def processors.logs) , forEachMetricProcessor f (fromMaybe def processors.metrics) , forEachTraceProcessor f (fromMaybe def processors.traces) + , forEachProfileProcessor f (fromMaybe def processors.profiles) ] {- | @@ -536,7 +566,8 @@ Apply a function to each metric processor. forEachLogProcessor :: ( forall traceProcessorConfig. (IsLogProcessorConfig traceProcessorConfig) => - traceProcessorConfig -> a + traceProcessorConfig -> + a ) -> Logs -> [a] @@ -554,7 +585,8 @@ Apply a function to each metric processor. forEachMetricProcessor :: ( forall metricProcessorConfig. (IsMetricProcessorConfig metricProcessorConfig) => - metricProcessorConfig -> a + metricProcessorConfig -> + a ) -> Metrics -> [a] @@ -577,7 +609,8 @@ Apply a function to each metric processor. forEachTraceProcessor :: ( forall traceProcessorConfig. (IsTraceProcessorConfig traceProcessorConfig) => - traceProcessorConfig -> a + traceProcessorConfig -> + a ) -> Traces -> [a] @@ -587,6 +620,22 @@ forEachTraceProcessor f traces = , f $ fromMaybe def traces.threadState ] +{- | +Apply a function to each metric processor. +-} +forEachProfileProcessor :: + ( forall profileProcessorConfig. + (IsProfileProcessorConfig profileProcessorConfig) => + profileProcessorConfig -> + a + ) -> + Profiles -> + [a] +forEachProfileProcessor f profiles = + [ -- NOTE: This should be kept in sync with the list of profiles. + f $ fromMaybe def profiles.stackSample + ] + ------------------------------------------------------------------------------- -- Internal Helpers ------------------------------------------------------------------------------- diff --git a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Config/Types.hs b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Config/Types.hs index dec561e5..355342f4 100644 --- a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Config/Types.hs +++ b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Config/Types.hs @@ -43,6 +43,11 @@ module GHC.Eventlog.Live.Otelcol.Config.Types ( CapabilityUsageSpan (..), ThreadStateSpan (..), + -- *** Profile processor configuration types + Profiles (..), + IsProfileProcessorConfig, + StackSampleProfile (..), + -- ** Property types Duration (..), AggregationStrategy (..), @@ -104,6 +109,7 @@ data Processors = Processors { logs :: Maybe Logs , metrics :: Maybe Metrics , traces :: Maybe Traces + , profiles :: Maybe Profiles } deriving (Lift) @@ -114,6 +120,7 @@ instance FromYAML Processors where <$> m .:? "logs" <*> m .:? "metrics" <*> m .:? "traces" + <*> m .:? "profiles" instance ToYAML Processors where toYAML :: Processors -> YAML.Node () @@ -122,6 +129,7 @@ instance ToYAML Processors where [ "logs" .= processors.logs , "metrics" .= processors.metrics , "traces" .= processors.traces + , "profiles" .= processors.profiles ] {- | @@ -253,6 +261,30 @@ instance ToYAML Traces where , "thread_state" .= traces.threadState ] +{- | +The configuration options for the profile processors. +-} +newtype Profiles = Profiles + { stackSample :: Maybe StackSampleProfile + } + deriving (Lift) + +instance FromYAML Profiles where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser Profiles + parseYAML = + -- NOTE: This should be kept in sync with the list of profiles. + YAML.withMap "Profiles" $ \m -> + Profiles + <$> m .:? "stack_sample" + +instance ToYAML Profiles where + toYAML :: Profiles -> YAML.Node () + toYAML profiles = + -- NOTE: This should be kept in sync with the list of profiles. + YAML.mapping + [ "stack_sample" .= profiles.stackSample + ] + ------------------------------------------------------------------------------- -- Logs ------------------------------------------------------------------------------- @@ -583,7 +615,7 @@ instance HasField "enabled" CapabilityUsageSpan Bool where getField = isEnabled . (.export) {- | -The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Thread.processThreadStateTraces`. +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Thread.processThreadStateSpan`. -} data ThreadStateSpan = ThreadStateSpan { name :: Maybe Text @@ -604,6 +636,28 @@ instance HasField "enabled" ThreadStateSpan Bool where getField :: ThreadStateSpan -> Bool getField = isEnabled . (.export) +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Profile.processStackProfSampleData`. +-} +data StackSampleProfile = StackSampleProfile + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift) + +instance FromYAML StackSampleProfile where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser StackSampleProfile + parseYAML = genericParseYAMLProfilerProcessorConfig "StackSampleProfile" StackSampleProfile + +instance ToYAML StackSampleProfile where + toYAML :: StackSampleProfile -> YAML.Node () + toYAML = genericToYAMLProfilerProcessorConfig + +instance HasField "enabled" StackSampleProfile Bool where + getField :: StackSampleProfile -> Bool + getField = isEnabled . (.export) + ------------------------------------------------------------------------------- -- Configuration supertypes ------------------------------------------------------------------------------- @@ -642,6 +696,13 @@ type IsTraceProcessorConfig :: Type -> Constraint type IsTraceProcessorConfig config = (IsProcessorConfig config) +{- | +The structural type of span processor configurations. +-} +type IsProfileProcessorConfig :: Type -> Constraint +type IsProfileProcessorConfig config = + (IsProcessorConfig config) + -------------------------------------------------------------------------------- -- Duration -------------------------------------------------------------------------------- @@ -879,3 +940,34 @@ genericToYAMLTraceProcessorConfig traceProcessorConfig = , "description" .= traceProcessorConfig.description , "export" .= traceProcessorConfig.export ] + +{- | +Internal helper. +Generic parser for processor configuration. +-} +genericParseYAMLProfilerProcessorConfig :: + String -> + (Maybe Text -> Maybe Text -> Maybe ExportStrategy -> profilerConfig) -> + YAML.Node YAML.Pos -> + YAML.Parser profilerConfig +genericParseYAMLProfilerProcessorConfig trace mkProfilerConfig = + YAML.withMap trace $ \m -> + mkProfilerConfig + <$> m .:? "name" + <*> m .:? "description" + <*> m .:? "export" + +{- | +Internal helper. +Generic parser for metric configuration. +-} +genericToYAMLProfilerProcessorConfig :: + (IsTraceProcessorConfig profilerConfig) => + profilerConfig -> + YAML.Node () +genericToYAMLProfilerProcessorConfig profilerConfig = + YAML.mapping + [ "name" .= profilerConfig.name + , "description" .= profilerConfig.description + , "export" .= profilerConfig.export + ] diff --git a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Exporter/Profiles.hs b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Exporter/Profiles.hs new file mode 100644 index 00000000..339954f7 --- /dev/null +++ b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Exporter/Profiles.hs @@ -0,0 +1,128 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.Eventlog.Live.Otelcol.Exporter.Profiles ( + -- * Profiles + ExportProfileResult (..), + RejectedProfilesError (..), + exportResourceProfiles, +) +where + +import Control.Exception (Exception (..), SomeException (..), catch) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Int (Int64) +import Data.Machine (ProcessT, await, construct, yield) +import Data.Semigroup (Sum (..)) +import Data.Text (Text) +import Data.Vector qualified as V +import GHC.Eventlog.Live.Machine.Core (Tick (..)) +import Lens.Family2 ((^.)) +import Network.GRPC.Client qualified as G +import Network.GRPC.Client.StreamType.IO qualified as G +import Network.GRPC.Common qualified as G +import Network.GRPC.Common.Protobuf (Protobuf) +import Network.GRPC.Common.Protobuf qualified as G +import Proto.Opentelemetry.Proto.Collector.Profiles.V1development.ProfilesService qualified as OPS +import Proto.Opentelemetry.Proto.Collector.Profiles.V1development.ProfilesService_Fields qualified as OPS +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles qualified as OP +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles_Fields qualified as OP +import Text.Printf (printf) + +data ExportProfileResult + = ExportProfileResult + { exportedProfiles :: !Int64 + , rejectedProfiles :: !Int64 + , maybeSomeException :: Maybe SomeException + } + deriving (Show) + +pattern ExportProfileSuccess :: Int64 -> ExportProfileResult +pattern ExportProfileSuccess exportedProfiles = + ExportProfileResult exportedProfiles 0 Nothing + +pattern ExportProfileError :: Int64 -> Int64 -> SomeException -> ExportProfileResult +pattern ExportProfileError exportedProfiles rejectedProfiles someException = + ExportProfileResult exportedProfiles rejectedProfiles (Just someException) + +data RejectedProfilesError + = RejectedProfilesError + { rejectedProfiles :: !Int64 + , errorMessage :: !Text + } + deriving (Show) + +instance Exception RejectedProfilesError where + displayException :: RejectedProfilesError -> String + displayException RejectedProfilesError{..} = + printf "Error: OpenTelemetry Collector rejectedProfiles %d data points with message: %s" rejectedProfiles errorMessage + +-------------------------------------------------------------------------------- +-- OpenTelemetry gRPC Exporter for Profiles + +exportResourceProfiles :: + G.Connection -> + ProcessT IO (Tick OPS.ExportProfilesServiceRequest) (Tick ExportProfileResult) +exportResourceProfiles conn = + construct $ go False + where + go exportedProfiles = + await >>= \case + Tick -> do + unless exportedProfiles $ + yield (Item $ ExportProfileSuccess 0) + yield Tick + go False + Item exportProfilesServiceRequest -> do + exportTraceResult <- liftIO (sendResourceProfiles exportProfilesServiceRequest) + yield (Item exportTraceResult) + go True + + sendResourceProfiles :: OPS.ExportProfilesServiceRequest -> IO ExportProfileResult + sendResourceProfiles exportProfilesServiceRequest = + doGrpc `catch` handleSomeException + where + !exportedProfiles = countSamplesInExportProfileServiceRequest exportProfilesServiceRequest + + doGrpc :: IO ExportProfileResult + doGrpc = do + G.nonStreaming conn (G.rpc @(Protobuf OPS.ProfilesService "export")) (G.Proto exportProfilesServiceRequest) >>= \case + G.Proto resp + | resp ^. OPS.partialSuccess . OPS.rejectedProfiles == 0 -> + pure $ ExportProfileSuccess exportedProfiles + | otherwise -> do + let !rejectedProfiles = resp ^. OPS.partialSuccess . OPS.rejectedProfiles + let !rejectedMetricsError = RejectedProfilesError{errorMessage = resp ^. OPS.partialSuccess . OPS.errorMessage, ..} + pure $ ExportProfileError exportedProfiles rejectedProfiles (SomeException rejectedMetricsError) + + handleSomeException :: SomeException -> IO ExportProfileResult + handleSomeException someException = pure $ ExportProfileError 0 exportedProfiles someException + +type instance G.RequestMetadata (Protobuf OPS.ProfilesService meth) = G.NoMetadata + +type instance G.ResponseInitialMetadata (Protobuf OPS.ProfilesService meth) = G.NoMetadata + +type instance G.ResponseTrailingMetadata (Protobuf OPS.ProfilesService meth) = G.NoMetadata + +{- | +Internal helper. +Count the number of 'OP.Sample' values in an 'OPS.ExportProfilesServiceRequest'. +-} +{-# SPECIALIZE countSamplesInExportProfileServiceRequest :: OPS.ExportProfilesServiceRequest -> Int64 #-} +{-# SPECIALIZE countSamplesInExportProfileServiceRequest :: OPS.ExportProfilesServiceRequest -> Word #-} +countSamplesInExportProfileServiceRequest :: (Integral i) => OPS.ExportProfilesServiceRequest -> i +countSamplesInExportProfileServiceRequest exportProfileServiceRequest = + getSum $ foldMap (Sum . countSamplesInResourceProfiles) (exportProfileServiceRequest ^. OPS.vec'resourceProfiles) + +countSamplesInResourceProfiles :: (Integral i) => OP.ResourceProfiles -> i +countSamplesInResourceProfiles resourceProfiles = + getSum $ foldMap (Sum . countSamplesInScopeProfiles) (resourceProfiles ^. OP.vec'scopeProfiles) + +countSamplesInScopeProfiles :: (Integral i) => OP.ScopeProfiles -> i +countSamplesInScopeProfiles scopeProfiles = + getSum $ foldMap (Sum . countSamplesInProfile) (scopeProfiles ^. OP.vec'profiles) + +countSamplesInProfile :: (Integral i) => OP.Profile -> i +countSamplesInProfile profile = + fromIntegral $ + V.length (profile ^. OP.vec'samples) diff --git a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles.hs b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles.hs new file mode 100644 index 00000000..32cf2d2b --- /dev/null +++ b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otelcol.Processor.Profiles.Dictionary +Description : Profile Processors for OTLP. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otelcol.Processor.Profiles ( + processCallStackData, +) +where + +import Control.Monad.Trans.State.Strict (State, runState) +import Data.ProtoLens (Message (defMessage)) +import Data.Text (Text) +import GHC.Eventlog.Live.Machine.Analysis.Heap qualified as M +import GHC.Eventlog.Live.Machine.Analysis.Profile qualified as M +import GHC.Eventlog.Live.Otelcol.Processor.Profiles.Dictionary (ProfileDictionary, SymbolIndex) +import GHC.Eventlog.Live.Otelcol.Processor.Profiles.Dictionary qualified as ProfDictionary +import GHC.Stack.Profiler.Core.SourceLocation qualified as Profiler +import Lens.Family2 ((.~)) +import Proto.Opentelemetry.Proto.Common.V1.Common qualified as OC +import Proto.Opentelemetry.Proto.Common.V1.Common_Fields qualified as OC +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles qualified as OP +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles_Fields qualified as OP +import Proto.Opentelemetry.Proto.Resource.V1.Resource qualified as OR + +processCallStackData :: OR.Resource -> OC.InstrumentationScope -> [M.CallStackData] -> (OP.ResourceProfiles, OP.ProfilesDictionary) +processCallStackData resource instrumentationScope callstacks = + let (profile, st) = flip runState ProfDictionary.emptyProfileDictionary $ do + sampleNameStrId <- ProfDictionary.getString "__name__" + sampleTypeStrId <- ProfDictionary.getString "String" + sampleAttrId <- + ProfDictionary.getAttribute $ + messageWith @OP.KeyValueAndUnit + [ OP.keyStrindex .~ sampleNameStrId + , OP.unitStrindex .~ sampleTypeStrId + , OP.value .~ messageWith [OC.stringValue .~ "process_cpu"] + ] + + samples <- traverse (asSample sampleAttrId) callstacks + cpuId <- ProfDictionary.getString "stack" + unitId <- ProfDictionary.getString "samples" + let sampleType :: OP.ValueType + sampleType = + messageWith + [ OP.typeStrindex .~ cpuId + , OP.unitStrindex .~ unitId + ] + + pure $ + messageWith + [ OP.samples .~ samples + , OP.sampleType .~ sampleType + ] + + scopedProfiles = + messageWith + [ OP.profiles .~ [profile] + , OP.scope .~ instrumentationScope + ] + + resourceProfiles = + messageWith + [ OP.scopeProfiles .~ [scopedProfiles] + , OP.resource .~ resource + ] + + profilesDictionary = ProfDictionary.toProfilesDictionary st + in (resourceProfiles, profilesDictionary) + +asSample :: SymbolIndex -> M.CallStackData -> State ProfileDictionary OP.Sample +asSample six stackData = do + locIndices <- traverse toIndex stackData.stack + s <- + ProfDictionary.getStack $ + messageWith + [ OP.locationIndices .~ locIndices + ] + + sampleThreadKeyStrId <- ProfDictionary.getString "thread" + sampleThreadUnitStrId <- ProfDictionary.getString "Number" + + threadAttrId <- + ProfDictionary.getAttribute $ + messageWith @OP.KeyValueAndUnit + [ OP.keyStrindex .~ sampleThreadKeyStrId + , OP.unitStrindex .~ sampleThreadUnitStrId + , OP.value .~ messageWith [OC.intValue .~ fromIntegral stackData.threadId] + ] + + pure $ + messageWith + [ OP.values .~ [1] + , OP.stackIndex .~ s + , OP.attributeIndices .~ [six, threadAttrId] + ] + where + toIndex :: M.StackItemData -> State ProfileDictionary SymbolIndex + toIndex = \case + M.IpeData infoTable -> getLocationIndexForInfoTable infoTable + M.UserMessageData message -> getLocationIndexForText message + M.SourceLocationData srcLoc -> getLocationIndexForSourceLocation srcLoc + +getLocationIndexForSourceLocation :: Profiler.SourceLocation -> State ProfileDictionary SymbolIndex +getLocationIndexForSourceLocation srcLoc = do + functionNameId <- ProfDictionary.getString $ Profiler.functionName srcLoc + fileNameId <- ProfDictionary.getString $ Profiler.fileName srcLoc + funcIdx <- + ProfDictionary.getFunction $ + messageWith + [ OP.nameStrindex .~ functionNameId + , OP.systemNameStrindex .~ 0 -- 0 means unset + , OP.filenameStrindex .~ fileNameId + , OP.startLine .~ fromIntegral (Profiler.line srcLoc) -- TODO: better casts + ] + + let line :: OP.Line + line = + messageWith + [ OP.functionIndex .~ funcIdx + , OP.line .~ fromIntegral (Profiler.line srcLoc) + , OP.column .~ fromIntegral (Profiler.column srcLoc) + ] + + ProfDictionary.getLocation $ + messageWith + [ OP.lines .~ [line] + , OP.mappingIndex .~ 0 -- 0 means unset + ] + +getLocationIndexForText :: Text -> State ProfileDictionary SymbolIndex +getLocationIndexForText msg = do + textId <- ProfDictionary.getString msg + funcIdx <- + ProfDictionary.getFunction $ + messageWith + [ OP.nameStrindex .~ textId + , OP.systemNameStrindex .~ 0 -- 0 means unset + , OP.filenameStrindex .~ 0 -- 0 means unset + , OP.startLine .~ 0 -- 0 means unset + ] + + let line :: OP.Line + line = + messageWith + [ OP.functionIndex .~ funcIdx + , OP.line .~ 0 -- 0 means unset + , OP.column .~ 0 -- 0 means unset + ] + + ProfDictionary.getLocation $ + messageWith + [ OP.lines .~ [line] + ] + +getLocationIndexForInfoTable :: M.InfoTable -> State ProfileDictionary SymbolIndex +getLocationIndexForInfoTable infoTable = do + infoTableNameId <- ProfDictionary.getString infoTable.infoTableName + let label = + if (infoTable.infoTableLabel) == "" + then infoTable.infoTableModule <> ":" <> infoTable.infoTableName + else infoTable.infoTableModule <> ":" <> infoTable.infoTableLabel + infoTableFuncNameId <- ProfDictionary.getString label + -- tyDesc <- getText infoTable.infoTableTyDesc + -- + infoTableSrcLocId <- ProfDictionary.getString infoTable.infoTableSrcLoc + funcIdx <- + ProfDictionary.getFunction $ + messageWith + [ OP.nameStrindex .~ infoTableFuncNameId + , OP.systemNameStrindex .~ infoTableNameId + , OP.filenameStrindex .~ infoTableSrcLocId -- 0 means unset + , OP.startLine .~ 0 -- 0 means unset + ] + + let line :: OP.Line + line = + messageWith + [ OP.functionIndex .~ funcIdx + , OP.line .~ 0 -- 0 means unset + , OP.column .~ 0 -- 0 means unset + ] + + ProfDictionary.getLocation $ + messageWith + [ OP.lines .~ [line] + , OP.address .~ 0 -- 0 means unset + ] + +-------------------------------------------------------------------------------- +-- DSL for writing messages + +-- | Construct a message with a list of modifications applied. +messageWith :: (Message msg) => [msg -> msg] -> msg +messageWith = foldr ($) defMessage diff --git a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles/Dictionary.hs b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles/Dictionary.hs new file mode 100644 index 00000000..0dd72d88 --- /dev/null +++ b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles/Dictionary.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otelcol.Processor.Profiles.Dictionary +Description : Abstraction over ProfilesDictionary for the OTLP protocol. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otelcol.Processor.Profiles.Dictionary ( + -- * Dictionary for deduplication logic of common values + ProfileDictionary, + emptyProfileDictionary, + + -- * Turn a 'ProfileDictionary' into a 'OP.ProfilesDictionary' + toProfilesDictionary, + + -- * Retrieve the 'SymbolIndex' for various 'OP.ProfilesData' fields + SymbolIndex, + getLocation, + getFunction, + getString, + getMapping, + getLink, + getAttribute, + getStack, +) +where + +import Control.Monad.Trans.State.Strict (StateT) +import Control.Monad.Trans.State.Strict qualified as State +import Data.Int +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.ProtoLens +import Data.Text (Text) +import GHC.Generics +import Lens.Family2 +import Lens.Family2.Unchecked +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles qualified as OP +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles_Fields qualified as OP + +type SymbolIndex = Int32 + +data ProfileDictionary = ProfileDictionary + { locationTable :: CommonSymbolTable OP.Location + {- ^ Common 'OP.Location' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , functionTable :: CommonSymbolTable OP.Function + {- ^ Common 'OP.Function' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , stringTable :: CommonSymbolTable Text + {- ^ Common string table, the first entry must be "" per the protobuf + documentation. + + @ + // A common table for strings referenced by various messages. + // string_table[0] must always be "". + repeated string string_table = 5; + @ + -} + , mappingTable :: CommonSymbolTable OP.Mapping + {- ^ Common 'OP.Mapping' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , linkTable :: CommonSymbolTable OP.Link + {- ^ Common 'OP.Link' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , attributeTable :: CommonSymbolTable OP.KeyValueAndUnit + {- ^ Common 'OP.KeyValueAndUnit' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , stackTable :: CommonSymbolTable OP.Stack + {- ^ Common 'OP.Stack' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + } + deriving (Show, Ord, Eq, Generic) + +toProfilesDictionary :: ProfileDictionary -> OP.ProfilesDictionary +toProfilesDictionary st = + defMessage + & OP.locationTable + .~ locationTableList st + & OP.functionTable + .~ functionTableList st + & OP.stringTable + .~ stringTableList st + & OP.mappingTable + .~ mappingTableList st + & OP.linkTable + .~ linkTableList st + & OP.attributeTable + .~ attributeTableList st + & OP.stackTable + .~ stackTableList st + +emptyProfileDictionary :: ProfileDictionary +emptyProfileDictionary = + ProfileDictionary + { locationTable = commonSymbolTableFromList [defMessage] + , functionTable = commonSymbolTableFromList [defMessage] + , stringTable = commonSymbolTableFromList [""] + , mappingTable = commonSymbolTableFromList [defMessage] + , linkTable = commonSymbolTableFromList [defMessage] + , attributeTable = commonSymbolTableFromList [defMessage] + , stackTable = commonSymbolTableFromList [defMessage] + } + +locationTableList :: ProfileDictionary -> [OP.Location] +locationTableList st = reverse st.locationTable.contents + +functionTableList :: ProfileDictionary -> [OP.Function] +functionTableList st = reverse st.functionTable.contents + +stringTableList :: ProfileDictionary -> [Text] +stringTableList st = reverse st.stringTable.contents + +mappingTableList :: ProfileDictionary -> [OP.Mapping] +mappingTableList st = reverse st.mappingTable.contents + +linkTableList :: ProfileDictionary -> [OP.Link] +linkTableList st = reverse st.linkTable.contents + +attributeTableList :: ProfileDictionary -> [OP.KeyValueAndUnit] +attributeTableList st = reverse st.attributeTable.contents + +stackTableList :: ProfileDictionary -> [OP.Stack] +stackTableList st = reverse st.stackTable.contents + +getSymbolIndexFor :: (Ord a, Monad m) => Lens' ProfileDictionary (CommonSymbolTable a) -> a -> StateT ProfileDictionary m SymbolIndex +getSymbolIndexFor accessor a = do + tbl <- State.gets (^. accessor) + let (idx, tbl1) = insertCommonSymbolTable a tbl + State.modify' (\st -> st & accessor .~ tbl1) + pure idx + +getLocation :: (Monad m) => OP.Location -> StateT ProfileDictionary m SymbolIndex +getLocation = getSymbolIndexFor (lens (.locationTable) (\s v -> s{locationTable = v})) + +getFunction :: (Monad m) => OP.Function -> StateT ProfileDictionary m SymbolIndex +getFunction = getSymbolIndexFor (lens (.functionTable) (\s v -> s{functionTable = v})) + +getString :: (Monad m) => Text -> StateT ProfileDictionary m SymbolIndex +getString = getSymbolIndexFor (lens (.stringTable) (\s v -> s{stringTable = v})) + +getMapping :: (Monad m) => OP.Mapping -> StateT ProfileDictionary m SymbolIndex +getMapping = getSymbolIndexFor (lens (.mappingTable) (\s v -> s{mappingTable = v})) + +getLink :: (Monad m) => OP.Link -> StateT ProfileDictionary m SymbolIndex +getLink = getSymbolIndexFor (lens (.linkTable) (\s v -> s{linkTable = v})) + +getAttribute :: (Monad m) => OP.KeyValueAndUnit -> StateT ProfileDictionary m SymbolIndex +getAttribute = getSymbolIndexFor (lens (.attributeTable) (\s v -> s{attributeTable = v})) + +getStack :: (Monad m) => OP.Stack -> StateT ProfileDictionary m SymbolIndex +getStack = getSymbolIndexFor (lens (.stackTable) (\s v -> s{stackTable = v})) + +------------------------------------------------------------------------------- +-- Common Symbol Table implementation +-- TODO: share with `ghc-stack-profiler-core` table? + +data CommonSymbolTable a + = CommonSymbolTable + { counter :: !SymbolIndex + , table :: Map a SymbolIndex + , contents :: ![a] + } + deriving (Show, Ord, Eq, Generic) + +emptyCommonSymbolTable :: CommonSymbolTable a +emptyCommonSymbolTable = + CommonSymbolTable + { counter = 0 + , table = Map.empty + , contents = [] + } + +commonSymbolTableFromList :: (Ord a) => [a] -> CommonSymbolTable a +commonSymbolTableFromList = foldr go emptyCommonSymbolTable + where + go val tbl0 = + let (_, tbl1) = insertCommonSymbolTable val tbl0 + in tbl1 + +nextCounter :: CommonSymbolTable a -> (SymbolIndex, CommonSymbolTable a) +nextCounter tbl = (tbl.counter, tbl{counter = tbl.counter + 1}) + +insertCommonSymbolTable :: (Ord a) => a -> CommonSymbolTable a -> (SymbolIndex, CommonSymbolTable a) +insertCommonSymbolTable val tbl = + let updateEntry tbl0 Nothing = + let (sid, newTbl) = nextCounter tbl0 + in ((sid, True, newTbl), Just sid) + updateEntry newTbl (Just old) = + ((old, False, newTbl), Just old) + + ((idx, newEntry, tbl1), newTable) = Map.alterF (updateEntry tbl) val tbl.table + in ( idx + , tbl1 + { table = newTable + , contents = + if newEntry + then val : tbl1.contents + else tbl1.contents + } + ) diff --git a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Stats.hs b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Stats.hs index 5fcce94a..6006aace 100644 --- a/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Stats.hs +++ b/eventlog-live-otelcol/src/GHC/Eventlog/Live/Otelcol/Stats.hs @@ -11,7 +11,8 @@ module GHC.Eventlog.Live.Otelcol.Stats ( eventCountTick, Stat (..), processStats, -) where +) +where import Control.Exception (Exception (..)) import Control.Monad (when) @@ -31,6 +32,7 @@ import GHC.Eventlog.Live.Machine.Core (Tick) import GHC.Eventlog.Live.Machine.Core qualified as M import GHC.Eventlog.Live.Otelcol.Exporter.Logs (ExportLogsResult (..)) import GHC.Eventlog.Live.Otelcol.Exporter.Metrics (ExportMetricsResult (..)) +import GHC.Eventlog.Live.Otelcol.Exporter.Profiles (ExportProfileResult (..)) import GHC.Eventlog.Live.Otelcol.Exporter.Traces (ExportTraceResult (..)) import GHC.Records (HasField (..)) import StrictList qualified as Strict @@ -66,6 +68,7 @@ data Stat | ExportLogsResultStat !ExportLogsResult | ExportMetricsResultStat !ExportMetricsResult | ExportTraceResultStat !ExportTraceResult + | ExportProfileResultStat !ExportProfileResult deriving (Show) {- | @@ -80,6 +83,8 @@ data Stats = Stats , rejectedDataPoints :: Row , exportedSpans :: Row , rejectedSpans :: Row + , exportedProfiles :: Row + , rejectedProfiles :: Row , errors :: !(Strict.List Text) , displayedLines :: !(First Int) } @@ -146,6 +151,8 @@ unionStats windowSize new old = Stats{..} rejectedDataPoints = unionRow windowSize new.rejectedDataPoints old.rejectedDataPoints exportedSpans = unionRow windowSize new.exportedSpans old.exportedSpans rejectedSpans = unionRow windowSize new.rejectedSpans old.rejectedSpans + exportedProfiles = unionRow windowSize new.exportedProfiles old.exportedProfiles + rejectedProfiles = unionRow windowSize new.rejectedProfiles old.rejectedProfiles errors = Strict.take windowSize (new.errors <> old.errors) displayedLines = new.displayedLines <> old.displayedLines @@ -192,6 +199,18 @@ fromExportTraceResult exportTracesResult = , errors = maybeToStrictList $ T.pack . displayException <$> exportTracesResult.maybeSomeException } +{- | +Internal helper. +Construct a `Stats` object from an `ExportProfileResult`. +-} +fromExportProfileResult :: ExportProfileResult -> Stats +fromExportProfileResult exportProfileResult = + def + { exportedProfiles = singletonRow exportProfileResult.exportedProfiles + , rejectedProfiles = singletonRow exportProfileResult.rejectedProfiles + , errors = maybeToStrictList $ T.pack . displayException <$> exportProfileResult.maybeSomeException + } + {- | Internal helper. Construct a singleton `Strict.List`. @@ -233,6 +252,8 @@ instance Default Stats where rejectedDataPoints = def exportedSpans = def rejectedSpans = def + exportedProfiles = def + rejectedProfiles = def errors = mempty displayedLines = First Nothing @@ -275,6 +296,7 @@ updateStats windowSize old = \case ExportLogsResultStat exportLogsResults -> unionStats windowSize (fromExportLogsResult exportLogsResults) old ExportMetricsResultStat exportMetricsResult -> unionStats windowSize (fromExportMetricsResult exportMetricsResult) old ExportTraceResultStat exportTracesResult -> unionStats windowSize (fromExportTraceResult exportTracesResult) old + ExportProfileResultStat exportProfilesResult -> unionStats windowSize (fromExportProfileResult exportProfilesResult) old {- | Internal helper. @@ -332,6 +354,20 @@ logStat logger = \case writeLog logger ERROR $ T.pack $ displayException someException + ExportProfileResultStat exportProfileResult -> do + -- Log exported events. + when (exportProfileResult.exportedProfiles > 0) $ + writeLog logger DEBUG $ + "Exported " <> showText exportProfileResult.exportedProfiles <> " profiles." + -- Log rejected events. + when (exportProfileResult.rejectedProfiles > 0) $ + writeLog logger ERROR $ + "Rejected " <> showText exportProfileResult.rejectedProfiles <> " profiles." + -- Log exception. + for_ exportProfileResult.maybeSomeException $ \someException -> do + writeLog logger ERROR $ + T.pack $ + displayException someException {- | Internal helper. @@ -379,6 +415,8 @@ displayStats logger eventlogFlushIntervalS stats = do , mkRow Nothing (Just "Rejected") stats.rejectedDataPoints , mkRow (Just "Traces") (Just "Exported") stats.exportedSpans , mkRow Nothing (Just "Rejected") stats.rejectedSpans + , mkRow (Just "Profile") (Just "Exported") stats.exportedProfiles + , mkRow Nothing (Just "Rejected") stats.rejectedProfiles ] let tSpec :: TBL.TableSpec TBL.LineStyle TBL.LineStyle String (Maybe Text) (Maybe Text) tSpec = TBL.columnHeaderTableS cSpec TBL.unicodeS hSpec rSpec diff --git a/eventlog-live/eventlog-live.cabal b/eventlog-live/eventlog-live.cabal index be60d0bb..b1a0d9c1 100644 --- a/eventlog-live/eventlog-live.cabal +++ b/eventlog-live/eventlog-live.cabal @@ -115,6 +115,7 @@ library GHC.Eventlog.Live.Machine.Analysis.Capability GHC.Eventlog.Live.Machine.Analysis.Heap GHC.Eventlog.Live.Machine.Analysis.Log + GHC.Eventlog.Live.Machine.Analysis.Profile GHC.Eventlog.Live.Machine.Analysis.Thread GHC.Eventlog.Live.Machine.Core GHC.Eventlog.Live.Machine.Decoder @@ -125,22 +126,24 @@ library GHC.Eventlog.Live.Socket build-depends: - , ansi-terminal >=1.1 && <1.2 - , base >=4.16 && <4.22 - , bytestring >=0.11 && <0.13 - , clock >=0.8 && <0.9 - , co-log-core >=0.3 && <0.4 - , dlist >=1.0 && <1.1 - , ghc-events >=0.20 && <0.21 - , hashable >=1.4 && <1.6 - , machines >=0.7.4 && <0.8 - , monad-control >=1.0 && <1.1 - , network >=3.2.7 && <3.3 - , optparse-applicative >=0.17 && <0.20 - , stm >=2.5 && <2.6 - , text >=1.2 && <2.2 - , transformers >=0.2 && <0.7 - , unordered-containers >=0.2.20 && <0.3 + , ansi-terminal >=1.1 && <1.2 + , base >=4.16 && <4.22 + , bytestring >=0.11 && <0.13 + , clock >=0.8 && <0.9 + , co-log-core >=0.3 && <0.4 + , containers >=0.6 && <0.8 + , dlist >=1.0 && <1.1 + , ghc-events >=0.20 && <0.21 + , ghc-stack-profiler-core >=0.1 && <0.2 + , hashable >=1.4 && <1.6 + , machines >=0.7.4 && <0.8 + , monad-control >=1.0 && <1.1 + , network >=3.2.7 && <3.3 + , optparse-applicative >=0.17 && <0.20 + , stm >=2.5 && <2.6 + , text >=1.2 && <2.2 + , transformers >=0.2 && <0.7 + , unordered-containers >=0.2.20 && <0.3 -- 2025-12-09: -- This configures the build requirements for the vendored copy of diff --git a/eventlog-live/src/GHC/Eventlog/Live/Data/Attribute.hs b/eventlog-live/src/GHC/Eventlog/Live/Data/Attribute.hs index 7f38b68b..c764ba53 100644 --- a/eventlog-live/src/GHC/Eventlog/Live/Data/Attribute.hs +++ b/eventlog-live/src/GHC/Eventlog/Live/Data/Attribute.hs @@ -7,6 +7,7 @@ Portability : portable module GHC.Eventlog.Live.Data.Attribute ( Attrs, lookup, + empty, toList, Attr, AttrKey, @@ -35,12 +36,18 @@ newtype Attrs = Attrs {attrMap :: HashMap AttrKey AttrValue} lookup :: AttrKey -> Attrs -> Maybe AttrValue lookup attrKey attrs = M.lookup attrKey attrs.attrMap +empty :: Attrs +empty = Attrs mempty + instance Hashable Attrs instance Semigroup Attrs where (<>) :: Attrs -> Attrs -> Attrs x <> y = Attrs{attrMap = x.attrMap <> y.attrMap} +instance Monoid Attrs where + mempty = empty + instance IsList Attrs where type Item Attrs = Attr diff --git a/eventlog-live/src/GHC/Eventlog/Live/Data/Metric.hs b/eventlog-live/src/GHC/Eventlog/Live/Data/Metric.hs index 87ae680f..a8bc746e 100644 --- a/eventlog-live/src/GHC/Eventlog/Live/Data/Metric.hs +++ b/eventlog-live/src/GHC/Eventlog/Live/Data/Metric.hs @@ -24,17 +24,18 @@ import GHC.RTS.Events (Timestamp) {- | Metrics combine a measurement with a timestamp representing the time of the -measurement, a timestamp representing the earliest possible measurment, and +measurement, a timestamp representing the earliest possible measurement, and a list of attributes. -} data Metric a = Metric { value :: !a -- ^ The measurement. , maybeTimeUnixNano :: !(Maybe Timestamp) - -- ^ The time at which the measurment was taken. + -- ^ 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. } diff --git a/eventlog-live/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs b/eventlog-live/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs index 0accead4..e12cf142 100644 --- a/eventlog-live/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs +++ b/eventlog-live/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs @@ -23,6 +23,11 @@ module GHC.Eventlog.Live.Machine.Analysis.Heap ( -- ** Heap Profile Breakdown heapProfBreakdownEitherReader, heapProfBreakdownShow, + + -- ** Things fendor doesn't want to reimplement + InfoTable (..), + InfoTablePtr (..), + metric, ) where import Control.Monad (unless, when) diff --git a/eventlog-live/src/GHC/Eventlog/Live/Machine/Analysis/Profile.hs b/eventlog-live/src/GHC/Eventlog/Live/Machine/Analysis/Profile.hs new file mode 100644 index 00000000..e73befba --- /dev/null +++ b/eventlog-live/src/GHC/Eventlog/Live/Machine/Analysis/Profile.hs @@ -0,0 +1,174 @@ +module GHC.Eventlog.Live.Machine.Analysis.Profile ( + StackProfSampleData (..), + CallStackData (..), + StackItemData (..), + processStackProfSampleData, + stackProfSamples, +) +where + +import Control.Monad.IO.Class (MonadIO) +import Data.ByteString.Lazy qualified as LBS +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashMap.Strict qualified as M +import Data.List qualified as List +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.Text (Text) +import Data.Text qualified as Text +import Data.Word (Word64) +import GHC.Eventlog.Live.Data.Attribute qualified as Attrs +import GHC.Eventlog.Live.Data.Metric +import GHC.Eventlog.Live.Logger (Logger) +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 GHC.RTS.Events qualified as E +import GHC.Stack.Profiler.Core.Eventlog as SPCE +import GHC.Stack.Profiler.Core.SymbolTable qualified as SPCT +import GHC.Stack.Profiler.Core.ThreadSample as SPCT + +data StackProfSampleState = StackProfSampleState + { infoTableMap :: !(HashMap InfoTablePtr InfoTable) + , -- TODO: this should probably be a maybe? + -- We could report when interleaved messages are present + stackProfSampleChunk :: ![BinaryCallStackMessage] + , stackProfSymbolTableReader :: !SPCT.IntMapTable + , maybeStackProfSampleData :: !(Maybe StackProfSampleData) + } + deriving (Generic) + +newtype StackProfSampleData = StackProfSampleData + { stackProfSample :: Metric CallStackData + } + deriving (Show, Generic) + +data CallStackData = CallStackData + { threadId :: !Word64 + , capabilityId :: !CapabilityId + , stack :: [StackItemData] + } + deriving (Show, Generic) + +data StackItemData + = IpeData !InfoTable + | UserMessageData !Text + | SourceLocationData !SourceLocation + deriving (Show, Generic) + +shouldTrackInfoTableMap :: Bool +shouldTrackInfoTableMap = True + +{- | +This machine processes `E.UserBinaryMessage` events into metrics. +Furthermore, it processes the `E.InfoTableProv` events to +-} +processStackProfSampleData :: + (MonadIO m) => + Logger m -> + ProcessT m (WithStartTime Event) StackProfSampleData +processStackProfSampleData _logger = + construct $ + go + StackProfSampleState + { infoTableMap = mempty + , stackProfSampleChunk = mempty + , stackProfSymbolTableReader = SPCT.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 deserializeEventlogMessage $ LBS.fromStrict payload of + Left _err -> + go st + Right evMsg -> case evMsg of + CallStackFinal msg -> do + let (callStackMessage, st1) = + hydrateBinaryEventlog st msg + + stackProfSample = + metric i callStackMessage Attrs.empty + + yield $ StackProfSampleData stackProfSample + go st1 + CallStackChunk msg -> + go st{stackProfSampleChunk = msg : st.stackProfSampleChunk} + StringDef msg -> + go st{stackProfSymbolTableReader = SPCT.insertTextMessage msg st.stackProfSymbolTableReader} + SourceLocationDef msg -> + go st{stackProfSymbolTableReader = SPCT.insertSourceLocationMessage msg st.stackProfSymbolTableReader} + _otherwise -> go st + +hydrateBinaryEventlog :: StackProfSampleState -> BinaryCallStackMessage -> (CallStackData, StackProfSampleState) +hydrateBinaryEventlog spst msg = + let 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 = catCallStackMessage orderedChunks + callStackMessage = + hydrateEventlogCallStackMessage + (SPCT.mkIntMapSymbolTableReader spst.stackProfSymbolTableReader) + fullBinaryCallStackMessage + + callStackData = + CallStackData + { threadId = callThreadId callStackMessage + , capabilityId = callCapabilityId callStackMessage + , stack = + -- TODO: log if we are encountering unknown ipe ids + mapMaybe (toStackItemData spst.infoTableMap) $ callStack callStackMessage + } + in ( callStackData + , spst{stackProfSampleChunk = []} + ) + +toStackItemData :: HashMap InfoTablePtr InfoTable -> StackItem -> Maybe StackItemData +toStackItemData tbl = \case + IpeId iid -> IpeData <$> HashMap.lookup (InfoTablePtr $ getIpeId iid) tbl + UserMessage msg -> Just $ UserMessageData $ Text.pack msg + SourceLocation srcLoc -> Just $ SourceLocationData srcLoc + +{- | +Get the elements of a heap profile sample collection. +-} +stackProfSamples :: StackProfSampleData -> [Metric CallStackData] +stackProfSamples = List.singleton . (.stackProfSample) diff --git a/eventlog-live/src/GHC/Eventlog/Live/Machine/Core.hs b/eventlog-live/src/GHC/Eventlog/Live/Machine/Core.hs index ac193267..6b73ba7e 100644 --- a/eventlog-live/src/GHC/Eventlog/Live/Machine/Core.hs +++ b/eventlog-live/src/GHC/Eventlog/Live/Machine/Core.hs @@ -281,7 +281,8 @@ It preserves ticks but batches items between ticks using `sconcat`. -} batchByTick :: forall a. - (Monoid a) => Process (Tick a) (Tick a) + (Monoid a) => + Process (Tick a) (Tick a) batchByTick = batchByTicks 1 {- | diff --git a/examples/ecosim/LICENSE b/examples/ecosim/LICENSE new file mode 100644 index 00000000..3e0055b4 --- /dev/null +++ b/examples/ecosim/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2023, Finley McIlwaine + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/examples/ecosim/app/Main.hs b/examples/ecosim/app/Main.hs new file mode 100644 index 00000000..2bd0e808 --- /dev/null +++ b/examples/ecosim/app/Main.hs @@ -0,0 +1,125 @@ +-- EcoSim.hs +-- Tiny colony simulator with computation tied to simulation state +-- Run indefinitely and produces varied call stacks naturally +module Main where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Data.Foldable +import Data.List qualified as List +import GHC.Eventlog.Socket +import GHC.Stack.Annotation +import GHC.Stack.Profiler.Sampler +import System.Environment +import System.Random + +-- Simulation state -------------------------------------------------------- + +data Colony = Colony + { population :: TVar Int + , energy :: TVar Int + } + +-- Parameters +tickMicros :: Int +tickMicros = 200 * 1000 -- 200 ms per tick + +maxPopulationGrowth :: Int +maxPopulationGrowth = 5 + +maxEnergyChange :: Int +maxEnergyChange = 10 + +-- Initialize colony +initColony :: IO Colony +initColony = do + pop <- newTVarIO 500000 + en <- newTVarIO 1000000 + return $ Colony pop en + +-- Simulation tick --------------------------------------------------------- + +tick :: Colony -> IO () +tick colony = annotateStackStringIO "Tick" $ do + -- 1. Read current state + pop <- readTVarIO (population colony) + en <- readTVarIO (energy colony) + + -- 2. Light demographics change + deltaPop <- randomRIO (-maxPopulationGrowth, maxPopulationGrowth) + deltaEn <- randomRIO (-maxEnergyChange, maxEnergyChange) + + annotateStackStringIO "Next Colony step" $ atomically $ do + modifyTVar' (population colony) (\x -> max 0 (x + deltaPop)) + modifyTVar' (energy colony) (\x -> max 0 (x + deltaEn)) + + -- 3. Heavy-ish computations tied to state + + -- Prime counting -> stability modifier + let stabilityScore = countPrimes pop + popModifier = if even stabilityScore then 1 else -1 + + -- Noise -> environment modifier + let envForecast = noise (pop + en) + energyModifier = if envForecast > 0 then 2 else -2 + + -- Matrix multiply -> resource balancing + let size = (en `mod` 15) + 5 + matrixScore = sum (concat (matMul (mkMatrix size) (mkMatrix size))) + energyAdj = ceiling matrixScore `mod` 5 + + -- Apply feedback + annotateStackStringIO "Apply Colony Feedback" $ atomically $ do + modifyTVar' (population colony) (\x -> max 0 (x + popModifier)) + modifyTVar' (energy colony) (\x -> max 0 (x + energyModifier + energyAdj)) + +-- Utilities --------------------------------------------------------------- + +countPrimes :: Int -> Int +countPrimes n = length [x | x <- [2 .. n], isPrime x] + where + isPrime k = all (\d -> k `mod` d /= 0) [2 .. floor (sqrt (fromIntegral @Int @Double k))] + +noise :: Int -> Double +noise n = go n 0 + where + go 0 acc = acc + go k acc = go (k - 1) (sin acc + cos (fromIntegral k) * 0.1) + +mkMatrix :: Int -> [[Double]] +mkMatrix n = replicate n (replicate n 1.0) + +matMul :: [[Double]] -> [[Double]] -> [[Double]] +matMul a b = + let bt = List.transpose b + in [[sum (zipWith (*) row col) | col <- bt] | row <- a] + +-- Logger ------------------------------------------------------------------ + +logger :: Colony -> IO () +logger colony = annotateStackStringIO "Logger Thread" $ forever $ do + annotateStackStringIO "Logger Sleep" $ threadDelay (5 * 1000 * 1000) -- every 5 seconds + pop <- readTVarIO (population colony) + en <- readTVarIO (energy colony) + putStrLn $ "Population: " ++ show pop ++ ", Energy: " ++ show en + +-- Main -------------------------------------------------------------------- + +main :: IO () +main = withStackProfiler (SampleIntervalMs 30) $ do + traverse_ startWait =<< lookupEnv "GHC_EVENTLOG_SOCKET" + putStrLn "Starting ColonySim... (Ctrl-C to stop)" + colony <- initColony + + -- Logger thread + _ <- forkIO $ logger colony + + -- Simulation loop + let + loop :: Integer -> IO () + loop tickNum = annotateStackStringIO "CallLoop" $ do + tick colony + annotateStackStringIO "Colony Sleep" $ threadDelay tickMicros + loop (tickNum + 1) + loop 0 diff --git a/examples/ecosim/ecosim-otelcol-config.sh b/examples/ecosim/ecosim-otelcol-config.sh new file mode 100755 index 00000000..68bb131f --- /dev/null +++ b/examples/ecosim/ecosim-otelcol-config.sh @@ -0,0 +1,82 @@ +#!/bin/sh -e + +# Get the script directory +DIR=$(CDPATH='' cd -- "$(dirname -- "$0")" && pwd -P) + +# Set the eventlog socket +export GHC_EVENTLOG_SOCKET="/tmp/ecosim_eventlog.sock" + +# Build ecosim +echo "Build ecosim" +cabal build -w ghc-9.14 ecosim -v0 +ECOSIM_BIN=$(cabal list-bin -w ghc-9.14 exe:ecosim -v0 | head -n1) + +# Build eventlog-live-otelcol +echo "Build eventlog-live-otelcol" +cabal build eventlog-live-otelcol -v0 +EVENTLOG_LIVE_OTELCOL_BIN=$(cabal list-bin exe:eventlog-live-otelcol -v0 | head -n1) + +# Create the temporary directory +TMPDIR=$(mktemp -d) || exit +trap 'rm -rf "$TMPDIR"' EXIT INT TERM HUP + +# Create the screen pipe for ecosim +ECOSIM_FIFO="$TMPDIR/ecosim.fifo" +mkfifo "$ECOSIM_FIFO" || exit + +# Create the screen pipe for eventlog-live-otelcol +EVENTLOG_LIVE_OTELCOL_FIFO=$TMPDIR/eventlog-live-otelcol.fifo +mkfifo "$EVENTLOG_LIVE_OTELCOL_FIFO" || exit + +# Create the command to start ecosim +# shellcheck disable=SC2089 +ECOSIM_CMD=" +echo 'Start ecosim' && \ + ${ECOSIM_BIN} \ + +RTS \ + -l \ + -hT \ + --eventlog-flush-interval=1 \ + -RTS +" + +# Create the command to start eventlog-live-otelcol +# shellcheck disable=SC2089 +EVENTLOG_LIVE_OTELCOL_CMD=" +echo 'Start eventlog-live-otelcol (for ecosim)' && \ + ${EVENTLOG_LIVE_OTELCOL_BIN} \ + --verbosity=debug \ + --stats \ + --config='$DIR/ecosim-otelcol-config.yaml' \ + --service-name='ecosim' \ + --eventlog-socket '$GHC_EVENTLOG_SOCKET' \ + -hT \ + --otelcol-host=localhost \ + +RTS -l -hT --eventlog-flush-interval=1 -RTS +" + +# Create the screen conf file +SCREEN_CONF="$TMPDIR/screen.conf" +cat > "$SCREEN_CONF" << 'EOF' || exit +split +split -v +focus right +screen -t 'ecosim/stderr' sh -c 'tty > "$ECOSIM_FIFO"; read done < "$ECOSIM_FIFO"' +focus left +screen -t 'ecosim/stdout' sh -c 'trap "screen -X quit" INT; read tty < "$ECOSIM_FIFO"; eval "$ECOSIM_CMD" 2> "$tty"; echo "[Command exited with status $?, press enter to exit]"; read prompt; echo done > "$ECOSIM_FIFO"' +focus down +split -v +focus right +screen -t 'eventlog-live-otelcol/stderr' sh -c 'tty > "$EVENTLOG_LIVE_OTELCOL_FIFO"; read done < "$EVENTLOG_LIVE_OTELCOL_FIFO"' +focus left +screen -t 'eventlog-live-otelcol/stdout' sh -c 'trap "screen -X quit" INT; read tty < "$EVENTLOG_LIVE_OTELCOL_FIFO"; eval "$EVENTLOG_LIVE_OTELCOL_CMD" 2> "$tty"; echo "[Command exited with status $?, press enter to exit]"; read prompt; echo done > "$EVENTLOG_LIVE_OTELCOL_FOR_ECOSIM_FIFO"' +EOF + +# Start screen +# shellcheck disable=SC2090 +export \ + ECOSIM_FIFO \ + ECOSIM_CMD \ + EVENTLOG_LIVE_OTELCOL_FIFO \ + EVENTLOG_LIVE_OTELCOL_CMD +screen -mc "$SCREEN_CONF" diff --git a/examples/ecosim/ecosim-otelcol-config.yaml b/examples/ecosim/ecosim-otelcol-config.yaml new file mode 100644 index 00000000..cdf57197 --- /dev/null +++ b/examples/ecosim/ecosim-otelcol-config.yaml @@ -0,0 +1,74 @@ +processors: + logs: + thread_label: + name: ghc_eventlog_ThreadLabel + description: A thread label. + export: false + user_marker: + name: ghc_eventlog_UserMarker + description: A user marker. + export: false + user_message: + name: ghc_eventlog_UserMessage + description: A user log message. + export: false + metrics: + blocks_size: + name: ghc_eventlog_BlocksSize + description: The current heap size, calculated by the allocated number of blocks. + aggregate: 1s + export: false + capability_usage: + name: ghc_eventlog_CapabilityUsageDuration + description: The duration of each capability usage span. + aggregate: 1s + export: false + heap_allocated: + name: ghc_eventlog_HeapAllocated + description: The size of a newly allocated chunk of heap. + aggregate: 1s + export: false + heap_live: + name: ghc_eventlog_HeapLive + description: The current heap size, calculated by the allocated number of megablocks. + aggregate: 1s + export: false + heap_prof_sample: + name: ghc_eventlog_HeapProfSample + description: A heap profile sample. + aggregate: 1s + export: false + heap_size: + name: ghc_eventlog_HeapSize + description: The current heap size, calculated by the allocated number of megablocks. + aggregate: 1s + export: false + mem_current: + name: ghc_eventlog_MemCurrent + description: The number of megablocks currently allocated. + aggregate: 1s + export: false + mem_needed: + name: ghc_eventlog_MemNeeded + description: The number of megablocks currently needed. + aggregate: 1s + export: false + mem_returned: + name: ghc_eventlog_MemReturned + description: The number of megablocks currently being returned to the OS. + aggregate: 1s + export: false + traces: + capability_usage: + name: ghc_eventlog_CapabilityUsage + description: A trace of capability usage (either mutator thread or garbage collection). + export: false + thread_state: + name: ghc_eventlog_ThreadState + description: A trace of thread state changes (either running or stopped). + export: false + profiles: + stack_sample: + name: ghc_eventlog_StackSampleProfile + description: A thread RTS callstack sample + export: 5s diff --git a/examples/ecosim/ecosim.cabal b/examples/ecosim/ecosim.cabal new file mode 100644 index 00000000..526d91ed --- /dev/null +++ b/examples/ecosim/ecosim.cabal @@ -0,0 +1,31 @@ +cabal-version: 3.0 +name: ecosim +version: 0.1.0.0 +author: fendor +maintainer: fendor@well-typed.com +copyright: (c) 2025 Well-Typed +license: BSD-3-Clause +build-type: Simple +category: Simulation +description: + Simulation example project for Stack profiles for eventlog-live. + +synopsis: Simulation example project for Stack profiles. + +common warnings + ghc-options: -Wall -Wx-no-partial + +executable ecosim + import: warnings + main-is: Main.hs + ghc-options: -threaded -rtsopts -finfo-table-map + build-depends: + , base >=4.20 && <5 + , eventlog-socket >=0.1.0 && <0.2 + , ghc-stack-annotations >=0.1 && <0.2 + , ghc-stack-profiler >=0.1 && <0.2 + , random >=1.2 && <1.4 + , stm >=2.5 && <2.6 + + hs-source-dirs: app + default-language: GHC2021 diff --git a/examples/oddball/oddball-otelcol-config.yaml b/examples/oddball/oddball-otelcol-config.yaml index 0e0bf95d..a62617ba 100644 --- a/examples/oddball/oddball-otelcol-config.yaml +++ b/examples/oddball/oddball-otelcol-config.yaml @@ -67,3 +67,8 @@ processors: name: ghc_eventlog_ThreadState description: A trace of thread state changes (either running or stopped). export: 5s + profiles: + stack_sample: + name: ghc_eventlog_StackSampleProfile + description: A thread RTS callstack sample + export: 5s