-- Copyright 2018 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE NamedFieldPuns #-}
-- | Convert ghc eventlog to json for <chrome://tracing>.
module App.ConvertEventLog (main) where
import qualified Data.Aeson as Aeson
import           Data.Aeson ((.=))
import qualified Data.ByteString.Lazy as ByteString.Lazy
import qualified Data.IntMap as IntMap
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Word as Word

import qualified GHC.RTS.Events as Events
import qualified System.Environment as Environment

import qualified Util.CallStack as CallStack
import qualified Util.Lens as Lens
import qualified Util.Lists as Lists

import           Global


byHsThread :: Bool
byHsThread :: Bool
byHsThread = Bool
False

main :: IO ()
main :: IO ()
main = do
    [String]
args <- IO [String]
Environment.getArgs
    case [String]
args of
        [String
"--print", String
input] -> Bool -> String -> IO ()
Events.printEventsIncremental Bool
False String
input
        [String
"--user", String
input] ->
            [Event] -> IO ()
dumpUser -- . Lists.sortOn Events.evTime
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO [Event]
readEvents String
input
        [String
input] -> do
            [Event]
events <- String -> IO [Event]
readEvents String
input
            forall a. Show a => a -> IO ()
print (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
events)
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Show a => a -> IO ()
print forall a b. (a -> b) -> a -> b
$ [Event]
events
        [String
input, String
output] -> do
            [Event]
events <- (if Bool
byHsThread then [Event] -> [Event]
replaceCapWithTid else forall a. a -> a
id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                String -> IO [Event]
readEvents String
input
            let converted :: [Event]
converted = [Event] -> [Event]
inferDurations forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Event -> [Event]
convertEvent [Event]
events
            String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"write " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
converted) forall a. Semigroup a => a -> a -> a
<> String
" events"
            String -> [Event] -> IO ()
write String
output [Event]
converted
        [String]
_ -> String -> IO ()
putStrLn String
"usage"

readEvents :: FilePath -> IO [Events.Event]
readEvents :: String -> IO [Event]
readEvents = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Data -> [Event]
Events.events forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventLog -> Data
Events.dat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO EventLog
readLog

readLog :: FilePath -> IO Events.EventLog
readLog :: String -> IO EventLog
readLog = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
CallStack.errorIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) forall (m :: * -> *) a. Monad m => a -> m a
return
    forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> IO (Either String EventLog)
Events.readEventLogFromFile

-- | Write user events in a format for tools/parse_timing.py.
dumpUser :: [Events.Event] -> IO ()
dumpUser :: [Event] -> IO ()
dumpUser [Event]
events = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event]
events forall a b. (a -> b) -> a -> b
$ \case
    Events.Event { Nanosecond
evTime :: Event -> Nanosecond
evTime :: Nanosecond
evTime, evSpec :: Event -> EventInfo
Events.evSpec = Events.UserMessage Text
msg } ->
        Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords [forall a. Show a => a -> Text
showt (Nanosecond -> Double
nsToSec Nanosecond
evTime), Text
msg]
    Events.Event { Nanosecond
evTime :: Nanosecond
evTime :: Event -> Nanosecond
evTime, evSpec :: Event -> EventInfo
Events.evSpec = Events.UserMarker Text
msg } ->
        Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords [forall a. Show a => a -> Text
showt (Nanosecond -> Double
nsToSec Nanosecond
evTime), Text
msg]
    Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

write :: FilePath -> [Event] -> IO ()
write :: String -> [Event] -> IO ()
write String
fname [Event]
events = String -> ByteString -> IO ()
ByteString.Lazy.writeFile String
fname forall a b. (a -> b) -> a -> b
$
    (ByteString
"[\n"<>) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<>ByteString
",\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encode) [Event]
events
    -- Chrome explicitly supports no trailing ]
    -- I could do Aeson.encode events, but then there are no newlines and it's
    -- annoying to view.

-- | Replace evCap with the thread ID running on that HEC.
replaceCapWithTid :: [Events.Event] -> [Events.Event]
replaceCapWithTid :: [Event] -> [Event]
replaceCapWithTid = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL IntMap Int -> Event -> (IntMap Int, Event)
go forall a. Monoid a => a
mempty
    where
    go :: IntMap Int -> Event -> (IntMap Int, Event)
go IntMap Int
capToThread_ Event
e = case Event -> Maybe Int
Events.evCap Event
e of
        Maybe Int
Nothing -> (IntMap Int
capToThread_, Event
e)
        Just Int
cap -> case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
cap IntMap Int
capToThread of
            Maybe Int
Nothing -> (IntMap Int
capToThread, Event
e)
            Just Int
tid -> (IntMap Int
capToThread, Event
e { evCap :: Maybe Int
Events.evCap = forall a. a -> Maybe a
Just Int
tid })
            where capToThread :: IntMap Int
capToThread = forall {a}. Num a => Int -> EventInfo -> IntMap a -> IntMap a
update Int
cap (Event -> EventInfo
Events.evSpec Event
e) IntMap Int
capToThread_
    update :: Int -> EventInfo -> IntMap a -> IntMap a
update Int
cap EventInfo
e = case EventInfo
e of
        Events.RunThread ThreadId
tid -> forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
cap (forall a b. (Integral a, Num b) => a -> b
fromIntegral ThreadId
tid)
        EventInfo
_ -> forall a. a -> a
id

-- TODO not integrated yet, but only makes sense if byHsThread
convertMetadata :: Events.EventInfo -> Maybe Detail
convertMetadata :: EventInfo -> Maybe Detail
convertMetadata EventInfo
spec = case EventInfo
spec of
    Events.ThreadLabel ThreadId
