Skip to content

Commit

Permalink
More compact thread presentation for Tracy
Browse files Browse the repository at this point in the history
  • Loading branch information
ethercrow committed Apr 10, 2021
1 parent 33cb217 commit 66f40e5
Show file tree
Hide file tree
Showing 7 changed files with 58 additions and 35 deletions.
8 changes: 6 additions & 2 deletions .github/workflows/ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,8 @@ jobs:
runs-on: ubuntu-latest
strategy:
matrix:
ghc: ['8.6', '8.8', '8.10', '9.0']
ghc: ['8.6', '8.8', '8.10']
fail-fast: false
steps:
- uses: actions/[email protected]
- uses: actions/[email protected]
Expand Down Expand Up @@ -48,6 +49,7 @@ jobs:
strategy:
matrix:
stack-yaml: ['stack-8.10.yaml']
fail-fast: false
steps:
- uses: actions/[email protected]
- uses: actions/[email protected]
Expand Down Expand Up @@ -75,6 +77,7 @@ jobs:
strategy:
matrix:
stack-yaml: ['stack-8.10.yaml']
fail-fast: false
steps:
- uses: actions/[email protected]
- uses: actions/[email protected]
Expand All @@ -101,7 +104,8 @@ jobs:
runs-on: windows-latest
strategy:
matrix:
ghc: ['8.10', '9.0.1']
ghc: ['8.10']
fail-fast: false
steps:
- uses: actions/[email protected]
- uses: actions/[email protected]
Expand Down
8 changes: 6 additions & 2 deletions megaexample/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@

import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Function
Expand Down Expand Up @@ -85,8 +86,11 @@ microservice httpRequestCounter = \req respond -> withSpan "handle_http_request"
respond $ Wai.responseLBS status200 [] result
_ -> do
bg_work <- async $ withSpan_ "background_task" do
threadDelay 10000
pure ()
replicateM_ 3 $ do
tasks <- forM [1..5] (\i ->
async $ withSpan_ (BS.pack $ printf "task %d" (i :: Int)) $ threadDelay 10000)
mapM_ wait tasks
threadDelay 10000
addEvent sp "message" "started bg work"
rtsStats <- withSpan_ "getRTSStats" getRTSStats
() <- wait bg_work
Expand Down
4 changes: 2 additions & 2 deletions opentelemetry-extra/exe/eventlog-to-tracy/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -39,12 +39,12 @@ main = do
["-h"] -> help
["--help"] -> help
["help"] -> help
[eventlogFile] -> work eventlogFile CollapseThreads
[eventlogFile] -> work eventlogFile SplitThreads
["--collapse-threads", eventlogFile] -> work eventlogFile CollapseThreads
["--split-threads", eventlogFile] -> work eventlogFile SplitThreads
_ -> help

work :: FilePath -> DoWeCollapseThreads -> IO ()
work :: FilePath -> ThreadPresentation -> IO ()
work inputFile doWeCollapseThreads = do
let chromeFile = inputFile ++ ".trace.json"
tracyFile = inputFile ++ ".tracy"
Expand Down
27 changes: 13 additions & 14 deletions opentelemetry-extra/src/OpenTelemetry/ChromeExporter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,6 @@ module OpenTelemetry.ChromeExporter where

