Rename threads for more compact tracy visualization

.github/workflows/ci.yml

@@ -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]
@@ -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]
@@ -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]
@@ -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]

megaexample/Main.hs

@@ -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
@@ -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

opentelemetry-extra/exe/eventlog-to-tracy/Main.hs

@@ -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"

opentelemetry-extra/src/OpenTelemetry/ChromeExporter.hs

@@ -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
@@ -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
@@ -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"
@@ -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

opentelemetry-extra/src/OpenTelemetry/Common.hs

@@ -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),

opentelemetry-extra/src/OpenTelemetry/EventlogStreaming_Internal.hs

@@ -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,
@@ -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
@@ -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}, _, _) ->
@@ -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)]]
@@ -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,
@@ -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,
@@ -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,
@@ -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,
@@ -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
@@ -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

stack-8.10.yaml

@@ -1,4 +1,4 @@
-resolver: nightly-2021-01-05
+resolver: nightly-2021-04-02
 
 packages:
 - megaexample
@@ -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