tid Text
label -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Detail
        { _categories :: [Text]
_categories = [Text
cGhc, Text
"thread"]
        , _name :: Text
_name = Text
"ThreadLabel"
        , _phase :: Phase
_phase = Metadata -> Phase
PMetadata forall a b. (a -> b) -> a -> b
$ Text -> Metadata
ThreadName Text
label
        , _args :: [(Text, Text)]
_args = []
        }
    EventInfo
_ -> forall a. Maybe a
Nothing

-- * convert

convertEvent :: Events.Event -> [Event]
convertEvent :: Event -> [Event]
convertEvent Event
e = do
    Int
capability <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Event -> Maybe Int
Events.evCap [Event
e]
    Detail
detail <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ Event -> EventInfo
Events.evSpec Event
e) [EventInfo -> Maybe Detail
convertGc, EventInfo -> Maybe Detail
convertUser]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Event
        { _processId :: Int
_processId = Int
1
        , _threadId :: Int
_threadId = Int
capability
        , _timestamp :: Nanosecond
_timestamp = Event -> Nanosecond
Events.evTime Event
e forall a. Integral a => a -> a -> a
`div` Nanosecond
1000
        , _detail :: Detail
_detail = Detail
detail
        }

convertUser :: Events.EventInfo -> Maybe Detail
convertUser :: EventInfo -> Maybe Detail
convertUser = \case
    Events.UserMessage Text
msg -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case Text -> [Text]
Text.words Text
msg of
        Text
"respond" : [Text]
args ->
            Text -> Int -> AsyncPhase -> [(Text, Text)] -> Detail
async Text
"respond" Int
1 AsyncPhase
AsyncBegin [(Text
"msg", [Text] -> Text
Text.unwords [Text]
args)]
        [Text
"wait"] -> Text -> Int -> AsyncPhase -> [(Text, Text)] -> Detail
async Text
"respond" Int
1 AsyncPhase
AsyncEnd []
        -- _ | msg `Set.member` respondCycle -> complete msg
        [Text]
_ -> Text -> [(Text, Text)] -> Phase -> Detail
detail Text
msg [] Phase
PMark
    EventInfo
_ -> forall a. Maybe a
Nothing
    where
    -- complete name = detail name [] $ PComplete (Complete Nothing)
    async :: Text -> Int -> AsyncPhase -> [(Text, Text)] -> Detail
async Text
name Int
id AsyncPhase
phase [(Text, Text)]
args = Text -> [(Text, Text)] -> Phase -> Detail
detail Text
name [(Text, Text)]
args forall a b. (a -> b) -> a -> b
$ Async -> Phase
PAsync forall a b. (a -> b) -> a -> b
$ Async
        { _asyncId :: Int
_asyncId = Int
id
        , _asyncPhase :: AsyncPhase
_asyncPhase = AsyncPhase
phase
        , _asyncScope :: Maybe Text
_asyncScope = forall a. Maybe a
Nothing
        }
    detail :: Text -> [(Text, Text)] -> Phase -> Detail
detail Text
name [(Text, Text)]
args Phase
phase = Detail
        { _categories :: [Text]
_categories = [Text
"user"]
        , _name :: Text
_name = Text
name
        , _phase :: Phase
_phase = Phase
phase
        , _args :: [(Text, Text)]
_args = [(Text, Text)]
args
        }

-- | Add durations for respondCycle events.
inferDurations :: [Event] -> [Event]
inferDurations :: [Event] -> [Event]
inferDurations = forall a b. (a -> b) -> [a] -> [b]
map (Event, [Event]) -> Event
infer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, [a])]
Lists.zipNexts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn Event -> Nanosecond
_timestamp
    where
    infer :: (Event, [Event]) -> Event
infer (Event
e, [Event]
nexts)
        | Event -> Bool
inCycle Event
e, Just Nanosecond
end <- [Event] -> Maybe Nanosecond
find [Event]
nexts = (forall a b. (a -> b) -> a -> b
$Event
e) forall a b. (a -> b) -> a -> b
$
            Event :-> Detail
detailforall a b c. Lens a b -> Lens b c -> Lens a c
#Detail :-> Phase
phase forall f a. Lens f a -> a -> f -> f
#= Complete -> Phase
PComplete (Maybe Nanosecond -> Complete
Complete (forall a. a -> Maybe a
Just (Nanosecond
end forall a. Num a => a -> a -> a
- Event -> Nanosecond
_timestamp Event
e)))
    infer (Event
e, [Event]
_) = Event
e
    inCycle :: Event -> Bool
inCycle Event
e = Detail -> Text
_name (Event -> Detail
_detail Event
e) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
respondCycle
    find :: [Event] -> Maybe Nanosecond
find = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> Nanosecond
_timestamp
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\Event
e -> Event -> Bool
inCycle Event
e Bool -> Bool -> Bool
|| Detail -> Text
_name (Event -> Detail
_detail Event
e) forall a. Eq a => a -> a -> Bool
== Text
"respond")
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Eq a => a -> a -> Bool
/= Text
"respond") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Detail -> Text
_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Detail
_detail)

-- These should occur after "respond" and before "wait".
respondCycle :: Set Text
respondCycle :: Set Text
respondCycle = forall a. Ord a => [a] -> Set a
Set.fromList
    [ Text
"keys", Text
"ui_updates", Text
"cmds"
    , Text
"ky", Text
"sync", Text
"derive", Text
"undo"
    ]
    -- These are in the expected order.

convertGc :: Events.EventInfo -> Maybe Detail
convertGc :: EventInfo -> Maybe Detail
convertGc EventInfo
spec = do
    Phase
phase <- case EventInfo
spec of
        EventInfo
Events.StartGC -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Duration -> Phase
PDuration Duration
Begin
        EventInfo
Events.EndGC -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Duration -> Phase
PDuration Duration
End
        EventInfo
_ -> forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Detail
        { _categories :: [Text]
_categories = [Text
cGhc, Text
"gc"]
        , _name :: Text
_name = Text
"gc"
        , _phase :: Phase
_phase = Phase
phase
        , _args :: [(Text, Text)]
_args = []
        }