import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Coerce
import Data.Function
import Data.HashMap.Strict as HM
Expand Down Expand Up @@ -42,7 +41,7 @@ jChromeBeginSpan Span {..} =
[ ("ph", J.textString "B"),
("name", J.textString spanOperation),
("pid", J.intNumber 1),
("tid", J.intNumber $ fromIntegral spanThreadId),
("tid", J.intNumber $ fromIntegral spanDisplayThreadId),
("ts", J.wordNumber . fromIntegral $ div spanStartedAt 1000),
( "args",
J.object
Expand All @@ -63,31 +62,31 @@ jChromeEndSpan Span {..} =
[ ("ph", J.textString "E"),
("name", J.textString spanOperation),
("pid", J.intNumber 1),
("tid", J.intNumber $ fromIntegral spanThreadId),
("tid", J.intNumber $ fromIntegral spanDisplayThreadId),
("ts", J.wordNumber . fromIntegral $ div spanFinishedAt 1000)
]

createChromeExporter :: FilePath -> IO (Exporter Span, Exporter Metric)
createChromeExporter path = createChromeExporter' path SplitThreads

createChromeExporter' :: FilePath -> DoWeCollapseThreads -> IO (Exporter Span, Exporter Metric)
createChromeExporter' path doWeCollapseThreads = do
createChromeExporter' :: FilePath -> ThreadPresentation -> IO (Exporter Span, Exporter Metric)
createChromeExporter' path threadPresentation = do
f <- openFile path WriteMode
hPutStrLn f "[ "
let modifyThreadId = case doWeCollapseThreads of
CollapseThreads -> const 1
SplitThreads -> id
let modifyThreadId = case threadPresentation of
CollapseThreads -> pure . const 1
SplitThreads -> pure
span_exporter =
Exporter
( \sps -> do
mapM_
( \sp -> do
let sp' = sp {spanThreadId = modifyThreadId (spanThreadId sp)}
let Span {spanThreadId, spanEvents} = sp'
( \sp@(Span {spanEvents}) -> do
tid' <- modifyThreadId (spanDisplayThreadId sp)
let sp' = sp {spanDisplayThreadId = tid'}
BS.hPutStr f $ J.toByteString $ jChromeBeginSpan sp'
BS.hPutStr f ",\n"
forM_ (sortOn spanEventTimestamp spanEvents) $ \ev -> do
BS.hPutStr f $ J.toByteString $ jChromeEvent $ ChromeEvent (modifyThreadId spanThreadId) ev
BS.hPutStr f $ J.toByteString $ jChromeEvent $ ChromeEvent tid' ev
BS.hPutStr f ",\n"
BS.hPutStr f $ J.toByteString $ jChromeEndSpan sp'
BS.hPutStr f ",\n"
Expand Down Expand Up @@ -120,9 +119,9 @@ createChromeExporter' path doWeCollapseThreads = do
(pure ())
pure (span_exporter, metric_exporter)

data DoWeCollapseThreads = CollapseThreads | SplitThreads
data ThreadPresentation = CollapseThreads | SplitThreads

eventlogToChrome :: FilePath -> FilePath -> DoWeCollapseThreads -> IO ()
eventlogToChrome :: FilePath -> FilePath -> ThreadPresentation -> IO ()
eventlogToChrome eventlogFile chromeFile doWeCollapseThreads = do
(span_exporter, metric_exporter) <- createChromeExporter' chromeFile doWeCollapseThreads
exportEventlog span_exporter metric_exporter eventlogFile
Expand Down
1 change: 1 addition & 0 deletions opentelemetry-extra/src/OpenTelemetry/Common.hs
Original file line number Diff line number Diff line change
Expand Up @@ -64,6 +64,7 @@ data Span = Span
{ spanContext :: {-# UNPACK #-} !SpanContext,
spanOperation :: T.Text,
spanThreadId :: Word32,
spanDisplayThreadId :: Word32,
spanStartedAt :: !Timestamp,
spanFinishedAt :: !Timestamp,
spanTags :: !(HM.HashMap TagName TagValue),
Expand Down
40 changes: 29 additions & 11 deletions opentelemetry-extra/src/OpenTelemetry/EventlogStreaming_Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -35,12 +35,13 @@ data WatDoOnEOF = StopOnEOF | SleepAndRetryOnEOF

data State = S
{ originTimestamp :: !Timestamp,
threadMap :: IM.IntMap ThreadId,
cap2thread :: IM.IntMap ThreadId,
spans :: HM.HashMap SpanId Span,
instrumentMap :: HM.HashMap InstrumentId CaptureInstrument,
traceMap :: HM.HashMap ThreadId TraceId,
serial2sid :: HM.HashMap Word64 SpanId,
thread2sid :: HM.HashMap ThreadId SpanId,
thread2displayThread :: HM.HashMap ThreadId ThreadId, -- https://github.com/ethercrow/opentelemetry-haskell/issues/40
gcRequestedAt :: !Timestamp,
gcStartedAt :: !Timestamp,
gcGeneration :: !Int,
Expand All @@ -52,7 +53,7 @@ data State = S
deriving (Show)

initialState :: Word64 -> R.SMGen -> State
initialState timestamp = S timestamp mempty mempty mempty mempty mempty mempty 0 0 0 0 0 0
initialState timestamp = S timestamp mempty mempty mempty mempty mempty mempty mempty 0 0 0 0 0 0

data EventSource
= EventLogHandle Handle WatDoOnEOF
Expand Down Expand Up @@ -142,9 +143,9 @@ parseOpenTelemetry UserBinaryMessage {payload} = parseByteString payload
parseOpenTelemetry _ = Nothing

processEvent :: Event -> State -> (State, [Span], [Metric])
processEvent (Event ts ev m_cap) st@(S {..}) =
processEvent (Event ts ev m_cap) st@S {..} =
let now = originTimestamp + ts
m_thread_id = m_cap >>= flip IM.lookup threadMap
m_thread_id = m_cap >>= flip IM.lookup cap2thread
m_trace_id = m_thread_id >>= flip HM.lookup traceMap
in case (ev, m_cap, m_thread_id) of
(WallClockTime {sec, nsec}, _, _) ->
Expand All @@ -158,12 +159,13 @@ processEvent (Event ts ev m_cap) st@(S {..}) =
[Metric threadsI [MetricDatapoint now 1]]
)
(RunThread tid, Just cap, _) ->
(st {threadMap = IM.insert cap tid threadMap}, [], [])
(st {cap2thread = IM.insert cap tid cap2thread}, [], [])
(StopThread tid tstatus, Just cap, _)
| isTerminalThreadStatus tstatus ->
( st
{ threadMap = IM.delete cap threadMap,
traceMap = HM.delete tid traceMap
{ cap2thread = IM.delete cap cap2thread,
traceMap = HM.delete tid traceMap,
thread2displayThread = HM.delete tid thread2displayThread
},
[],
[Metric threadsI [MetricDatapoint now (-1)]]
Expand All @@ -187,6 +189,7 @@ processEvent (Event ts ev m_cap) st@(S {..}) =
spanStartedAt = gcStartedAt,
spanFinishedAt = now,
spanThreadId = maxBound,
spanDisplayThreadId = maxBound,
spanTags = mempty,
spanEvents = [],
spanParentId = Nothing,
Expand All @@ -200,6 +203,7 @@ processEvent (Event ts ev m_cap) st@(S {..}) =
spanStartedAt = gcRequestedAt,
spanFinishedAt = gcStartedAt,
spanThreadId = maxBound,
spanDisplayThreadId = maxBound,
spanTags = mempty,
spanEvents = [],
spanParentId = Nothing,
Expand Down Expand Up @@ -284,12 +288,14 @@ handleOpenTelemetryEventlogEvent m st (tid, now, m_trace_id) =
case HM.lookup serial $ serial2sid st of
Nothing ->
let (st', span_id) = inventSpanId serial st
(st'', display_tid) = inventDisplayTid tid st'
parent = HM.lookup tid (thread2sid st)
sp =
Span
{ spanContext = SpanContext span_id (fromMaybe (TId 42) m_trace_id),
spanOperation = "",
spanThreadId = tid,
spanDisplayThreadId = display_tid,
spanStartedAt = 0,
spanFinishedAt = now,
spanTags = mempty,
Expand All @@ -298,20 +304,23 @@ handleOpenTelemetryEventlogEvent m st (tid, now, m_trace_id) =
spanNanosecondsSpentInGC = 0,
spanParentId = parent
}
in (createSpan span_id sp st', [], [])
in (createSpan span_id sp st'', [], [])
Just span_id ->
let (st', sp) = emitSpan serial span_id st
in (st', [sp {spanFinishedAt = now}], [])
(st'', display_tid) = inventDisplayTid tid st'
in (st'', [sp {spanFinishedAt = now, spanDisplayThreadId = display_tid}], [])
BeginSpanEv (SpanInFlight serial) (SpanName operation) ->
case HM.lookup serial (serial2sid st) of
Nothing ->
let (st', span_id) = inventSpanId serial st
parent = HM.lookup tid (thread2sid st)
(st'', display_tid) = inventDisplayTid tid st'
sp =
Span
{ spanContext = SpanContext span_id (fromMaybe (TId 42) m_trace_id),
spanOperation = operation,
spanThreadId = tid,
spanDisplayThreadId = display_tid,
spanStartedAt = now,
spanFinishedAt = 0,
spanTags = mempty,
Expand All @@ -320,10 +329,11 @@ handleOpenTelemetryEventlogEvent m st (tid, now, m_trace_id) =
spanNanosecondsSpentInGC = 0,
spanParentId = parent
}
in (createSpan span_id sp st', [], [])
in (createSpan span_id sp st'', [], [])
Just span_id ->
let (st', sp) = emitSpan serial span_id st
in (st', [sp {spanOperation = operation, spanStartedAt = now, spanThreadId = tid}], [])
(st'', display_tid) = inventDisplayTid tid st'
in (st'', [sp {spanOperation = operation, spanStartedAt = now, spanThreadId = tid, spanDisplayThreadId = display_tid}], [])
DeclareInstrumentEv iType iId iName ->
(st {instrumentMap = HM.insert iId (CaptureInstrument iType iName) (instrumentMap st)}, [], [])
MetricCaptureEv instrumentId val -> case HM.lookup instrumentId (instrumentMap st) of
Expand Down Expand Up @@ -396,6 +406,14 @@ inventSpanId serial st = (st', sid)
(SId -> sid, randomGen') = R.nextWord64 randomGen
st' = st {serial2sid = HM.insert serial sid serial2sid, randomGen = randomGen'}

inventDisplayTid :: ThreadId -> State -> (State, ThreadId)
inventDisplayTid tid st@(S {thread2displayThread}) =
case HM.lookup tid thread2displayThread of
Nothing ->
let new_dtid = fromIntegral (HM.size thread2displayThread)
in (st {thread2displayThread = HM.insert tid new_dtid thread2displayThread}, new_dtid)
Just dtid -> (st, dtid)

parseText :: [T.Text] -> Maybe OpenTelemetryEventlogEvent
parseText =
\case
Expand Down
5 changes: 1 addition & 4 deletions stack-8.10.yaml
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
resolver: nightly-2021-01-05
resolver: nightly-2021-04-02

packages:
- megaexample
Expand All @@ -10,8 +10,5 @@ packages:
allow-newer: true

extra-deps:
- ghc-events-0.13.0
- ghc-trace-events-0.1.0.1
- hvega-0.9.1.0
- jsonifier-0.1.0.5
- ptr-poker-0.1.1.3

0 comments on commit 66f40e5

Please sign in to comment.