diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.6.1.0 + +- Support eventlog over TCP/IP. + ### 0.6.0.0 - **BREAKING**: Drop `enabled` from configuration files. diff --git a/eventlog-live-otelcol.cabal b/eventlog-live-otelcol.cabal --- a/eventlog-live-otelcol.cabal +++ b/eventlog-live-otelcol.cabal @@ -1,80 +1,85 @@ cabal-version: 3.0 name: eventlog-live-otelcol -version: 0.6.0.0 +version: 0.6.1.0 synopsis: Stream eventlog data to the OpenTelemetry Collector. description: This executable supports live streaming of eventlog data into the OpenTelemetry Collector. - > Usage: eventlog-live-otelcol (--eventlog-stdin | --eventlog-file FILE | --eventlog-socket SOCKET) + > Usage: eventlog-live-otelcol (--eventlog-stdin | --eventlog-file FILE | + > --eventlog-socket SOCKET | + > --eventlog-socket-host HOST + > --eventlog-socket-port PORT) > [--eventlog-socket-timeout SECONDS] > [--eventlog-socket-exponent NUMBER] > [--eventlog-flush-interval SECONDS] - > [--eventlog-log-file FILE] - > [-h Tcmdyrbi] + > [--eventlog-log-file FILE] [-h Tcmdyrbi] > [--service-name STRING] > [-v|--verbosity fatal|error|warning|info|debug|trace] - > [-s|--stats] - > [--config FILE] - > --otelcol-host HOST - > [--otelcol-port PORT] - > [--otelcol-authority HOST] - > [--otelcol-ssl] - > [--otelcol-certificate-store FILE] - > [--otelcol-ssl-key-log FILE | --otelcol-ssl-key-log-from-env] - > [--control] - > [--control-port PORT] - > [--control-cors-allow-origin ORIGIN] - > [--control-cors-max-age SECONDS] - > [--control-cors-require-origin] - > [--control-cors-ignore-failure] - > [--my-eventlog-socket-unix FILE] - > [--my-ghc-debug-socket | --my-ghc-debug-socket-unix FILE | --my-ghc-debug-socket-tcp ADDRESS] - > [--print-defaults] - > [--print-config-json-schema] + > [-s|--stats] [--config FILE] --otelcol-host HOST + > [--otelcol-port PORT] [--otelcol-authority HOST] + > [--otelcol-ssl] [--otelcol-certificate-store FILE] + > [--otelcol-ssl-key-log FILE | + > --otelcol-ssl-key-log-from-env] + > [--print-defaults] [--print-config-json-schema] > > Available options: - > --eventlog-stdin Read the eventlog from stdin. - > --eventlog-file FILE Read the eventlog from a file. - > --eventlog-socket SOCKET Read the eventlog from a Unix socket. - > --eventlog-socket-timeout SECONDS Eventlog socket connection retry timeout in seconds. - > --eventlog-socket-exponent NUMBER Eventlog socket connection retry timeout exponent. - > --eventlog-flush-interval SECONDS Eventlog flush interval in seconds. - > Should match the option passed to the application. - > --eventlog-log-file FILE Use file to log binary eventlog data. - > -h Tcmdyrbi Heap profile breakdown. - > Should match the option passed to the application. - > --service-name STRING The name of the profiled service. + > --eventlog-stdin Read the eventlog from stdin. + > --eventlog-file FILE Read the eventlog from a file. + > --eventlog-socket SOCKET Read the eventlog from a Unix socket. + > --eventlog-socket-host HOST Read the eventlog from a TCP/IP socket. + > --eventlog-socket-port PORT Read the eventlog from a TCP/IP socket. + > --eventlog-socket-timeout SECONDS Eventlog socket connection retry timeout in seconds. + > --eventlog-socket-exponent NUMBER Eventlog socket connection retry timeout exponent. + > --eventlog-flush-interval SECONDS Eventlog flush interval in seconds. + > Should match the option passed to the application. + > --eventlog-log-file FILE Use file to log binary eventlog data. + > -h Tcmdyrbi Heap profile breakdown. + > Should match the option passed to the application. + > --service-name STRING The name of the profiled service. > -v,--verbosity fatal|error|warning|info|debug|trace - > The severity threshold for logging. - > -s,--stats Display runtime statistics. - > --config FILE The path to a detailed configuration file. - > --print-defaults Print default configuration options. - > --print-config-json-schema Print JSON Schema for configuration format. - > --help Show this help text. - > --version Show version information + > The severity threshold for logging. + > -s,--stats Display runtime statistics. + > --config FILE The path to a detailed configuration file. + > --print-defaults Print default configuration options. + > --print-config-json-schema Print JSON Schema for configuration format. + > --help Show this help text. + > --version Show version information > > OpenTelemetry Collector Server Options - > --otelcol-host HOST Otelcol server hostname. - > --otelcol-port PORT Otelcol server TCP port. - > --otelcol-authority HOST Otelcol server authority. - > --otelcol-ssl Use SSL. - > --otelcol-certificate-store FILE Store for certificate validation. - > --otelcol-ssl-key-log FILE Use file to log SSL keys. - > --otelcol-ssl-key-log-from-env Use SSLKEYLOGFILE to log SSL keys. + > --otelcol-host HOST Otelcol server hostname. + > --otelcol-port PORT Otelcol server TCP port. + > --otelcol-authority HOST Otelcol server authority. + > --otelcol-ssl Use SSL. + > --otelcol-certificate-store FILE Store for certificate validation. + > --otelcol-ssl-key-log FILE Use file to log SSL keys. + > --otelcol-ssl-key-log-from-env Use SSLKEYLOGFILE to log SSL keys. > > Control Server Options - > --control Start the control server. - > --control-port PORT The port number for the control server. - > --control-cors-allow-origin ORIGIN Set the allowed origins for the control server CORS policy. - > --control-cors-max-age SECONDS Set the maximum age of a cached CORS preflight request for the control server CORS policy. - > --control-cors-require-origin If enabled, the control server will not accept requests without an Origin header. - > --control-cors-ignore-failure If enabled, the control server will accept malformed CORS preflight requests. + > --control Requires build with -f+control. + > Start the control server. + > --control-port Requires build with -f+control. + > The port number for the control server. + > --control-cors-allow-origin + > Requires build with -f+control. + > Set the allowed origins for the control server CORS policy. + > --control-cors-max-age Requires build with -f+control. + > Set the maximum age of a cached CORS preflight request for the control server CORS policy. + > --control-cors-require-origin + > Requires build with -f+control. + > If enabled, the control server will not accept requests without an Origin header. + > --control-cors-ignore-failure + > Requires build with -f+control. + > If enabled, the control server will accept malformed CORS preflight requests. > > Debug Options - > --my-eventlog-socket-unix FILE Open an eventlog socket for this program on the given Unix socket. - > --my-ghc-debug-socket Open the default ghc-debug socket for this program. - > --my-ghc-debug-socket-unix FILE Open a ghc-debug Unix domain socket with the given file path. - > --my-ghc-debug-socket-tcp ADDRESS Open a ghc-debug TCP/IP socket with the given address as 'host:port'. + > --my-eventlog-socket-unix Requires build with -f+use-eventlog-socket. + > Open an eventlog socket for this program on the given Unix socket. + > --my-ghc-debug-socket Requires build with -f+use-ghc-debug-stub. + > Open the default ghc-debug socket for this program. + > --my-ghc-debug-socket-unix Requires build with -f+use-ghc-debug-stub. + > Open a ghc-debug Unix domain socket with the given file path. + > --my-ghc-debug-socket-tcp Requires build with -f+use-ghc-debug-stub. + > Open a ghc-debug TCP/IP socket with the given address as 'host:port'. license: BSD-3-Clause license-file: LICENSE @@ -100,7 +105,7 @@ type: git location: https://github.com/well-typed/eventlog-live.git subdir: eventlog-live-otelcol - tag: eventlog-live-otelcol-0.6.0.0 + tag: eventlog-live-otelcol-0.6.1.0 -- This flag enables the control command server, which is an HTTP endpoint -- that gets started by eventlog-live-otelcol. If +control is set, then @@ -200,7 +205,8 @@ GHC.Eventlog.Live.Otelcol.Processor.Common.Core GHC.Eventlog.Live.Otelcol.Processor.Common.Logs GHC.Eventlog.Live.Otelcol.Processor.Common.Metrics - GHC.Eventlog.Live.Otelcol.Processor.Common.Profiles + GHC.Eventlog.Live.Otelcol.Processor.Common.ProfilesDictionary + GHC.Eventlog.Live.Otelcol.Processor.Common.SymbolTable GHC.Eventlog.Live.Otelcol.Processor.Common.Traces GHC.Eventlog.Live.Otelcol.Processor.Heap GHC.Eventlog.Live.Otelcol.Processor.Logs diff --git a/src/GHC/Eventlog/Live/Otelcol.hs b/src/GHC/Eventlog/Live/Otelcol.hs --- a/src/GHC/Eventlog/Live/Otelcol.hs +++ b/src/GHC/Eventlog/Live/Otelcol.hs @@ -43,7 +43,7 @@ import GHC.Eventlog.Live.Otelcol.Processor.Common.Core import GHC.Eventlog.Live.Otelcol.Processor.Common.Logs (ToLogRecord (..), toExportLogsServiceRequest, toResourceLogs, toScopeLogs) import GHC.Eventlog.Live.Otelcol.Processor.Common.Metrics (toExportMetricsServiceRequest, toResourceMetrics, toScopeMetrics) -import GHC.Eventlog.Live.Otelcol.Processor.Common.Profiles (toExportProfileServiceRequest) +import GHC.Eventlog.Live.Otelcol.Processor.Common.ProfilesDictionary (toExportProfileServiceRequest) import GHC.Eventlog.Live.Otelcol.Processor.Common.Traces (toExportTracesServiceRequest, toResourceSpans, toScopeSpans) import GHC.Eventlog.Live.Otelcol.Processor.Heap (processHeapEvents) import GHC.Eventlog.Live.Otelcol.Processor.Logs (processLogEvents) diff --git a/src/GHC/Eventlog/Live/Otelcol/Control.hs b/src/GHC/Eventlog/Live/Otelcol/Control.hs --- a/src/GHC/Eventlog/Live/Otelcol/Control.hs +++ b/src/GHC/Eventlog/Live/Otelcol/Control.hs @@ -356,7 +356,7 @@ , errHeaders = [] } -- If the service telemetry is streamed from a socket, continue. - Just (EventlogSourceHandleSocketUnix s) -> action s + Just (EventlogSourceHandleSocket s) -> action s -------------------------------------------------------------------------------- -- Control API diff --git a/src/GHC/Eventlog/Live/Otelcol/Processor/Common/Profiles.hs b/src/GHC/Eventlog/Live/Otelcol/Processor/Common/Profiles.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Otelcol/Processor/Common/Profiles.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : GHC.Eventlog.Live.Otelcol.Processor.Common.Profiles -Description : Abstraction over ProfilesDictionary for the OTLP protocol. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Otelcol.Processor.Common.Profiles ( - toExportProfileServiceRequest, - - -- * 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 (Int32) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.ProtoLens (Message (..)) -import Data.Text (Text) -import GHC.Eventlog.Live.Otelcol.Processor.Common.Core (messageWith) -import GHC.Generics (Generic) -import Lens.Family2 (Lens', (&), (.~), (^.)) -import Lens.Family2.Unchecked (lens) -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 - -toExportProfileServiceRequest :: OP.ProfilesData -> OPS.ExportProfilesServiceRequest -toExportProfileServiceRequest profilesData = - messageWith - [ OPS.resourceProfiles .~ profilesData ^. OPS.resourceProfiles - , OPS.dictionary .~ profilesData ^. OPS.dictionary - ] - -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 = - messageWith - [ 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/src/GHC/Eventlog/Live/Otelcol/Processor/Common/ProfilesDictionary.hs b/src/GHC/Eventlog/Live/Otelcol/Processor/Common/ProfilesDictionary.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Eventlog/Live/Otelcol/Processor/Common/ProfilesDictionary.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otelcol.Processor.Common.Profiles +Description : Abstraction over ProfilesDictionary for the OTLP protocol. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otelcol.Processor.Common.ProfilesDictionary ( + -- * Dictionary for deduplication logic of common values + ProfilesDictionary, + empty, + + -- * Retrieve the 'SymbolIndex' for various 'OP.ProfilesData' fields + SymbolIndex, + getLocation, + getFunction, + getString, + getMapping, + getLink, + getAttribute, + getStack, + + -- * Convert data to the formats used by @hs-opentelemetry-otlp@. + toExportProfileServiceRequest, + toProfilesDictionary, +) +where + +import Control.Monad.Trans.State.Strict (StateT) +import Control.Monad.Trans.State.Strict qualified as State +import Data.ProtoLens (Message (..)) +import Data.Text (Text) +import GHC.Eventlog.Live.Otelcol.Processor.Common.Core (messageWith) +import GHC.Eventlog.Live.Otelcol.Processor.Common.SymbolTable (SymbolIndex, SymbolTable) +import GHC.Eventlog.Live.Otelcol.Processor.Common.SymbolTable qualified as ST +import GHC.Generics (Generic) +import Lens.Family2 (Lens', (.~), (^.)) +import Lens.Family2.Unchecked (lens) +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 + +toExportProfileServiceRequest :: OP.ProfilesData -> OPS.ExportProfilesServiceRequest +toExportProfileServiceRequest profilesData = + messageWith + [ OPS.resourceProfiles .~ profilesData ^. OPS.resourceProfiles + , OPS.dictionary .~ profilesData ^. OPS.dictionary + ] + +data ProfilesDictionary = ProfilesDictionary + { locationTable :: SymbolTable OP.Location + {- ^ Common 'OP.Location' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , functionTable :: SymbolTable OP.Function + {- ^ Common 'OP.Function' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , stringTable :: SymbolTable 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 :: SymbolTable OP.Mapping + {- ^ Common 'OP.Mapping' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , linkTable :: SymbolTable OP.Link + {- ^ Common 'OP.Link' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , attributeTable :: SymbolTable OP.KeyValueAndUnit + {- ^ Common 'OP.KeyValueAndUnit' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , stackTable :: SymbolTable OP.Stack + {- ^ Common 'OP.Stack' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + } + deriving (Show, Ord, Eq, Generic) + +toProfilesDictionary :: ProfilesDictionary -> OP.ProfilesDictionary +toProfilesDictionary st = + messageWith + [ OP.locationTable .~ locations st + , OP.functionTable .~ functions st + , OP.stringTable .~ strings st + , OP.mappingTable .~ mappings st + , OP.linkTable .~ links st + , OP.attributeTable .~ attributes st + , OP.stackTable .~ stacks st + ] + +empty :: ProfilesDictionary +empty = + ProfilesDictionary + { locationTable = ST.fromList [defMessage] + , functionTable = ST.fromList [defMessage] + , stringTable = ST.fromList [""] + , mappingTable = ST.fromList [defMessage] + , linkTable = ST.fromList [defMessage] + , attributeTable = ST.fromList [defMessage] + , stackTable = ST.fromList [defMessage] + } + +locations :: ProfilesDictionary -> [OP.Location] +locations pd = ST.toList pd.locationTable + +functions :: ProfilesDictionary -> [OP.Function] +functions pd = ST.toList pd.functionTable + +strings :: ProfilesDictionary -> [Text] +strings pd = ST.toList pd.stringTable + +mappings :: ProfilesDictionary -> [OP.Mapping] +mappings pd = ST.toList pd.mappingTable + +links :: ProfilesDictionary -> [OP.Link] +links pd = ST.toList pd.linkTable + +attributes :: ProfilesDictionary -> [OP.KeyValueAndUnit] +attributes pd = ST.toList pd.attributeTable + +stacks :: ProfilesDictionary -> [OP.Stack] +stacks pd = ST.toList pd.stackTable + +getSymbolIndexFor :: (Ord a, Monad m) => Lens' ProfilesDictionary (SymbolTable a) -> a -> StateT ProfilesDictionary m SymbolIndex +getSymbolIndexFor accessor a = do + st <- State.gets (^. accessor) + let (si, pd') = ST.insert a st + State.modify' (accessor .~ pd') + pure si + +getLocation :: (Monad m) => OP.Location -> StateT ProfilesDictionary m SymbolIndex +getLocation = getSymbolIndexFor (lens (.locationTable) (\pd st -> pd{locationTable = st})) + +getFunction :: (Monad m) => OP.Function -> StateT ProfilesDictionary m SymbolIndex +getFunction = getSymbolIndexFor (lens (.functionTable) (\pd st -> pd{functionTable = st})) + +getString :: (Monad m) => Text -> StateT ProfilesDictionary m SymbolIndex +getString = getSymbolIndexFor (lens (.stringTable) (\pd st -> pd{stringTable = st})) + +getMapping :: (Monad m) => OP.Mapping -> StateT ProfilesDictionary m SymbolIndex +getMapping = getSymbolIndexFor (lens (.mappingTable) (\pd st -> pd{mappingTable = st})) + +getLink :: (Monad m) => OP.Link -> StateT ProfilesDictionary m SymbolIndex +getLink = getSymbolIndexFor (lens (.linkTable) (\pd st -> pd{linkTable = st})) + +getAttribute :: (Monad m) => OP.KeyValueAndUnit -> StateT ProfilesDictionary m SymbolIndex +getAttribute = getSymbolIndexFor (lens (.attributeTable) (\pd st -> pd{attributeTable = st})) + +getStack :: (Monad m) => OP.Stack -> StateT ProfilesDictionary m SymbolIndex +getStack = getSymbolIndexFor (lens (.stackTable) (\pd st -> pd{stackTable = st})) diff --git a/src/GHC/Eventlog/Live/Otelcol/Processor/Common/SymbolTable.hs b/src/GHC/Eventlog/Live/Otelcol/Processor/Common/SymbolTable.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Eventlog/Live/Otelcol/Processor/Common/SymbolTable.hs @@ -0,0 +1,76 @@ +{- | +Module : GHC.Eventlog.Live.Otelcol.Processor.Common.SymbolTable +Description : Abstract symbol table datatype. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otelcol.Processor.Common.SymbolTable ( + SymbolIndex, + SymbolTable, + empty, + elemIndex, + toList, + fromList, + insert, +) +where + +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Generics (Generic) + +type SymbolIndex = Int32 + +data SymbolTable a + = SymbolTable + { nextSymbolIndex :: !SymbolIndex + {- ^ + The next unused `SymbolIndex`. + + > st.nextSymbolIndex == length st.entriesReversed + -} + , entryToSymbolIndex :: !(Map a SymbolIndex) + {- ^ + A map from entries to their `SymbolIndex`. + + > toList st !! (st.entryToSymbolIndex Map.! a) == a + -} + , entriesReversed :: ![a] -- reverse order of insertion into entryToSymbolIndex + + {- ^ + A list of entries in the `SymbolTable` in reverse order. + -} + } + deriving (Show, Ord, Eq, Generic) + +empty :: SymbolTable a +empty = + SymbolTable + { nextSymbolIndex = 0 + , entryToSymbolIndex = Map.empty + , entriesReversed = [] + } + +elemIndex :: (Ord a) => a -> SymbolTable a -> Maybe SymbolIndex +elemIndex a st = Map.lookup a st.entryToSymbolIndex + +toList :: SymbolTable a -> [a] +toList st = reverse st.entriesReversed + +fromList :: (Ord a) => [a] -> SymbolTable a +fromList = foldr (\val st -> snd (insert val st)) empty + +insert :: (Ord a) => a -> SymbolTable a -> (SymbolIndex, SymbolTable a) +insert a st = (si, st'') + where + ((si, isNew, st'), entryToSymbolIndex') = Map.alterF (updateEntry st) a st.entryToSymbolIndex + entriesReversed' = if isNew then a : st'.entriesReversed else st'.entriesReversed + st'' = st'{entryToSymbolIndex = entryToSymbolIndex', entriesReversed = entriesReversed'} + +updateEntry :: SymbolTable a -> Maybe SymbolIndex -> ((SymbolIndex, Bool, SymbolTable a), Maybe SymbolIndex) +updateEntry st Nothing = let (si, st') = freshSymbolIndex st in ((si, True, st'), Just si) +updateEntry st (Just si) = ((si, False, st), Just si) + +freshSymbolIndex :: SymbolTable a -> (SymbolIndex, SymbolTable a) +freshSymbolIndex st = (st.nextSymbolIndex, st{nextSymbolIndex = st.nextSymbolIndex + 1}) diff --git a/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles.hs b/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles.hs --- a/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles.hs +++ b/src/GHC/Eventlog/Live/Otelcol/Processor/Profiles.hs @@ -28,8 +28,8 @@ import GHC.Eventlog.Live.Otelcol.Config qualified as C import GHC.Eventlog.Live.Otelcol.Config.Types (FullConfig (..)) import GHC.Eventlog.Live.Otelcol.Processor.Common.Core -import GHC.Eventlog.Live.Otelcol.Processor.Common.Profiles (ProfileDictionary, SymbolIndex) -import GHC.Eventlog.Live.Otelcol.Processor.Common.Profiles qualified as ProfDictionary +import GHC.Eventlog.Live.Otelcol.Processor.Common.ProfilesDictionary (ProfilesDictionary, SymbolIndex) +import GHC.Eventlog.Live.Otelcol.Processor.Common.ProfilesDictionary qualified as PD import GHC.RTS.Events (Event (..)) import GHC.Stack.Profiler.Core.SourceLocation qualified as Profiler import Lens.Family2 ((.~)) @@ -102,13 +102,13 @@ , OP.resource .~ resource ] - profilesDictionary = ProfDictionary.toProfilesDictionary st + profilesDictionary = PD.toProfilesDictionary st - (profile, st) = flip runState ProfDictionary.emptyProfileDictionary $ do - sampleNameStrId <- ProfDictionary.getString "__name__" - sampleTypeStrId <- ProfDictionary.getString "String" + (profile, st) = flip runState PD.empty $ do + sampleNameStrId <- PD.getString "__name__" + sampleTypeStrId <- PD.getString "String" sampleAttrId <- - ProfDictionary.getAttribute $ + PD.getAttribute $ messageWith @OP.KeyValueAndUnit [ OP.keyStrindex .~ sampleNameStrId , OP.unitStrindex .~ sampleTypeStrId @@ -116,8 +116,8 @@ ] samples <- traverse (asSample sampleAttrId) callstacks - cpuId <- ProfDictionary.getString "stack" - unitId <- ProfDictionary.getString "samples" + cpuId <- PD.getString "stack" + unitId <- PD.getString "samples" let sampleType :: OP.ValueType sampleType = messageWith @@ -131,21 +131,21 @@ , OP.sampleType .~ sampleType ] -asSample :: SymbolIndex -> M.CallStackData -> State ProfileDictionary OP.Sample +asSample :: SymbolIndex -> M.CallStackData -> State ProfilesDictionary OP.Sample asSample six stackData = do locIndices <- traverse toIndex stackData.stack s <- - ProfDictionary.getStack $ + PD.getStack $ messageWith [ OP.locationIndices .~ locIndices ] - sampleThreadKeyStrId <- ProfDictionary.getString "thread" - sampleCapKeyStrId <- ProfDictionary.getString "capability" - sampleNumberUnitStrId <- ProfDictionary.getString "Number" + sampleThreadKeyStrId <- PD.getString "thread" + sampleCapKeyStrId <- PD.getString "capability" + sampleNumberUnitStrId <- PD.getString "Number" threadAttrId <- - ProfDictionary.getAttribute $ + PD.getAttribute $ messageWith @OP.KeyValueAndUnit [ OP.keyStrindex .~ sampleThreadKeyStrId , OP.unitStrindex .~ sampleNumberUnitStrId @@ -153,7 +153,7 @@ ] capAttrId <- - ProfDictionary.getAttribute $ + PD.getAttribute $ messageWith @OP.KeyValueAndUnit [ OP.keyStrindex .~ sampleCapKeyStrId , OP.unitStrindex .~ sampleNumberUnitStrId @@ -171,19 +171,19 @@ ] ] where - toIndex :: M.StackItemData -> State ProfileDictionary SymbolIndex + toIndex :: M.StackItemData -> State ProfilesDictionary SymbolIndex toIndex = \case - M.IpeData infoTable -> getLocationIndexForInfoTable infoTable + M.IpeData infoProv -> getLocationIndexForInfoTable infoProv M.UserMessageData message -> getLocationIndexForText message M.SourceLocationData srcLoc -> getLocationIndexForSourceLocation srcLoc M.CostCentreData costCentre -> getLocationIndexForCostCentre costCentre -getLocationIndexForSourceLocation :: Profiler.SourceLocation -> State ProfileDictionary SymbolIndex +getLocationIndexForSourceLocation :: Profiler.SourceLocation -> State ProfilesDictionary SymbolIndex getLocationIndexForSourceLocation srcLoc = do - functionNameId <- ProfDictionary.getString $ Profiler.functionName srcLoc - fileNameId <- ProfDictionary.getString $ Profiler.fileName srcLoc + functionNameId <- PD.getString $ Profiler.functionName srcLoc + fileNameId <- PD.getString $ Profiler.fileName srcLoc funcIdx <- - ProfDictionary.getFunction $ + PD.getFunction $ messageWith [ OP.nameStrindex .~ functionNameId , OP.systemNameStrindex .~ 0 -- 0 means unset @@ -199,17 +199,17 @@ , OP.column .~ fromIntegral (Profiler.column srcLoc) ] - ProfDictionary.getLocation $ + PD.getLocation $ messageWith [ OP.lines .~ [line] , OP.mappingIndex .~ 0 -- 0 means unset ] -getLocationIndexForText :: Text -> State ProfileDictionary SymbolIndex +getLocationIndexForText :: Text -> State ProfilesDictionary SymbolIndex getLocationIndexForText msg = do - textId <- ProfDictionary.getString msg + textId <- PD.getString msg funcIdx <- - ProfDictionary.getFunction $ + PD.getFunction $ messageWith [ OP.nameStrindex .~ textId , OP.systemNameStrindex .~ 0 -- 0 means unset @@ -225,28 +225,28 @@ , OP.column .~ 0 -- 0 means unset ] - ProfDictionary.getLocation $ + PD.getLocation $ messageWith [ OP.lines .~ [line] ] -getLocationIndexForInfoTable :: M.InfoTable -> State ProfileDictionary SymbolIndex -getLocationIndexForInfoTable infoTable = do - infoTableNameId <- ProfDictionary.getString infoTable.infoTableName +getLocationIndexForInfoTable :: M.InfoProv -> State ProfilesDictionary SymbolIndex +getLocationIndexForInfoTable infoProv = do + ipNameId <- PD.getString infoProv.ipName let label = - if (infoTable.infoTableLabel) == "" - then infoTable.infoTableModule <> ":" <> infoTable.infoTableName - else infoTable.infoTableModule <> ":" <> infoTable.infoTableLabel - infoTableFuncNameId <- ProfDictionary.getString label - -- tyDesc <- getText infoTable.infoTableTyDesc + if (infoProv.ipLabel) == "" + then infoProv.ipModule <> ":" <> infoProv.ipName + else infoProv.ipModule <> ":" <> infoProv.ipLabel + infoProvFuncNameId <- PD.getString label + -- tyDesc <- getText infoProv.infoProvTyDesc -- - infoTableSrcLocId <- ProfDictionary.getString infoTable.infoTableSrcLoc + ipSrcLocId <- PD.getString infoProv.ipSrcLoc funcIdx <- - ProfDictionary.getFunction $ + PD.getFunction $ messageWith - [ OP.nameStrindex .~ infoTableFuncNameId - , OP.systemNameStrindex .~ infoTableNameId - , OP.filenameStrindex .~ infoTableSrcLocId -- 0 means unset + [ OP.nameStrindex .~ infoProvFuncNameId + , OP.systemNameStrindex .~ ipNameId + , OP.filenameStrindex .~ ipSrcLocId -- 0 means unset , OP.startLine .~ 0 -- 0 means unset ] @@ -258,21 +258,21 @@ , OP.column .~ 0 -- 0 means unset ] - ProfDictionary.getLocation $ + PD.getLocation $ messageWith [ OP.lines .~ [line] , OP.address .~ 0 -- 0 means unset ] -getLocationIndexForCostCentre :: M.CostCentre -> State ProfileDictionary SymbolIndex +getLocationIndexForCostCentre :: M.CostCentre -> State ProfilesDictionary SymbolIndex getLocationIndexForCostCentre costCentre = do let label = costCentre.costCentreModule <> ":" <> costCentre.costCentreLabel - costCentreFuncNameId <- ProfDictionary.getString label - -- tyDesc <- getText infoTable.infoTableTyDesc + costCentreFuncNameId <- PD.getString label + -- tyDesc <- getText infoProv.infoProvTyDesc -- - costCentreSrcLocId <- ProfDictionary.getString costCentre.costCentreSrcLoc + costCentreSrcLocId <- PD.getString costCentre.costCentreSrcLoc funcIdx <- - ProfDictionary.getFunction $ + PD.getFunction $ messageWith [ OP.nameStrindex .~ costCentreFuncNameId , OP.systemNameStrindex .~ costCentreFuncNameId @@ -288,7 +288,7 @@ , OP.column .~ 0 -- 0 means unset ] - ProfDictionary.getLocation $ + PD.getLocation $ messageWith [ OP.lines .~ [line] , OP.address .~ 0 -- 0 means unset