{-
    Copied from GHC source:

             GCStart     GCWork      GCIdle      GCEnd
    gc start -----> work -----> idle ------+> done -----> gc end
                     |                     |
                     `-------<-------<-----'

    My on notes:

    RequestParGC -> GCWork -> {GCIdle, GCDone}
        -> GlobalSyncGC -> GCStatsGHC -> EndGC
-}

-- TODO there are too many short-lived threads for this to be useful, since
-- chrome doesn't collapse them vertically.
_convertThread :: Events.EventInfo -> Maybe Detail
_convertThread :: EventInfo -> Maybe Detail
_convertThread EventInfo
spec = do
    Async
phase <- case EventInfo
spec of
        Events.CreateThread ThreadId
_tid -> forall a. Maybe a
Nothing
        Events.RunThread ThreadId
tid -> forall {a}. Integral a => a -> AsyncPhase -> Maybe Async
flow ThreadId
tid AsyncPhase
AsyncBegin
        Events.StopThread ThreadId
tid ThreadStopStatus
_status -> forall {a}. Integral a => a -> AsyncPhase -> Maybe Async
flow ThreadId
tid AsyncPhase
AsyncEnd
        Events.ThreadRunnable ThreadId
_tid -> forall a. Maybe a
Nothing
        Events.MigrateThread ThreadId
_tid Int
_newCap -> forall a. Maybe a
Nothing
        Events.WakeupThread ThreadId
_tid Int
_otherCap -> forall a. Maybe a
Nothing
        Events.ThreadLabel ThreadId
_tid Text
_label -> forall a. Maybe a
Nothing -- metadata?
            -- TODO associate with this tid and put it in the _name
        EventInfo
_ -> forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Detail
        { _categories :: [Text]
_categories = [Text
cGhc, Text
"thread"]
        , _name :: Text
_name = Text
"thread " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Async -> Int
_asyncId Async
phase)
        , _phase :: Phase
_phase = Async -> Phase
PAsync Async
phase
        , _args :: [(Text, Text)]
_args = case EventInfo
spec of
            Events.StopThread ThreadId
_tid ThreadStopStatus
status -> case ThreadStopStatus
status of
                ThreadStopStatus
Events.NoStatus -> []
                ThreadStopStatus
_ -> [(Text
"stop", forall a. Show a => a -> Text
showt ThreadStopStatus
status)]
            EventInfo
_ -> []
        }
    where
    flow :: a -> AsyncPhase -> Maybe Async
flow a
id AsyncPhase
phase = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Async
        { _asyncId :: Int
_asyncId = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
id
        , _asyncPhase :: AsyncPhase
_asyncPhase = AsyncPhase
phase
        , _asyncScope :: Maybe Text
_asyncScope = forall a. Maybe a
Nothing
        }

cGhc :: Text
cGhc :: Text
cGhc = Text
"ghc"

-- * Event

data Event = Event {
    Event -> Int
_processId :: !Int
    , Event -> Int
_threadId :: !Int
    , Event -> Nanosecond
_timestamp :: !Nanosecond
    , Event -> Detail
_detail :: !Detail
    } deriving (Event -> Event -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq, Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show)

detail :: Event :-> Detail
detail = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Event -> Detail
_detail (\Detail -> Detail
f Event
r -> Event
r { _detail :: Detail
_detail = Detail -> Detail
f (Event -> Detail
_detail Event
r) })

data Detail = Detail {
    Detail -> [Text]
_categories :: ![Text]
    , Detail -> Text
_name :: !Text
    , Detail -> Phase
_phase :: !Phase
    , Detail -> [(Text, Text)]
_args :: ![(Text, Text)]
    -- Additional fields:
    -- tts: Optional. The thread clock timestamp of the event. The timestamps
    -- are provided at microsecond granularity.
    -- cname: A fixed color name to associate with the event. If provided,
    -- cname must be one of the names listed in trace-viewer's base color
    -- scheme's reserved color names list
    } deriving (Detail -> Detail -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Detail -> Detail -> Bool
$c/= :: Detail -> Detail -> Bool
== :: Detail -> Detail -> Bool
$c== :: Detail -> Detail -> Bool
Eq, Int -> Detail -> ShowS
[Detail] -> ShowS
Detail -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Detail] -> ShowS
$cshowList :: [Detail] -> ShowS
show :: Detail -> String
$cshow :: Detail -> String
showsPrec :: Int -> Detail -> ShowS
$cshowsPrec :: Int -> Detail -> ShowS
Show)

phase :: Detail :-> Phase
phase = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Detail -> Phase
_phase (\Phase -> Phase
f Detail
r -> Detail
r { _phase :: Phase
_phase = Phase -> Phase
f (Detail -> Phase
_phase Detail
r) })

type Nanosecond = Word.Word64

nsToSec :: Nanosecond -> Double
nsToSec :: Nanosecond -> Double
nsToSec = (forall a. Fractional a => a -> a -> a
/Double
1_000_000_000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Aeson.ToJSON Event where
    toEncoding :: Event -> Encoding
toEncoding (Event Int
pid Int
tid Nanosecond
ts (Detail [Text]
cats Text
name Phase
phase_ [(Text, Text)]
args)) =
        Series -> Encoding
Aeson.pairs forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
            [ Key
"cat" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
cats
            , Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name
            , Key
"args" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
args
            , Key
"pid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
pid
            , Key
"tid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
tid
            , Key
"ts" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Nanosecond
ts
            , Key
"ph" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
phase
            ] forall a. [a] -> [a] -> [a]
++ [Key
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v | (Key
k, Value
v) <- [(Key, Value)]
fields]
        where
        (Value
phase, [(Key, Value)]
fields) = forall a. Convert a => a -> (Value, [(Key, Value)])
convert Phase
phase_
        -- TODO ensure later fields override earlier ones

    -- TODO how to remove the duplication?
    toJSON :: Event -> Value
toJSON (Event Int
pid Int
tid Nanosecond
ts (Detail [Text]
cats Text
name Phase
_phase [(Text, Text)]
args)) = [(Key, Value)] -> Value
Aeson.object
        [ Key
"cat" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
cats
        , Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name
        , Key
"args" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Text, Text)]
args
        , Key
"pid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
pid
        , Key
"tid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
tid
        , Key
"ts" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Nanosecond
ts
        -- , "ph" .= phase
        ]

class Convert a where
    -- (value for ph field, extra fields for the top level)
    convert :: a -> (Aeson.Value, [(Aeson.Key, Aeson.Value)])

data Phase = PDuration !Duration | PComplete !Complete | PInstant !Instant
    | PCounter !Counter | PAsync !Async | PFlow !Flow | PMetadata !Metadata
    -- | PMemoryDump !MemoryDump
    -- | Mark events are created whenever a corresponding navigation timing API
    -- mark is created.
    | PMark
    deriving (Phase -> Phase -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Phase -> Phase -> Bool
$c/= :: Phase -> Phase -> Bool
== :: Phase -> Phase -> Bool
$c== :: Phase -> Phase -> Bool
Eq, Int -> Phase -> ShowS
[Phase] -> ShowS
Phase -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Phase] -> ShowS
$cshowList :: [Phase] -> ShowS
show :: Phase -> String
$cshow :: Phase -> String
showsPrec :: Int -> Phase -> ShowS
$cshowsPrec :: Int -> Phase -> ShowS
Show)

instance Convert Phase where
    convert :: Phase -> (Value, [(Key, Value)])
convert = \case
        PDuration Duration
duration -> forall a. Convert a => a -> (Value, [(Key, Value)])
convert Duration
duration
        PComplete Complete
complete -> forall a. Convert a => a -> (Value, [(Key, Value)])
convert Complete
complete
        PInstant Instant
instant -> forall a. Convert a => a -> (Value, [(Key, Value)])
convert Instant
instant
        PCounter Counter
counter -> forall a. Convert a => a -> (Value, [(Key, Value)])
convert Counter
counter
        PAsync Async
async -> forall a. Convert a => a -> (Value, [(Key, Value)])
convert Async
async
        PFlow Flow
flow -> forall a. Convert a => a -> (Value, [(Key, Value)])
convert Flow
flow
        PMetadata Metadata
metadata -> forall a. Convert a => a -> (Value, [(Key, Value)])
convert Metadata
metadata
        -- PMemoryDump memoryDump -> convert memoryDump
        Phase
PMark -> (Value
"R", [])

-- | These must be strictly nested.
--
-- For Begin events, either stack=[TextFrame], or sf=Int, index into
-- stackFrames map in metadata.
data Duration = Begin | End deriving (Duration -> Duration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Duration -> Duration -> Bool
$c/= :: Duration -> Duration -> Bool
== :: Duration -> Duration -> Bool
$c== :: Duration -> Duration -> Bool
Eq, Int -> Duration -> ShowS
[Duration] -> ShowS
Duration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Duration] -> ShowS
$cshowList :: [Duration] -> ShowS
show :: Duration -> String
$cshow :: Duration -> String
showsPrec :: Int -> Duration -> ShowS
$cshowsPrec :: Int -> Duration -> ShowS
Show)

instance Convert Duration where
    convert :: Duration -> (Value, [(Key, Value)])
convert = \case
        Duration
Begin -> (Value
"B", [])
        Duration
End -> (Value
"E", [])

-- tdur=thread clock duration.  Also could have stack or sf.
data Complete = Complete !(Maybe Nanosecond) deriving (Complete -> Complete -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Complete -> Complete -> Bool
$c/= :: Complete -> Complete -> Bool
== :: Complete -> Complete -> Bool
$c== :: Complete -> Complete -> Bool
Eq, Int -> Complete -> ShowS
[Complete] -> ShowS
Complete -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Complete] -> ShowS
$cshowList :: [Complete] -> ShowS
show :: Complete -> String
$cshow :: Complete -> String
showsPrec :: Int -> Complete -> ShowS
$cshowsPrec :: Int -> Complete -> ShowS
Show)

instance Convert Complete where
    convert :: Complete -> (Value, [(Key, Value)])
convert (Complete Maybe Nanosecond
dur) =
        (Value
"X", forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"dur",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
Aeson.toJSON) Maybe Nanosecond
dur)

data Instant = Instant !InstantScope deriving (Instant -> Instant -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Instant -> Instant -> Bool
$c/= :: Instant -> Instant -> Bool
== :: Instant -> Instant -> Bool
$c== :: Instant -> Instant -> Bool
Eq, Int -> Instant -> ShowS
[Instant] -> ShowS
Instant -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instant] -> ShowS
$cshowList :: [Instant] -> ShowS
show :: Instant -> String
$cshow :: Instant -> String
showsPrec :: Int -> Instant -> ShowS
$cshowsPrec :: Int -> Instant -> ShowS
Show)
data InstantScope = Global | Process | Thread deriving (InstantScope -> InstantScope -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InstantScope -> InstantScope -> Bool
$c/= :: InstantScope -> InstantScope -> Bool
== :: InstantScope -> InstantScope -> Bool
$c== :: InstantScope -> InstantScope -> Bool
Eq, Int -> InstantScope -> ShowS
[InstantScope] -> ShowS
InstantScope -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InstantScope] -> ShowS
$cshowList :: [InstantScope] -> ShowS
show :: InstantScope -> String
$cshow :: InstantScope -> String
showsPrec :: Int -> InstantScope -> ShowS
$cshowsPrec :: Int -> InstantScope -> ShowS
Show)

instance Convert Instant where
    convert :: Instant -> (Value, [(Key, Value)])
convert (Instant InstantScope
scope) = (Value
"i",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"s",) forall a b. (a -> b) -> a -> b
$ case InstantScope
scope of
        InstantScope
Global -> Value
"g"
        InstantScope
Process -> Value
"p"
        InstantScope
Thread -> Value
"t"

data Counter = Counter !(Map Text Int)
    deriving (Counter -> Counter -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Counter -> Counter -> Bool
$c/= :: Counter -> Counter -> Bool
== :: Counter -> Counter -> Bool
$c== :: Counter -> Counter -> Bool
Eq, Int -> Counter -> ShowS
[Counter] -> ShowS
Counter -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Counter] -> ShowS
$cshowList :: [Counter] -> ShowS
show :: Counter -> String
$cshow :: Counter -> String
showsPrec :: Int -> Counter -> ShowS
$cshowsPrec :: Int -> Counter -> ShowS
Show)

instance Convert Counter where
    convert :: Counter -> (Value, [(Key, Value)])
convert (Counter Map Text Int
args) = (Value
"C", [(Key
"args", forall a. ToJSON a => a -> Value
Aeson.toJSON Map Text Int
args)])

-- We consider the events with the same category and id as events from the same
-- event tree.
data Async = Async {
    Async -> Int
_asyncId :: !Int
    , Async -> AsyncPhase
_asyncPhase :: !AsyncPhase
    -- | Differentiate events with the same id.
    , Async -> Maybe Text
_asyncScope :: !(Maybe Text)
    } deriving (Async -> Async -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Async -> Async -> Bool
$c/= :: Async -> Async -> Bool
== :: Async -> Async -> Bool
$c== :: Async -> Async -> Bool
Eq, Int -> Async -> ShowS
[Async] -> ShowS
Async -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Async] -> ShowS
$cshowList :: [Async] -> ShowS
show :: Async -> String
$cshow :: Async -> String
showsPrec :: Int -> Async -> ShowS
$cshowsPrec :: Int -> Async -> ShowS
Show)
data AsyncPhase = AsyncBegin | AsyncInstant | AsyncEnd
    deriving (AsyncPhase -> AsyncPhase -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AsyncPhase -> AsyncPhase -> Bool
$c/= :: AsyncPhase -> AsyncPhase -> Bool
== :: AsyncPhase -> AsyncPhase -> Bool
$c== :: AsyncPhase -> AsyncPhase -> Bool
Eq, Int -> AsyncPhase -> ShowS
[AsyncPhase] -> ShowS
AsyncPhase -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AsyncPhase] -> ShowS
$cshowList :: [AsyncPhase] -> ShowS
show :: AsyncPhase -> String
$cshow :: AsyncPhase -> String
showsPrec :: Int -> AsyncPhase -> ShowS
$cshowsPrec :: Int -> AsyncPhase -> ShowS
Show)

instance Convert Async where
    convert :: Async -> (Value, [(Key, Value)])
convert (Async Int
id AsyncPhase
phase Maybe Text
scope) =
        (Value
ph, forall a k.
ToJSON a =>
k -> Maybe a -> [(k, Value)] -> [(k, Value)]
add Key
"scope" Maybe Text
scope [(Key
"id", forall a. ToJSON a => a -> Value
Aeson.toJSON Int
id)])
        where
        ph :: Value
ph = case AsyncPhase
phase of
            AsyncPhase
AsyncBegin -> Value
"b"
            AsyncPhase
AsyncInstant -> Value
"n"
            AsyncPhase
AsyncEnd -> Value
"e"

-- | These only show up if they have enclosing Durations.
--
-- Official doc: The flow events are very similar in concept to the Async
-- events, but allow duration to be associated with each other across
-- threads/processes.  Visually, think of a flow event as an arrow between two
-- duration events.  With flow events, each event will be drawn in the thread
-- it is emitted from.  The events will be linked together in Trace Viewer
-- using lines and arrows.
data Flow = Flow {
    Flow -> Int
_flowId :: !Int
    , Flow -> AsyncPhase
_flowPhase :: !AsyncPhase
    -- | Differentiate events with the same id.
    , Flow -> Maybe Text
_flowScope :: !(Maybe Text)
    } deriving (Flow -> Flow -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flow -> Flow -> Bool
$c/= :: Flow -> Flow -> Bool
== :: Flow -> Flow -> Bool
$c== :: Flow -> Flow -> Bool
Eq, Int -> Flow -> ShowS
[Flow] -> ShowS
Flow -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flow] -> ShowS
$cshowList :: [Flow] -> ShowS
show :: Flow -> String
$cshow :: Flow -> String
showsPrec :: Int -> Flow -> ShowS
$cshowsPrec :: Int -> Flow -> ShowS
Show)

instance Convert Flow where
    convert :: Flow -> (Value, [(Key, Value)])
convert (Flow Int
id AsyncPhase
phase Maybe Text
scope) =
        (Value
ph, forall a k.
ToJSON a =>
k -> Maybe a -> [(k, Value)] -> [(k, Value)]
add Key
"scope" Maybe Text
scope [(Key
"id", forall a. ToJSON a => a -> Value
Aeson.toJSON Int
id)])
        where
        ph :: Value
ph = case AsyncPhase
phase of
            AsyncPhase
AsyncBegin -> Value
"s"
            AsyncPhase
AsyncInstant -> Value
"t"
            AsyncPhase
AsyncEnd -> Value
"f"

-- There are currently 5 possible metadata items that can be provided:
data Metadata =
    -- | Sets the display name for the provided pid. The name is provided in
    -- a name argument.
    ProcessName !Text
    -- | Sets the extra process labels for the provided pid. The label is
    -- provided in a labels argument.
    | ProcessLabels !Text
    -- | Sets the process sort order position. The sort index is provided in
    -- a sort_index argument.
    | ProcessSortIndex !Int
    -- | Sets the name for the given tid. The name is provided in a name
    -- argument.
    | ThreadName !Text
    -- Sets the thread sort order position. The sort index is provided in
    -- a sort_index argument.
    | ThreadSortIndex !Int
    deriving (Metadata -> Metadata -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Metadata -> Metadata -> Bool
$c/= :: Metadata -> Metadata -> Bool
== :: Metadata -> Metadata -> Bool
$c== :: Metadata -> Metadata -> Bool
Eq, Int -> Metadata -> ShowS
[Metadata] -> ShowS
Metadata -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metadata] -> ShowS
$cshowList :: [Metadata] -> ShowS
show :: Metadata -> String
$cshow :: Metadata -> String
showsPrec :: Int -> Metadata -> ShowS
$cshowsPrec :: Int -> Metadata -> ShowS
Show)

instance Convert Metadata where
    convert :: Metadata -> (Value, [(Key, Value)])
convert Metadata
m = (Value
"M",) forall a b. (a -> b) -> a -> b
$ case Metadata
m of
        ProcessName Text
name ->
            [ (Key
"name", Value
"thread_name")
            , (Key
"args", [(Key, Value)] -> Value
Aeson.object [(Key
"name", forall a. ToJSON a => a -> Value
Aeson.toJSON Text
name)])
            ]
        ThreadName Text
name ->
            [ (Key
"name", Value
"thread_name")
            , (Key
"args", [(Key, Value)] -> Value
Aeson.object [(Key
"name", forall a. ToJSON a => a -> Value
Aeson.toJSON Text
name)])
            ]
        ProcessLabels Text
label ->
            [ (Key
"name", Value
"process_labels")
            , (Key
"args", [(Key, Value)] -> Value
Aeson.object [(Key
"labels", forall a. ToJSON a => a -> Value
Aeson.toJSON Text
label)])
            ]
        ProcessSortIndex Int
index ->
            [ (Key
"name", Value
"process_sort_index")
            , (Key
"args", [(Key, Value)] -> Value
Aeson.object [(Key
"sort_index", forall a. ToJSON a => a -> Value
Aeson.toJSON Int
index)])
            ]
        ThreadSortIndex Int
index ->
            [ (Key
"name", Value
"thread_sort_index")
            , (Key
"args", [(Key, Value)] -> Value
Aeson.object [(Key
"sort_index", forall a. ToJSON a => a -> Value
Aeson.toJSON Int
index)])
            ]

-- | Memory dump events correspond to memory dumps of (groups of) processes.
-- There are two types of memory dump events:
--
-- - Global memory dump events, which contain system memory information such as
-- the size of RAM, are denoted by the V phase type and
--
-- - Process memory dump events, which contain information about a single
-- process’s memory usage (e.g. total allocated memory), are denoted by the
-- v phase type.
data MemoryDump = MemoryDump {
    MemoryDump -> MemoryScope
_mScope :: !MemoryScope
    , MemoryDump -> ()
_mDump :: () -- TODO, maybe I can use GCStatsGHC?
    } deriving (MemoryDump -> MemoryDump -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MemoryDump -> MemoryDump -> Bool
$c/= :: MemoryDump -> MemoryDump -> Bool
== :: MemoryDump -> MemoryDump -> Bool
$c== :: MemoryDump -> MemoryDump -> Bool
Eq, Int -> MemoryDump -> ShowS
[MemoryDump] -> ShowS
MemoryDump -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MemoryDump] -> ShowS
$cshowList :: [MemoryDump] -> ShowS
show :: MemoryDump -> String
$cshow :: MemoryDump -> String
showsPrec :: Int -> MemoryDump -> ShowS
$cshowsPrec :: Int -> MemoryDump -> ShowS
Show)
data MemoryScope = MemoryGlobal | MemoryProcess deriving (MemoryScope -> MemoryScope -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MemoryScope -> MemoryScope -> Bool
$c/= :: MemoryScope -> MemoryScope -> Bool
== :: MemoryScope -> MemoryScope -> Bool
$c== :: MemoryScope -> MemoryScope -> Bool
Eq, Int -> MemoryScope -> ShowS
[MemoryScope] -> ShowS
MemoryScope -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MemoryScope] -> ShowS
$cshowList :: [MemoryScope] -> ShowS
show :: MemoryScope -> String
$cshow :: MemoryScope -> String
showsPrec :: Int -> MemoryScope -> ShowS
$cshowsPrec :: Int -> MemoryScope -> ShowS
Show)

-- * util

add :: Aeson.ToJSON a => k -> Maybe a -> [(k, Aeson.Value)]
    -> [(k, Aeson.Value)]
add :: forall a k.
ToJSON a =>
k -> Maybe a -> [(k, Value)] -> [(k, Value)]
add k
k Maybe a
mbV [(k, Value)]
xs = case Maybe a
mbV of
    Maybe a
Nothing -> [(k, Value)]
xs
    Just a
v -> (k
k, forall a. ToJSON a => a -> Value
Aeson.toJSON a
v) forall a. a -> [a] -> [a]
: [(k, Value)]
xs

{-
data EventInfo
    -- pseudo events
    = EventBlock         { end_time   :: Timestamp,
                           cap        :: Int,
                           block_size :: BlockSize
                         }
    | UnknownEvent       { ref  :: {-# UNPACK #-}!EventTypeNum }

    -- init and shutdown
    | Startup            { n_caps :: Int
                         }
    -- EVENT_SHUTDOWN is replaced by EVENT_CAP_DELETE and GHC 7.6+
    -- no longer generate the event; should be removed at some point
    | Shutdown           { }

    -- thread scheduling
    | CreateThread       { thread :: {-# UNPACK #-}!ThreadId
                         }
    | RunThread          { thread :: {-# UNPACK #-}!ThreadId
                         }
    | StopThread         { thread :: {-# UNPACK #-}!ThreadId,
                           status :: !ThreadStopStatus
                         }
    | ThreadRunnable     { thread :: {-# UNPACK #-}!ThreadId
                         }
    | MigrateThread      { thread :: {-# UNPACK #-}!ThreadId,
                           newCap :: {-# UNPACK #-}!Int
                         }
    | WakeupThread       { thread :: {-# UNPACK #-}!ThreadId,
                           otherCap :: {-# UNPACK #-}!Int
                         }
    | ThreadLabel        { thread :: {-# UNPACK #-}!ThreadId,
                           threadlabel :: String
                         }

    -- par sparks
    | CreateSparkThread  { sparkThread :: {-# UNPACK #-}!ThreadId
                         }
    | SparkCounters      { sparksCreated, sparksDud, sparksOverflowed,
                           sparksConverted, sparksFizzled, sparksGCd,
                           sparksRemaining :: {-# UNPACK #-}! Word64
                         }
    | SparkCreate        { }
    | SparkDud           { }
    | SparkOverflow      { }
    | SparkRun           { }
    | SparkSteal         { victimCap :: {-# UNPACK #-}!Int }
    | SparkFizzle        { }
    | SparkGC            { }

    -- tasks
    | TaskCreate         { taskId :: TaskId,
                           cap :: {-# UNPACK #-}!Int,
                           tid :: {-# UNPACK #-}!KernelThreadId
                         }
    | TaskMigrate        { taskId :: TaskId,
                           cap :: {-# UNPACK #-}!Int,
                           new_cap :: {-# UNPACK #-}!Int
                         }
    | TaskDelete         { taskId :: TaskId }

    -- garbage collection
    | RequestSeqGC       { }
    | RequestParGC       { }
    | StartGC            { }
    | GCWork             { }
    | GCIdle             { }
    | GCDone             { }
    | EndGC              { }
    | GlobalSyncGC       { }
    | GCStatsGHC         { heapCapset   :: {-# UNPACK #-}!Capset
                         , gen          :: {-# UNPACK #-}!Int
                         , copied       :: {-# UNPACK #-}!Word64
                         , slop, frag   :: {-# UNPACK #-}!Word64
                         , parNThreads  :: {-# UNPACK #-}!Int
                         , parMaxCopied :: {-# UNPACK #-}!Word64
                         , parTotCopied :: {-# UNPACK #-}!Word64
                         }

    -- heap statistics
    | HeapAllocated      { heapCapset  :: {-# UNPACK #-}!Capset
                         , allocBytes  :: {-# UNPACK #-}!Word64
                         }
    | HeapSize           { heapCapset  :: {-# UNPACK #-}!Capset
                         , sizeBytes   :: {-# UNPACK #-}!Word64
                         }
    | HeapLive           { heapCapset  :: {-# UNPACK #-}!Capset
                         , liveBytes   :: {-# UNPACK #-}!Word64
                         }
    | HeapInfoGHC        { heapCapset    :: {-# UNPACK #-}!Capset
                         , gens          :: {-# UNPACK #-}!Int
                         , maxHeapSize   :: {-# UNPACK #-}!Word64
                         , allocAreaSize :: {-# UNPACK #-}!Word64
                         , mblockSize    :: {-# UNPACK #-}!Word64
                         , blockSize     :: {-# UNPACK #-}!Word64
                         }

    -- adjusting the number of capabilities on the fly
    | CapCreate          { cap :: {-# UNPACK #-}!Int
                         }
    | CapDelete          { cap :: {-# UNPACK #-}!Int
                         }
    | CapDisable         { cap :: {-# UNPACK #-}!Int
                         }
    | CapEnable          { cap :: {-# UNPACK #-}!Int
                         }

    -- capability sets
    | CapsetCreate       { capset     :: {-# UNPACK #-}!Capset
                         , capsetType :: CapsetType
                         }
    | CapsetDelete       { capset :: {-# UNPACK #-}!Capset
                         }
    | CapsetAssignCap    { capset :: {-# UNPACK #-}!Capset
                         , cap    :: {-# UNPACK #-}!Int
                         }
    | CapsetRemoveCap    { capset :: {-# UNPACK #-}!Capset
                         , cap    :: {-# UNPACK #-}!Int
                         }

    -- program/process info
    | RtsIdentifier      { capset :: {-# UNPACK #-}!Capset
                         , rtsident :: String
                         }
    | ProgramArgs        { capset :: {-# UNPACK #-}!Capset
                         , args   :: [String]
                         }
    | ProgramEnv         { capset :: {-# UNPACK #-}!Capset
                         , env    :: [String]
                         }
    | OsProcessPid       { capset :: {-# UNPACK #-}!Capset
                         , pid    :: {-# UNPACK #-}!PID
                         }
    | OsProcessParentPid { capset :: {-# UNPACK #-}!Capset
                         , ppid   :: {-# UNPACK #-}!PID
                         }
    | WallClockTime      { capset :: {-# UNPACK #-}!Capset
                         , sec    :: {-# UNPACK #-}!Word64
                         , nsec   :: {-# UNPACK #-}!Word32
                         }

    -- messages
    | Message            { msg :: String }
    | UserMessage        { msg :: String }
    | UserMarker         { markername :: String }

    -- Events emitted by a parallel RTS
     -- Program /process info (tools might prefer newer variants above)
    | Version            { version :: String }
    | ProgramInvocation  { commandline :: String }
     -- startup and shutdown (incl. real start time, not first log entry)
    | CreateMachine      { machine :: {-# UNPACK #-} !MachineId,
                           realtime    :: {-# UNPACK #-} !Timestamp}
    | KillMachine        { machine ::  {-# UNPACK #-} !MachineId }
     -- Haskell processes mgmt (thread groups that share heap and communicate)
    | CreateProcess      { process :: {-# UNPACK #-} !ProcessId }
    | KillProcess        { process :: {-# UNPACK #-} !ProcessId }
    | AssignThreadToProcess { thread :: {-# UNPACK #-} !ThreadId,
                              process :: {-# UNPACK #-} !ProcessId
                            }
     -- communication between processes
    | EdenStartReceive   { }
    | EdenEndReceive     { }
    | SendMessage        { mesTag :: !MessageTag,
                           senderProcess :: {-# UNPACK #-} !ProcessId,
                           senderThread :: {-# UNPACK #-} !ThreadId,
                           receiverMachine ::  {-# UNPACK #-} !MachineId,
                           receiverProcess :: {-# UNPACK #-} !ProcessId,
                           receiverInport :: {-# UNPACK #-} !PortId
                         }
    | ReceiveMessage     { mesTag :: !MessageTag,
                           receiverProcess :: {-# UNPACK #-} !ProcessId,
                           receiverInport :: {-# UNPACK #-} !PortId,
                           senderMachine ::  {-# UNPACK #-} !MachineId,
                           senderProcess :: {-# UNPACK #-} !ProcessId,
                           senderThread :: {-# UNPACK #-} !ThreadId,
                           messageSize :: {-# UNPACK #-} !MessageSize
                         }
    | SendReceiveLocalMessage { mesTag :: !MessageTag,
                                senderProcess :: {-# UNPACK #-} !ProcessId,
                                senderThread :: {-# UNPACK #-} !ThreadId,
                                receiverProcess :: {-# UNPACK #-} !ProcessId,
                                receiverInport :: {-# UNPACK #-} !PortId
                              }

    -- These events have been added for Mercury's benifit but are generally
    -- useful.
    | InternString       { str :: String, sId :: {-# UNPACK #-}!StringId }

    -- Mercury specific events.
    | MerStartParConjunction {
          dyn_id      :: {-# UNPACK #-}!ParConjDynId,
          static_id   :: {-# UNPACK #-}!ParConjStaticId
      }
    | MerEndParConjunction {
          dyn_id      :: {-# UNPACK #-}!ParConjDynId
      }
    | MerEndParConjunct {
          dyn_id      :: {-# UNPACK #-}!ParConjDynId
      }
    | MerCreateSpark {
          dyn_id      :: {-# UNPACK #-}!ParConjDynId,
          spark_id    :: {-# UNPACK #-}!SparkId
      }
    | MerFutureCreate {
          future_id   :: {-# UNPACK #-}!FutureId,
          name_id     :: {-# UNPACK #-}!StringId
      }
    | MerFutureWaitNosuspend {
          future_id   :: {-# UNPACK #-}!FutureId
      }
    | MerFutureWaitSuspended {
          future_id   :: {-# UNPACK #-}!FutureId
      }
    | MerFutureSignal {
          future_id   :: {-# UNPACK #-}!FutureId
      }
    | MerLookingForGlobalThread
    | MerWorkStealing
    | MerLookingForLocalSpark
    | MerReleaseThread {
          thread_id   :: {-# UNPACK #-}!ThreadId
      }
    | MerCapSleeping
    | MerCallingMain

    -- perf events
    | PerfName           { perfNum :: {-# UNPACK #-}!PerfEventTypeNum
                         , name    :: String
                         }
    | PerfCounter        { perfNum :: {-# UNPACK #-}!PerfEventTypeNum
                         , tid     :: {-# UNPACK #-}!KernelThreadId
                         , period  :: {-# UNPACK #-}!Word64
                         }
    | PerfTracepoint     { perfNum :: {-# UNPACK #-}!PerfEventTypeNum
                         , tid     :: {-# UNPACK #-}!KernelThreadId
                         }
    | HeapProfBegin      { heapProfId :: !Word8
                         , heapProfSamplingPeriod :: !Word64
                         , heapProfBreakdown :: !HeapProfBreakdown
                         , heapProfModuleFilter :: !Text
                         , heapProfClosureDescrFilter :: !Text
                         , heapProfTypeDescrFilter :: !Text
                         , heapProfCostCentreFilter :: !Text
                         , heapProfCostCentreStackFilter :: !Text
                         , heapProfRetainerFilter :: !Text
                         , heapProfBiographyFilter :: !Text
                         }
    | HeapProfCostCentre { heapProfCostCentreId :: !Word32
                         , heapProfLabel :: !Text
                         , heapProfModule :: !Text
                         , heapProfSrcLoc :: !Text
                         , heapProfFlags :: !HeapProfFlags
                         }
    | HeapProfSampleBegin
                         { heapProfSampleEra :: !Word64
                         }
    | HeapProfSampleCostCentre
                         { heapProfId :: !Word8
                         , heapProfResidency :: !Word64
                         , heapProfStackDepth :: !Word8
                         , heapProfStack :: !(VU.Vector Word32)
                         }
    | HeapProfSampleString
                         { heapProfId :: !Word8
                         , heapProfResidency :: !Word64
                         , heapProfLabel :: !Text
                         }

data ThreadStopStatus
    = NoStatus
    | HeapOverflow
    | StackOverflow
    | ThreadYielding
    | ThreadBlocked
    | ThreadFinished
    | ForeignCall
    | BlockedOnMVar
    | BlockedOnMVarRead   -- since GHC-7.8, see [Stop status since GHC-7.7]
    | BlockedOnBlackHole
    | BlockedOnRead
    | BlockedOnWrite
    | BlockedOnDelay
    | BlockedOnSTM
    | BlockedOnDoProc
    | BlockedOnCCall
    | BlockedOnCCall_NoUnblockExc
    | BlockedOnMsgThrowTo
    | ThreadMigrating
    | BlockedOnMsgGlobalise
    | BlockedOnBlackHoleOwnedBy {-# UNPACK #-}!ThreadId
-}