{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

{- |
Module      : GHC.Eventlog.Live.Machine
Description : Machines for processing eventlog data.
Stability   : experimental
Portability : portable
-}
module GHC.Eventlog.Live.Machine (
  -- * Event processing

  -- ** Capability Usage

  -- *** Capability Usage Metrics
  processCapabilityUsageMetrics,

  -- *** Capability Usage Spans
  CapabilityUsageSpan,
  CapabilityUser (..),
  capabilityUser,
  showCapabilityUserCategory,
  processCapabilityUsageSpans,
  processCapabilityUsageSpans',

  -- *** GC Spans
  GCSpan (..),
  processGCSpans,
  processGCSpans',

  -- *** Mutator Spans
  MutatorSpan (..),
  asMutatorSpans,
  asMutatorSpans',
  processMutatorSpans,
  processMutatorSpans',

  -- ** Thread labels
  ThreadLabel (..),
  processThreadLabels,

  -- ** Thread State Spans
  ThreadState (..),
  showThreadStateCategory,
  threadStateStatus,
  threadStateCap,
  ThreadStateSpan (..),
  processThreadStateSpans,
  processThreadStateSpans',

  -- ** Heap events
  processHeapAllocatedData,
  processHeapSizeData,
  processBlocksSizeData,
  processHeapLiveData,
  MemReturnData (..),
  processMemReturnData,
  processHeapProfSampleData,

  -- * Heap profile breakdown
  heapProfBreakdownEitherReader,
  heapProfBreakdownShow,
) where

import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Char (isSpace)
import Data.Either (isLeft)
import Data.Foldable (for_)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as M
import Data.Hashable (Hashable (..))
import Data.List qualified as L
import Data.Machine (Is (..), PlanT, Process, ProcessT, asParts, await, construct, mapping, repeatedly, yield, (~>))
import Data.Machine.Fanout (fanout)
import Data.Maybe (isNothing, listToMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void (Void)
import Data.Word (Word32, Word64)
import GHC.Eventlog.Live.Data.Attribute (Attr, AttrValue, IsAttrValue (..), (~=))
import GHC.Eventlog.Live.Data.Metric (Metric (..))
import GHC.Eventlog.Live.Data.Span (duration)
import GHC.Eventlog.Live.Internal.Logger (logWarning)
import GHC.Eventlog.Live.Machine.Core (liftRouter)
import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), setWithStartTime'value, tryGetTimeUnixNano)
import GHC.Eventlog.Live.Verbosity (Verbosity)
import GHC.RTS.Events (Event (..), EventInfo, HeapProfBreakdown (..), ThreadId, ThreadStopStatus (..), Timestamp)
import GHC.RTS.Events qualified as E
import GHC.Records (HasField (..))
import Numeric (showHex)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.ParserCombinators.ReadP qualified as P
import Text.Printf (printf)
import Text.Read (readMaybe)
import Text.Read.Lex (readHexP)

-------------------------------------------------------------------------------
-- Capability Usage

-------------------------------------------------------------------------------
-- Capability Usage Metrics

{- |
This machine processes t`CapabilityUsageSpan` spans and produces metrics that
contain the duration and category of each such span and each idle period in
between.
-}
processCapabilityUsageMetrics ::
  forall m.
  (MonadIO m) =>
  ProcessT m (WithStartTime CapabilityUsageSpan) (Metric Timestamp)
processCapabilityUsageMetrics :: forall (m :: * -> *).
MonadIO m =>
ProcessT m (WithStartTime CapabilityUsageSpan) (Metric Timestamp)
processCapabilityUsageMetrics =
  (WithStartTime CapabilityUsageSpan -> Maybe Int)
-> (Int
    -> ProcessT
         m (WithStartTime CapabilityUsageSpan) (Metric Timestamp))
-> ProcessT
     m (WithStartTime CapabilityUsageSpan) (Metric Timestamp)
forall (m :: * -> *) k a b.
(MonadIO m, Hashable k) =>
(a -> Maybe k) -> (k -> ProcessT m a b) -> ProcessT m a b
liftRouter WithStartTime CapabilityUsageSpan -> Maybe Int
measure Int
-> ProcessT
     m (WithStartTime CapabilityUsageSpan) (Metric Timestamp)
spawn
 where
  measure :: WithStartTime CapabilityUsageSpan -> Maybe Int
  measure :: WithStartTime CapabilityUsageSpan -> Maybe Int
measure = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> (WithStartTime CapabilityUsageSpan -> Int)
-> WithStartTime CapabilityUsageSpan
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.value.cap)

  spawn :: Int -> ProcessT m (WithStartTime CapabilityUsageSpan) (Metric Timestamp)
  spawn :: Int
-> ProcessT
     m (WithStartTime CapabilityUsageSpan) (Metric Timestamp)
spawn Int
cap = PlanT
  (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void
-> ProcessT
     m (WithStartTime CapabilityUsageSpan) (Metric Timestamp)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
construct (PlanT
   (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void
 -> ProcessT
      m (WithStartTime CapabilityUsageSpan) (Metric Timestamp))
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void
-> ProcessT
     m (WithStartTime CapabilityUsageSpan) (Metric Timestamp)
forall a b. (a -> b) -> a -> b
$ Maybe CapabilityUsageSpan
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void
go Maybe CapabilityUsageSpan
forall a. Maybe a
Nothing
   where
    go ::
      Maybe CapabilityUsageSpan ->
      PlanT (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void
    go :: Maybe CapabilityUsageSpan
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void
go Maybe CapabilityUsageSpan
mi =
      PlanT
  (Is (WithStartTime CapabilityUsageSpan))
  (Metric Timestamp)
  m
  (WithStartTime CapabilityUsageSpan)
Plan
  (Is (WithStartTime CapabilityUsageSpan))
  (Metric Timestamp)
  (WithStartTime CapabilityUsageSpan)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime CapabilityUsageSpan))
  (Metric Timestamp)
  m
  (WithStartTime CapabilityUsageSpan)
-> (WithStartTime CapabilityUsageSpan
    -> PlanT
         (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void)
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void
forall a b.
PlanT
  (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m a
-> (a
    -> PlanT
         (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m b)
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \WithStartTime CapabilityUsageSpan
j -> do
        -- If there is a previous span, and...
        Maybe CapabilityUsageSpan
-> (CapabilityUsageSpan
    -> PlanT
         (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ())
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe CapabilityUsageSpan
mi ((CapabilityUsageSpan
  -> PlanT
       (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ())
 -> PlanT
      (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ())
-> (CapabilityUsageSpan
    -> PlanT
         (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ())
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ()
forall a b. (a -> b) -> a -> b
$ \CapabilityUsageSpan
i ->
          -- ...the end time of the previous span precedes the start time of the current span, then...
          Bool
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ()
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CapabilityUsageSpan
i.endTimeUnixNano Timestamp -> Timestamp -> Bool
forall a. Ord a => a -> a -> Bool
< WithStartTime CapabilityUsageSpan
j.value.startTimeUnixNano) (PlanT
   (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ()
 -> PlanT
      (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ())
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ()
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m ()
forall a b. (a -> b) -> a -> b
$
            -- ...yield an idle duration metric.
            Metric Timestamp
-> Plan
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) ()
forall o (k :: * -> *). o -> Plan k o ()
yield
              Metric
                { value :: Timestamp
value = WithStartTime CapabilityUsageSpan
j.value.startTimeUnixNano Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
- CapabilityUsageSpan
i.endTimeUnixNano
                , maybeTimeUnixNano :: Maybe Timestamp
maybeTimeUnixNano = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just CapabilityUsageSpan
i.endTimeUnixNano
                , maybeStartTimeUnixNano :: Maybe Timestamp
maybeStartTimeUnixNano = WithStartTime CapabilityUsageSpan
j.maybeStartTimeUnixNano
                , attr :: [Attr]
attr = [Text
"cap" Text -> Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Int
cap, Text
"category" Text -> Text -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= (Text
"Idle" :: Text)]
                }
        -- Yield a duration metric for the current span.
        let user :: CapabilityUser
user = CapabilityUsageSpan -> CapabilityUser
capabilityUser WithStartTime CapabilityUsageSpan
j.value
        Metric Timestamp
-> Plan
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) ()
forall o (k :: * -> *). o -> Plan k o ()
yield
          Metric
            { value :: Timestamp
value = CapabilityUsageSpan -> Timestamp
forall s. IsSpan s => s -> Timestamp
duration WithStartTime CapabilityUsageSpan
j.value
            , maybeTimeUnixNano :: Maybe Timestamp
maybeTimeUnixNano = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just WithStartTime CapabilityUsageSpan
j.value.startTimeUnixNano
            , maybeStartTimeUnixNano :: Maybe Timestamp
maybeStartTimeUnixNano = WithStartTime CapabilityUsageSpan
j.maybeStartTimeUnixNano
            , attr :: [Attr]
attr = [Text
"cap" Text -> Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Int
cap, Text
"category" Text -> Text -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= CapabilityUser -> Text
showCapabilityUserCategory CapabilityUser
user, Text
"user" Text -> CapabilityUser -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= CapabilityUser
user]
            }
        Maybe CapabilityUsageSpan
-> PlanT
     (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void
go (CapabilityUsageSpan -> Maybe CapabilityUsageSpan
forall a. a -> Maybe a
Just WithStartTime CapabilityUsageSpan
j.value)

{- |
The type of process using a capability,
which is either a mutator thread or garbage collection.
-}
data CapabilityUser
  = GC
  | Mutator {CapabilityUser -> ThreadId
thread :: !ThreadId}

instance Show CapabilityUser where
  show :: CapabilityUser -> String
  show :: CapabilityUser -> String
show = \case
    CapabilityUser
GC -> String
"GC"
    Mutator{ThreadId
thread :: CapabilityUser -> ThreadId
thread :: ThreadId
thread} -> ThreadId -> String
forall a. Show a => a -> String
show ThreadId
thread

instance IsAttrValue CapabilityUser where
  toAttrValue :: CapabilityUser -> AttrValue
  toAttrValue :: CapabilityUser -> AttrValue
toAttrValue = String -> AttrValue
forall v. IsAttrValue v => v -> AttrValue
toAttrValue (String -> AttrValue)
-> (CapabilityUser -> String) -> CapabilityUser -> AttrValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CapabilityUser -> String
forall a. Show a => a -> String
show
  {-# INLINE toAttrValue #-}

{- |
Get the t`CapabilityUser` associated with a t`CapabilityUsageSpan`.
-}
capabilityUser :: CapabilityUsageSpan -> CapabilityUser
capabilityUser :: CapabilityUsageSpan -> CapabilityUser
capabilityUser = (GCSpan -> CapabilityUser)
-> (MutatorSpan -> CapabilityUser)
-> CapabilityUsageSpan
-> CapabilityUser
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CapabilityUser -> GCSpan -> CapabilityUser
forall a b. a -> b -> a
const CapabilityUser
GC) (ThreadId -> CapabilityUser
Mutator (ThreadId -> CapabilityUser)
-> (MutatorSpan -> ThreadId) -> MutatorSpan -> CapabilityUser
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.thread))

{- |
Show the category of a `CapabilityUser` as either @"GC"@ or @"Mutator"@.
-}
showCapabilityUserCategory :: CapabilityUser -> Text
showCapabilityUserCategory :: CapabilityUser -> Text
showCapabilityUserCategory = \case
  GC{} -> Text
"GC"
  Mutator{} -> Text
"Mutator"

-------------------------------------------------------------------------------
-- Capability Usage Spans

{- |
A t`CapabilityUsageSpan` is either a t`GCSpan` or a t`MutatorSpan`.
-}
type CapabilityUsageSpan = Either GCSpan MutatorSpan

instance HasField "startTimeUnixNano" CapabilityUsageSpan Timestamp where
  getField :: CapabilityUsageSpan -> Timestamp
  getField :: CapabilityUsageSpan -> Timestamp
getField = (GCSpan -> Timestamp)
-> (MutatorSpan -> Timestamp) -> CapabilityUsageSpan -> Timestamp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (.startTimeUnixNano) (.startTimeUnixNano)

instance HasField "endTimeUnixNano" CapabilityUsageSpan Timestamp where
  getField :: CapabilityUsageSpan -> Timestamp
  getField :: CapabilityUsageSpan -> Timestamp
getField = (GCSpan -> Timestamp)
-> (MutatorSpan -> Timestamp) -> CapabilityUsageSpan -> Timestamp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (.endTimeUnixNano) (.endTimeUnixNano)

instance HasField "cap" CapabilityUsageSpan Int where
  getField :: CapabilityUsageSpan -> Int
  getField :: CapabilityUsageSpan -> Int
getField = (GCSpan -> Int)
-> (MutatorSpan -> Int) -> CapabilityUsageSpan -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (.cap) (.cap)

{-# SPECIALIZE duration :: CapabilityUsageSpan -> Timestamp #-}

{- |
This machine runs `processGCSpans` and `processMutatorSpans` in parallel and
combines their output.

This is effectively a fanout of `processGCSpans` and `processMutatorSpans`, the
latter of which runs `processThreadStateSpans` internally. If you are running
`processThreadStateSpans` as well, then using `asMutatorSpans` and constructing
the fanout yourself is more efficient.
-}
processCapabilityUsageSpans ::
  forall m.
  (MonadIO m) =>
  Verbosity ->
  ProcessT m (WithStartTime Event) (WithStartTime CapabilityUsageSpan)
processCapabilityUsageSpans :: forall (m :: * -> *).
MonadIO m =>
Verbosity
-> ProcessT
     m (WithStartTime Event) (WithStartTime CapabilityUsageSpan)
processCapabilityUsageSpans Verbosity
verbosity =
  (WithStartTime Event -> Maybe Timestamp)
-> (WithStartTime Event -> Event)
-> (WithStartTime Event -> GCSpan -> WithStartTime GCSpan)
-> (WithStartTime Event
    -> MutatorSpan -> WithStartTime MutatorSpan)
-> Verbosity
-> ProcessT
     m
     (WithStartTime Event)
     (Either (WithStartTime GCSpan) (WithStartTime MutatorSpan))
forall (m :: * -> *) s t1 t2.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> GCSpan -> t1)
-> (s -> MutatorSpan -> t2)
-> Verbosity
-> ProcessT m s (Either t1 t2)
processCapabilityUsageSpans' WithStartTime Event -> Maybe Timestamp
tryGetTimeUnixNano (.value) WithStartTime Event -> GCSpan -> WithStartTime GCSpan
forall a b. WithStartTime a -> b -> WithStartTime b
setWithStartTime'value WithStartTime Event -> MutatorSpan -> WithStartTime MutatorSpan
forall a b. WithStartTime a -> b -> WithStartTime b
setWithStartTime'value Verbosity
verbosity
    ProcessT
  m
  (WithStartTime Event)
  (Either (WithStartTime GCSpan) (WithStartTime MutatorSpan))
-> ProcessT
     m
     (Either (WithStartTime GCSpan) (WithStartTime MutatorSpan))
     (WithStartTime CapabilityUsageSpan)
-> MachineT
     m (Is (WithStartTime Event)) (WithStartTime CapabilityUsageSpan)
forall (m :: * -> *) (k :: * -> *) b c.
Monad m =>
MachineT m k b -> ProcessT m b c -> MachineT m k c
~> (Either (WithStartTime GCSpan) (WithStartTime MutatorSpan)
 -> WithStartTime CapabilityUsageSpan)
-> Machine
     (Is (Either (WithStartTime GCSpan) (WithStartTime MutatorSpan)))
     (WithStartTime CapabilityUsageSpan)
forall (k :: * -> * -> *) a b.
Category k =>
(a -> b) -> Machine (k a) b
mapping ((WithStartTime GCSpan -> WithStartTime CapabilityUsageSpan)
-> (WithStartTime MutatorSpan -> WithStartTime CapabilityUsageSpan)
-> Either (WithStartTime GCSpan) (WithStartTime MutatorSpan)
-> WithStartTime CapabilityUsageSpan
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((GCSpan -> CapabilityUsageSpan)
-> WithStartTime GCSpan -> WithStartTime CapabilityUsageSpan
forall a b. (a -> b) -> WithStartTime a -> WithStartTime b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GCSpan -> CapabilityUsageSpan
forall a b. a -> Either a b
Left) ((MutatorSpan -> CapabilityUsageSpan)
-> WithStartTime MutatorSpan -> WithStartTime CapabilityUsageSpan
forall a b. (a -> b) -> WithStartTime a -> WithStartTime b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MutatorSpan -> CapabilityUsageSpan
forall a b. b -> Either a b
Right))

{- |
Generalised version of `processCapabilityUsageSpans` that can be adapted to
work on arbitrary types using a getter and a pair of lenses.
-}
processCapabilityUsageSpans' ::
  forall m s t1 t2.
  (MonadIO m) =>
  (s -> Maybe Timestamp) ->
  (s -> Event) ->
  (s -> GCSpan -> t1) ->
  (s -> MutatorSpan -> t2) ->
  Verbosity ->
  ProcessT m s (Either t1 t2)
processCapabilityUsageSpans' :: forall (m :: * -> *) s t1 t2.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> GCSpan -> t1)
-> (s -> MutatorSpan -> t2)
-> Verbosity
-> ProcessT m s (Either t1 t2)
processCapabilityUsageSpans' s -> Maybe Timestamp
timeUnixNano s -> Event
getEvent s -> GCSpan -> t1
setGCSpan s -> MutatorSpan -> t2
setMutatorSpan Verbosity
verbosity =
  -- NOTE:
  -- Combining this fanout with an `Either` is risky, because it
  -- has the potential to lose information if both `processGCSpans`
  -- and `processMutatorSpans` yield a value for the same input.
  -- However, this shouldn't ever happen, since the two processors
  -- process disjoint sets of events.
  [ProcessT m s (Either t1 t2)] -> ProcessT m s (Either t1 t2)
forall (m :: * -> *) a r.
(Monad m, Semigroup r) =>
[ProcessT m a r] -> ProcessT m a r
fanout
    [ (s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> GCSpan -> t1)
-> Verbosity
-> ProcessT m s t1
forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> GCSpan -> t)
-> Verbosity
-> ProcessT m s t
processGCSpans' s -> Maybe Timestamp
timeUnixNano s -> Event
getEvent s -> GCSpan -> t1
setGCSpan Verbosity
verbosity
        ProcessT m s t1
-> ProcessT m t1 (Either t1 t2) -> ProcessT m s (Either t1 t2)
forall (m :: * -> *) (k :: * -> *) b c.
Monad m =>
MachineT m k b -> ProcessT m b c -> MachineT m k c
~> (t1 -> Either t1 t2) -> Machine (Is t1) (Either t1 t2)
forall (k :: * -> * -> *) a b.
Category k =>
(a -> b) -> Machine (k a) b
mapping t1 -> Either t1 t2
forall a b. a -> Either a b
Left
    , (s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> MutatorSpan -> t2)
-> Verbosity
-> ProcessT m s t2
forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> MutatorSpan -> t)
-> Verbosity
-> ProcessT m s t
processMutatorSpans' s -> Maybe Timestamp
timeUnixNano s -> Event
getEvent s -> MutatorSpan -> t2
setMutatorSpan Verbosity
verbosity
        ProcessT m s t2
-> ProcessT m t2 (Either t1 t2) -> ProcessT m s (Either t1 t2)
forall (m :: * -> *) (k :: * -> *) b c.
Monad m =>
MachineT m k b -> ProcessT m b c -> MachineT m k c
~> (t2 -> Either t1 t2) -> Machine (Is t2) (Either t1 t2)
forall (k :: * -> * -> *) a b.
Category k =>
(a -> b) -> Machine (k a) b
mapping t2 -> Either t1 t2
forall a b. b -> Either a b
Right
    ]

-------------------------------------------------------------------------------
-- GC spans

{- |
A t`GCSpan` represents a segment of time during which the specified capability
ran GC.
-}
data GCSpan = GCSpan
  { GCSpan -> Int
cap :: !Int
  , GCSpan -> Timestamp
startTimeUnixNano :: !Timestamp
  , GCSpan -> Timestamp
endTimeUnixNano :: !Timestamp
  }
  deriving (Int -> GCSpan -> String -> String
[GCSpan] -> String -> String
GCSpan -> String
(Int -> GCSpan -> String -> String)
-> (GCSpan -> String)
-> ([GCSpan] -> String -> String)
-> Show GCSpan
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GCSpan -> String -> String
showsPrec :: Int -> GCSpan -> String -> String
$cshow :: GCSpan -> String
show :: GCSpan -> String
$cshowList :: [GCSpan] -> String -> String
showList :: [GCSpan] -> String -> String
Show)

{-# SPECIALIZE duration :: GCSpan -> Timestamp #-}

{- |
This machine processes `E.StartGC` and `E.EndGC` events to produce t`GCSpan`
values that represent the segments of time a capability spent in GC.

This processor uses the following finite-state automaton:

@
      ┌─(EndGC)───┐
      │           ↓
    ┌→[   Idle    ]─┐
    │               │
(EndGC)         (StartGC)
    │               │
    └─[    GC     ]←┘
      ↑           │
      └─(StartGC)─┘
@

The transition from @GC@ to @Idle@ yields a GC span.
-}
processGCSpans ::
  forall m.
  (MonadIO m) =>
  Verbosity ->
  ProcessT m (WithStartTime Event) (WithStartTime GCSpan)
processGCSpans :: forall (m :: * -> *).
MonadIO m =>
Verbosity
-> ProcessT m (WithStartTime Event) (WithStartTime GCSpan)
processGCSpans =
  (WithStartTime Event -> Maybe Timestamp)
-> (WithStartTime Event -> Event)
-> (WithStartTime Event -> GCSpan -> WithStartTime GCSpan)
-> Verbosity
-> ProcessT m (WithStartTime Event) (WithStartTime GCSpan)
forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> GCSpan -> t)
-> Verbosity
-> ProcessT m s t
processGCSpans' WithStartTime Event -> Maybe Timestamp
tryGetTimeUnixNano (.value) WithStartTime Event -> GCSpan -> WithStartTime GCSpan
forall a b. WithStartTime a -> b -> WithStartTime b
setWithStartTime'value

{- |
Generalised version of `processGCSpans` that can be adapted to work on
arbitrary types using a getter and a lens.
-}
processGCSpans' ::
  forall m s t.
  (MonadIO m) =>
  (s -> Maybe Timestamp) ->
  (s -> Event) ->
  (s -> GCSpan -> t) ->
  Verbosity ->
  ProcessT m s t
processGCSpans' :: forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> GCSpan -> t)
-> Verbosity
-> ProcessT m s t
processGCSpans' s -> Maybe Timestamp
timeUnixNano s -> Event
getEvent s -> GCSpan -> t
setGCSpan Verbosity
verbosity =
  (s -> Maybe Int) -> (Int -> ProcessT m s t) -> ProcessT m s t
forall (m :: * -> *) k a b.
(MonadIO m, Hashable k) =>
(a -> Maybe k) -> (k -> ProcessT m a b) -> ProcessT m a b
liftRouter s -> Maybe Int
measure Int -> ProcessT m s t
spawn
 where
  getEventTime :: s -> Timestamp
getEventTime = (.evTime) (Event -> Timestamp) -> (s -> Event) -> s -> Timestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Event
getEvent
  getEventInfo :: s -> EventInfo
getEventInfo = (.evSpec) (Event -> EventInfo) -> (s -> Event) -> s -> EventInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Event
getEvent
  getEventCap :: s -> Maybe Int
getEventCap = (.evCap) (Event -> Maybe Int) -> (s -> Event) -> s -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Event
getEvent

  measure :: s -> Maybe Int
  measure :: s -> Maybe Int
measure s
i
    | EventInfo -> Bool
accept (s -> EventInfo
getEventInfo s
i) = s -> Maybe Int
getEventCap s
i
    | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
   where
    accept :: EventInfo -> Bool
accept E.StartGC{} = Bool
True
    accept E.EndGC{} = Bool
True
    accept EventInfo
_ = Bool
False

  -- TODO: Rewrite using `MealyT`
  spawn :: Int -> ProcessT m s t
  spawn :: Int -> ProcessT m s t
spawn Int
cap = PlanT (Is s) t m Void -> ProcessT m s t
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
construct (PlanT (Is s) t m Void -> ProcessT m s t)
-> PlanT (Is s) t m Void -> ProcessT m s t
forall a b. (a -> b) -> a -> b
$ Maybe s -> PlanT (Is s) t m Void
go Maybe s
forall a. Maybe a
Nothing
   where
    -- The "mi" variable tracks the previous event for this capability, which
    -- is either `Nothing` or `Just` a `StartGC` or a `EndGC` event.
    go :: Maybe s -> PlanT (Is s) t m Void
    go :: Maybe s -> PlanT (Is s) t m Void
go Maybe s
mi =
      -- We start by awaiting the next event "j"...
      PlanT (Is s) t m s
Plan (Is s) t s
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT (Is s) t m s
-> (s -> PlanT (Is s) t m Void) -> PlanT (Is s) t m Void
forall a b.
PlanT (Is s) t m a
-> (a -> PlanT (Is s) t m b) -> PlanT (Is s) t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s
j -> case s -> EventInfo
getEventInfo s
j of
        -- If the next event is a `RunThread` event, and...
        E.StartGC{} -> case Maybe s
mi of
          Just s
i
            -- If the previous event was a `StartGC` event, then...
            | E.StartGC{} <- s -> EventInfo
getEventInfo s
i ->
                -- ...continue with the oldest event.
                Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just (s -> Maybe s) -> s -> Maybe s
forall a b. (a -> b) -> a -> b
$ (s -> Timestamp) -> s -> s -> s
forall b a. Ord b => (a -> b) -> a -> a -> a
minBy s -> Timestamp
getEventTime s
i s
j)
            -- If the previous event was a `EndGC` event, then...
            | E.EndGC{} <- s -> EventInfo
getEventInfo s
i ->
                -- ...continue with the current event.
                Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just s
j)
            -- If the previous event was any other event, then...
            | Bool
otherwise -> do
                -- ...emit an error, and...
                Verbosity -> Text -> Text -> PlanT (Is s) t m ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logWarning Verbosity
verbosity Text
"processGCSpans" (Text -> PlanT (Is s) t m ())
-> (String -> Text) -> String -> PlanT (Is s) t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> PlanT (Is s) t m ()) -> String -> PlanT (Is s) t m ()
forall a b. (a -> b) -> a -> b
$
                  String -> Int -> String -> String -> String
forall r. PrintfType r => String -> r
printf
                    String
"Capability %d: Unsupported trace %s --> %s"
                    Int
cap
                    (EventInfo -> String
showEventInfo (s -> EventInfo
getEventInfo s
i))
                    (EventInfo -> String
showEventInfo (s -> EventInfo
getEventInfo s
j))
                -- ...continue with the previous event.
                Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just s
i)
          -- If there was no previous event, then...
          Maybe s
Nothing ->
            -- ...continue with the current event.
            Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just s
j)
        -- If the next event is a `StopThread` event...
        E.EndGC{} -> case Maybe s
mi of
          Just s
i
            -- If the previous event was a `StartGC` event, then...
            | E.StartGC{} <- s -> EventInfo
getEventInfo s
i
            , Just Timestamp
startTimeUnixNano <- s -> Maybe Timestamp
timeUnixNano s
i
            , Just Timestamp
endTimeUnixNano <- s -> Maybe Timestamp
timeUnixNano s
j -> do
                -- ...yield a GC span, and...
                t -> PlanT (Is s) t m ()
t -> Plan (Is s) t ()
forall o (k :: * -> *). o -> Plan k o ()
yield (t -> PlanT (Is s) t m ())
-> (GCSpan -> t) -> GCSpan -> PlanT (Is s) t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> GCSpan -> t
setGCSpan s
j (GCSpan -> PlanT (Is s) t m ()) -> GCSpan -> PlanT (Is s) t m ()
forall a b. (a -> b) -> a -> b
$ GCSpan{Int
Timestamp
cap :: Int
startTimeUnixNano :: Timestamp
endTimeUnixNano :: Timestamp
cap :: Int
startTimeUnixNano :: Timestamp
endTimeUnixNano :: Timestamp
..}
                -- ...continue with the current event.
                Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just s
j)
            -- If the previous event was a `EndGC` event, then...
            | E.EndGC{} <- s -> EventInfo
getEventInfo s
i ->
                -- ...continue with the oldest event.
                Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just (s -> Maybe s) -> s -> Maybe s
forall a b. (a -> b) -> a -> b
$ (s -> Timestamp) -> s -> s -> s
forall b a. Ord b => (a -> b) -> a -> a -> a
minBy s -> Timestamp
getEventTime s
i s
j)
          -- If there was no previous event or it was any other event, then...
          Maybe s
_otherwise -> do
            -- ...emit an error, and...
            Verbosity -> Text -> Text -> PlanT (Is s) t m ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logWarning Verbosity
verbosity Text
"processGCSpans" (Text -> PlanT (Is s) t m ())
-> (String -> Text) -> String -> PlanT (Is s) t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> PlanT (Is s) t m ()) -> String -> PlanT (Is s) t m ()
forall a b. (a -> b) -> a -> b
$
              String -> Int -> String -> String -> String
forall r. PrintfType r => String -> r
printf
                String
"Capability %d: Unsupported trace %s --> %s"
                Int
cap
                (String -> (s -> String) -> Maybe s -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"?" (EventInfo -> String
showEventInfo (EventInfo -> String) -> (s -> EventInfo) -> s -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> EventInfo
getEventInfo) Maybe s
mi)
                (EventInfo -> String
showEventInfo (s -> EventInfo
getEventInfo s
j))
            -- ...continue with the previous event.
            Maybe s -> PlanT (Is s) t m Void
go Maybe s
mi
        -- If the next event is any other event, ignore it.
        EventInfo
_otherwise -> Maybe s -> PlanT (Is s) t m Void
go Maybe s
mi

-------------------------------------------------------------------------------
-- Mutator spans

{- |
A t`MutatorSpan` represents a segment of time during which the specified
capability ran the specified mutator thread.
-}
data MutatorSpan = MutatorSpan
  { MutatorSpan -> Int
cap :: !Int
  , MutatorSpan -> ThreadId
thread :: !ThreadId
  , MutatorSpan -> Timestamp
startTimeUnixNano :: !Timestamp
  , MutatorSpan -> Timestamp
endTimeUnixNano :: !Timestamp
  }
  deriving (Int -> MutatorSpan -> String -> String
[MutatorSpan] -> String -> String
MutatorSpan -> String
(Int -> MutatorSpan -> String -> String)
-> (MutatorSpan -> String)
-> ([MutatorSpan] -> String -> String)
-> Show MutatorSpan
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MutatorSpan -> String -> String
showsPrec :: Int -> MutatorSpan -> String -> String
$cshow :: MutatorSpan -> String
show :: MutatorSpan -> String
$cshowList :: [MutatorSpan] -> String -> String
showList :: [MutatorSpan] -> String -> String
Show)

{-# SPECIALIZE duration :: MutatorSpan -> Timestamp #-}

{- |
This machine processes `E.RunThread` and `E.StopThread` events to produce
t`MutatorSpan` values that represent the segments of time a capability spent
executating a mutator.

This processor uses the following finite-state automaton:

@
      ┌─(StopThread[X])─┐
      │                 ↓
    ┌→[      Idle       ]─┐
    │                     │
(StopThread[X])       (RunThread[X])
    │                     │
    └─[   Mutator[X]    ]←┘
      ↑                 │
      └─(RunThread[X])──┘
@

The transition from @Mutator[X]@ to @Idle@ yields a t`MutatorSpan`.
While in the @Mutator[X]@ state, any @RunThread[Y]@ or @StopThread[Y]@ events result in an error.
Furthermore, when a @StopThread[X]@ event with the @ThreadFinished@ status is processed,
the thread @X@ is added to a set of finished threads,
and any further @RunThread[X]@ events for that thread are ignored.
This is done because the GHC RTS frequently emits a @RunThread[X]@ event
immediately after a @StopThread[X]@ event with the @ThreadFinished@ status.

This runs `processThreadStateSpans` internally. If you are also running
`processThreadStateSpans`, then post-composing it with `asMutatorSpans`
is more efficient.
-}
processMutatorSpans ::
  forall m.
  (MonadIO m) =>
  Verbosity ->
  ProcessT m (WithStartTime Event) (WithStartTime MutatorSpan)
processMutatorSpans :: forall (m :: * -> *).
MonadIO m =>
Verbosity
-> ProcessT m (WithStartTime Event) (WithStartTime MutatorSpan)
processMutatorSpans =
  (WithStartTime Event -> Maybe Timestamp)
-> (WithStartTime Event -> Event)
-> (WithStartTime Event
    -> MutatorSpan -> WithStartTime MutatorSpan)
-> Verbosity
-> ProcessT m (WithStartTime Event) (WithStartTime MutatorSpan)
forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> MutatorSpan -> t)
-> Verbosity
-> ProcessT m s t
processMutatorSpans' WithStartTime Event -> Maybe Timestamp
tryGetTimeUnixNano (.value) WithStartTime Event -> MutatorSpan -> WithStartTime MutatorSpan
forall a b. WithStartTime a -> b -> WithStartTime b
setWithStartTime'value

{- |
Generalised version of `processMutatorSpans` that can be adapted to work on
arbitrary types using a getter and a lens.
-}
processMutatorSpans' ::
  forall m s t.
  (MonadIO m) =>
  (s -> Maybe Timestamp) ->
  (s -> Event) ->
  (s -> MutatorSpan -> t) ->
  Verbosity ->
  ProcessT m s t
processMutatorSpans' :: forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> MutatorSpan -> t)
-> Verbosity
-> ProcessT m s t
processMutatorSpans' s -> Maybe Timestamp
timeUnixNano s -> Event
getEvent s -> MutatorSpan -> t
setMutatorSpan Verbosity
verbosity =
  (s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> ThreadStateSpan -> Maybe t)
-> Verbosity
-> ProcessT m s (Maybe t)
forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> ThreadStateSpan -> t)
-> Verbosity
-> ProcessT m s t
processThreadStateSpans' s -> Maybe Timestamp
timeUnixNano s -> Event
getEvent s -> ThreadStateSpan -> Maybe t
setThreadStateSpan Verbosity
verbosity ProcessT m s (Maybe t)
-> ProcessT m (Maybe t) t -> MachineT m (Is s) t
forall (m :: * -> *) (k :: * -> *) b c.
Monad m =>
MachineT m k b -> ProcessT m b c -> MachineT m k c
~> ProcessT m (Maybe t) t
Process (Maybe t) t
forall (f :: * -> *) a. Foldable f => Process (f a) a
asParts
 where
  setThreadStateSpan :: s -> ThreadStateSpan -> Maybe t
  setThreadStateSpan :: s -> ThreadStateSpan -> Maybe t
setThreadStateSpan s
s ThreadStateSpan
threadStateSpan =
    s -> MutatorSpan -> t
setMutatorSpan s
s (MutatorSpan -> t) -> Maybe MutatorSpan -> Maybe t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreadStateSpan -> Maybe MutatorSpan
threadStateSpanToMutatorSpan ThreadStateSpan
threadStateSpan

{- |
This machine converts any `Running` t`ThreadStateSpan` to a t`MutatorSpan`.
-}
asMutatorSpans ::
  forall m.
  (MonadIO m) =>
  ProcessT m ThreadStateSpan MutatorSpan
asMutatorSpans :: forall (m :: * -> *).
MonadIO m =>
ProcessT m ThreadStateSpan MutatorSpan
asMutatorSpans = (ThreadStateSpan -> ThreadStateSpan)
-> (ThreadStateSpan -> MutatorSpan -> MutatorSpan)
-> ProcessT m ThreadStateSpan MutatorSpan
forall (m :: * -> *) s t.
MonadIO m =>
(s -> ThreadStateSpan) -> (s -> MutatorSpan -> t) -> ProcessT m s t
asMutatorSpans' ThreadStateSpan -> ThreadStateSpan
forall a. a -> a
id ((MutatorSpan -> MutatorSpan)
-> ThreadStateSpan -> MutatorSpan -> MutatorSpan
forall a b. a -> b -> a
const MutatorSpan -> MutatorSpan
forall a. a -> a
id)

{- |
Generalised version of `asMutatorSpans` that can be adapted to work on
arbitrary types using a getter and a lens.
-}
asMutatorSpans' ::
  forall m s t.
  (MonadIO m) =>
  (s -> ThreadStateSpan) ->
  (s -> MutatorSpan -> t) ->
  ProcessT m s t
asMutatorSpans' :: forall (m :: * -> *) s t.
MonadIO m =>
(s -> ThreadStateSpan) -> (s -> MutatorSpan -> t) -> ProcessT m s t
asMutatorSpans' s -> ThreadStateSpan
getThreadStateSpan s -> MutatorSpan -> t
setMutatorSpan = PlanT (Is s) t m () -> MachineT m (Is s) t
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly PlanT (Is s) t m ()
go
 where
  go :: PlanT (Is s) t m ()
go =
    PlanT (Is s) t m s
Plan (Is s) t s
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT (Is s) t m s
-> (s -> PlanT (Is s) t m ()) -> PlanT (Is s) t m ()
forall a b.
PlanT (Is s) t m a
-> (a -> PlanT (Is s) t m b) -> PlanT (Is s) t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s
s -> do
      let threadStateSpan :: ThreadStateSpan
threadStateSpan = s -> ThreadStateSpan
getThreadStateSpan s
s
      let maybeMutatorSpan :: Maybe MutatorSpan
maybeMutatorSpan = ThreadStateSpan -> Maybe MutatorSpan
threadStateSpanToMutatorSpan ThreadStateSpan
threadStateSpan
      Maybe MutatorSpan
-> (MutatorSpan -> PlanT (Is s) t m ()) -> PlanT (Is s) t m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe MutatorSpan
maybeMutatorSpan ((MutatorSpan -> PlanT (Is s) t m ()) -> PlanT (Is s) t m ())
-> (MutatorSpan -> PlanT (Is s) t m ()) -> PlanT (Is s) t m ()
forall a b. (a -> b) -> a -> b
$ t -> PlanT (Is s) t m ()
t -> Plan (Is s) t ()
forall o (k :: * -> *). o -> Plan k o ()
yield (t -> PlanT (Is s) t m ())
-> (MutatorSpan -> t) -> MutatorSpan -> PlanT (Is s) t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> MutatorSpan -> t
setMutatorSpan s
s

{- |
Convert the `Running` t`ThreadStateSpan` to `Just` a t`MutatorSpan`.
-}
threadStateSpanToMutatorSpan :: ThreadStateSpan -> Maybe MutatorSpan
threadStateSpanToMutatorSpan :: ThreadStateSpan -> Maybe MutatorSpan
threadStateSpanToMutatorSpan ThreadStateSpan{ThreadId
Timestamp
ThreadState
thread :: ThreadId
threadState :: ThreadState
startTimeUnixNano :: Timestamp
endTimeUnixNano :: Timestamp
endTimeUnixNano :: ThreadStateSpan -> Timestamp
startTimeUnixNano :: ThreadStateSpan -> Timestamp
threadState :: ThreadStateSpan -> ThreadState
thread :: ThreadStateSpan -> ThreadId
..} =
  case ThreadState
threadState of
    Running{Int
cap :: Int
cap :: ThreadState -> Int
..} -> MutatorSpan -> Maybe MutatorSpan
forall a. a -> Maybe a
Just MutatorSpan{Int
ThreadId
Timestamp
cap :: Int
thread :: ThreadId
startTimeUnixNano :: Timestamp
endTimeUnixNano :: Timestamp
thread :: ThreadId
startTimeUnixNano :: Timestamp
endTimeUnixNano :: Timestamp
cap :: Int
..}
    ThreadState
_otherwise -> Maybe MutatorSpan
forall a. Maybe a
Nothing

{- |
Internal helper.
Check whether a t`ThreadStopStatus` is equal to `ThreadFinished`.
This is needed because t`ThreadStopStatus` does not define an `Eq` instance.
-}
isThreadFinished :: ThreadStopStatus -> Bool
isThreadFinished :: ThreadStopStatus -> Bool
isThreadFinished = \case
  ThreadStopStatus
ThreadFinished -> Bool
True
  ThreadStopStatus
_otherwise -> Bool
False

{- |
Internal helper.
Show `EventInfo` in a condensed format suitable for logging.
-}
showEventInfo :: EventInfo -> String
showEventInfo :: EventInfo -> String
showEventInfo = \case
  E.RunThread{ThreadId
thread :: ThreadId
thread :: EventInfo -> ThreadId
thread} -> String -> ThreadId -> String
forall r. PrintfType r => String -> r
printf String
"RunThread{%d}" ThreadId
thread
  E.StopThread{ThreadId
thread :: EventInfo -> ThreadId
thread :: ThreadId
thread, ThreadStopStatus
status :: ThreadStopStatus
status :: EventInfo -> ThreadStopStatus
status} -> String -> ThreadId -> String -> String
forall r. PrintfType r => String -> r
printf String
"StopThread{%d,%s}" ThreadId
thread (ThreadStopStatus -> String
E.showThreadStopStatus ThreadStopStatus
status)
  E.MigrateThread{ThreadId
thread :: EventInfo -> ThreadId
thread :: ThreadId
thread} -> String -> ThreadId -> String
forall r. PrintfType r => String -> r
printf String
"MigrateThread{%d}" ThreadId
thread
  E.StartGC{} -> String
"StartGC"
  E.EndGC{} -> String
"EndGC"
  EventInfo
evSpec -> (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) (String -> String) -> (EventInfo -> String) -> EventInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventInfo -> String
forall a. Show a => a -> String
show (EventInfo -> String) -> EventInfo -> String
forall a b. (a -> b) -> a -> b
$ EventInfo
evSpec

-------------------------------------------------------------------------------
-- Thread Labels

{- |
The t`ThreadLabel` type represents the association of a label with a thread
starting at a given time.
-}
data ThreadLabel
  = ThreadLabel
  { ThreadLabel -> ThreadId
thread :: !ThreadId
  , ThreadLabel -> Text
threadlabel :: !Text
  , ThreadLabel -> Timestamp
startTimeUnixNano :: !Timestamp
  }

{- |
This machine processes `E.ThreadLabel` events and yields t`ThreadLabel` values.
-}
processThreadLabels :: Process (WithStartTime Event) ThreadLabel
processThreadLabels :: Process (WithStartTime Event) ThreadLabel
processThreadLabels = PlanT (Is (WithStartTime Event)) ThreadLabel m ()
-> MachineT m (Is (WithStartTime Event)) ThreadLabel
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly PlanT (Is (WithStartTime Event)) ThreadLabel m ()
forall {m :: * -> *}.
PlanT (Is (WithStartTime Event)) ThreadLabel m ()
go
 where
  go :: PlanT (Is (WithStartTime Event)) ThreadLabel m ()
go =
    PlanT
  (Is (WithStartTime Event)) ThreadLabel m (WithStartTime Event)
Plan (Is (WithStartTime Event)) ThreadLabel (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event)) ThreadLabel m (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) ThreadLabel m ())
-> PlanT (Is (WithStartTime Event)) ThreadLabel m ()
forall a b.
PlanT (Is (WithStartTime Event)) ThreadLabel m a
-> (a -> PlanT (Is (WithStartTime Event)) ThreadLabel m b)
-> PlanT (Is (WithStartTime Event)) ThreadLabel m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \WithStartTime Event
i -> case WithStartTime Event
i.value.evSpec of
      E.ThreadLabel{ThreadId
Text
thread :: EventInfo -> ThreadId
thread :: ThreadId
threadlabel :: Text
threadlabel :: EventInfo -> Text
..}
        | Just Timestamp
startTimeUnixNano <- WithStartTime Event -> Maybe Timestamp
tryGetTimeUnixNano WithStartTime Event
i ->
            ThreadLabel
-> forall {m :: * -> *}.
   PlanT (Is (WithStartTime Event)) ThreadLabel m ()
forall o (k :: * -> *). o -> Plan k o ()
yield ThreadLabel{ThreadId
Timestamp
Text
thread :: ThreadId
threadlabel :: Text
startTimeUnixNano :: Timestamp
thread :: ThreadId
threadlabel :: Text
startTimeUnixNano :: Timestamp
..}
      EventInfo
_otherwise -> () -> PlanT (Is (WithStartTime Event)) ThreadLabel m ()
forall a. a -> PlanT (Is (WithStartTime Event)) ThreadLabel m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-------------------------------------------------------------------------------
-- Thread State Spans

{- |
The execution states of a mutator thread.
-}
data ThreadState
  = Running {ThreadState -> Int
cap :: !Int}
  | Blocked {ThreadState -> ThreadStopStatus
status :: !ThreadStopStatus}
  | Finished
  deriving (Int -> ThreadState -> String -> String
[ThreadState] -> String -> String
ThreadState -> String
(Int -> ThreadState -> String -> String)
-> (ThreadState -> String)
-> ([ThreadState] -> String -> String)
-> Show ThreadState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ThreadState -> String -> String
showsPrec :: Int -> ThreadState -> String -> String
$cshow :: ThreadState -> String
show :: ThreadState -> String
$cshowList :: [ThreadState] -> String -> String
showList :: [ThreadState] -> String -> String
Show)

{- |
Pretty-print a thread state as "Running", "Blocked", or "Finished".
-}
showThreadStateCategory :: ThreadState -> Text
showThreadStateCategory :: ThreadState -> Text
showThreadStateCategory = \case
  Running{} -> Text
"Running"
  Blocked{} -> Text
"Blocked"
  Finished{} -> Text
"Finished"

{- |
Get the t`ThreadState` status, if the t`ThreadState` is `Blocked`.
-}
threadStateStatus :: ThreadState -> Maybe ThreadStopStatus
threadStateStatus :: ThreadState -> Maybe ThreadStopStatus
threadStateStatus = \case
  Running{} -> Maybe ThreadStopStatus
forall a. Maybe a
Nothing
  Blocked{ThreadStopStatus
status :: ThreadState -> ThreadStopStatus
status :: ThreadStopStatus
status} -> ThreadStopStatus -> Maybe ThreadStopStatus
forall a. a -> Maybe a
Just ThreadStopStatus
status
  Finished{} -> Maybe ThreadStopStatus
forall a. Maybe a
Nothing

{- |
Get the t`ThreadState` capability, if the `ThreadState` is `Running`.
-}
threadStateCap :: ThreadState -> Maybe Int
threadStateCap :: ThreadState -> Maybe Int
threadStateCap = \case
  Running{Int
cap :: ThreadState -> Int
cap :: Int
cap} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
cap
  Blocked{} -> Maybe Int
forall a. Maybe a
Nothing
  Finished{} -> Maybe Int
forall a. Maybe a
Nothing

{- |
A span representing the state of a mutator thread.
-}
data ThreadStateSpan
  = ThreadStateSpan
  { ThreadStateSpan -> ThreadId
thread :: !ThreadId
  , ThreadStateSpan -> ThreadState
threadState :: !ThreadState
  , ThreadStateSpan -> Timestamp
startTimeUnixNano :: !Timestamp
  , ThreadStateSpan -> Timestamp
endTimeUnixNano :: !Timestamp
  }
  deriving (Int -> ThreadStateSpan -> String -> String
[ThreadStateSpan] -> String -> String
ThreadStateSpan -> String
(Int -> ThreadStateSpan -> String -> String)
-> (ThreadStateSpan -> String)
-> ([ThreadStateSpan] -> String -> String)
-> Show ThreadStateSpan
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ThreadStateSpan -> String -> String
showsPrec :: Int -> ThreadStateSpan -> String -> String
$cshow :: ThreadStateSpan -> String
show :: ThreadStateSpan -> String
$cshowList :: [ThreadStateSpan] -> String -> String
showList :: [ThreadStateSpan] -> String -> String
Show)

{-# SPECIALIZE duration :: ThreadStateSpan -> Timestamp #-}

{- |
This machine processes `E.RunThread` and `E.StopThread` events to produce
t`ThreadStateSpan` values that represent segments of time where a thread is
running, blocked, or finished.

This processor uses the following finite-state automaton:

@
      ┌─(StopThread)─┐
      │              ↓
    ┌→[   Blocked    ]─┐
    │                  │
(StopThread)       (RunThread)
    │                  │
    └─[   Running    ]←┘
      ↑              │
      └─(RunThread)──┘
@

The transitions from @Blocked@ to @Blocked@, @Blocked@ to @Running@, and
@Running@ to @Running@ yield a t`ThreadStateSpan`. There are additional
transitions (not pictured) from either state to the final `Finished` state
with a `E.StopThread` event with the `ThreadFinished` status.
-}
processThreadStateSpans ::
  (MonadIO m) =>
  Verbosity ->
  ProcessT m (WithStartTime Event) ThreadStateSpan
processThreadStateSpans :: forall (m :: * -> *).
MonadIO m =>
Verbosity -> ProcessT m (WithStartTime Event) ThreadStateSpan
processThreadStateSpans =
  (WithStartTime Event -> Maybe Timestamp)
-> (WithStartTime Event -> Event)
-> (WithStartTime Event -> ThreadStateSpan -> ThreadStateSpan)
-> Verbosity
-> ProcessT m (WithStartTime Event) ThreadStateSpan
forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> ThreadStateSpan -> t)
-> Verbosity
-> ProcessT m s t
processThreadStateSpans' WithStartTime Event -> Maybe Timestamp
tryGetTimeUnixNano (.value) ((ThreadStateSpan -> ThreadStateSpan)
-> WithStartTime Event -> ThreadStateSpan -> ThreadStateSpan
forall a b. a -> b -> a
const ThreadStateSpan -> ThreadStateSpan
forall a. a -> a
id)

{- |
Generalised version of `processThreadStateSpans` that can be adapted to work
on arbitrary types using a getter and a lens.
-}
processThreadStateSpans' ::
  forall m s t.
  (MonadIO m) =>
  (s -> Maybe Timestamp) ->
  (s -> Event) ->
  (s -> ThreadStateSpan -> t) ->
  Verbosity ->
  ProcessT m s t
processThreadStateSpans' :: forall (m :: * -> *) s t.
MonadIO m =>
(s -> Maybe Timestamp)
-> (s -> Event)
-> (s -> ThreadStateSpan -> t)
-> Verbosity
-> ProcessT m s t
processThreadStateSpans' s -> Maybe Timestamp
timeUnixNano s -> Event
getEvent s -> ThreadStateSpan -> t
setThreadStateSpan Verbosity
verbosity =
  (s -> Maybe ThreadId)
-> (ThreadId -> ProcessT m s t) -> ProcessT m s t
forall (m :: * -> *) k a b.
(MonadIO m, Hashable k) =>
(a -> Maybe k) -> (k -> ProcessT m a b) -> ProcessT m a b
liftRouter s -> Maybe ThreadId
measure ThreadId -> ProcessT m s t
spawn
 where
  getEventTime :: s -> Timestamp
getEventTime = (.evTime) (Event -> Timestamp) -> (s -> Event) -> s -> Timestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Event
getEvent
  getEventInfo :: s -> EventInfo
getEventInfo = (.evSpec) (Event -> EventInfo) -> (s -> Event) -> s -> EventInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Event
getEvent
  getEventCap :: s -> Maybe Int
getEventCap = (.evCap) (Event -> Maybe Int) -> (s -> Event) -> s -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Event
getEvent

  measure :: s -> Maybe ThreadId
  measure :: s -> Maybe ThreadId
measure s
i = case s -> EventInfo
getEventInfo s
i of
    E.RunThread{ThreadId
thread :: EventInfo -> ThreadId
thread :: ThreadId
thread} -> ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
thread
    E.StopThread{ThreadId
thread :: EventInfo -> ThreadId
thread :: ThreadId
thread} -> ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
thread
    EventInfo
_otherwise -> Maybe ThreadId
forall a. Maybe a
Nothing

  spawn :: ThreadId -> ProcessT m s t
  spawn :: ThreadId -> ProcessT m s t
spawn ThreadId
thread = PlanT (Is s) t m Void -> ProcessT m s t
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
construct (PlanT (Is s) t m Void -> ProcessT m s t)
-> PlanT (Is s) t m Void -> ProcessT m s t
forall a b. (a -> b) -> a -> b
$ Maybe s -> PlanT (Is s) t m Void
go Maybe s
forall a. Maybe a
Nothing
   where
    go :: Maybe s -> PlanT (Is s) t m Void
    go :: Maybe s -> PlanT (Is s) t m Void
go Maybe s
mi =
      PlanT (Is s) t m s
Plan (Is s) t s
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT (Is s) t m s
-> (s -> PlanT (Is s) t m Void) -> PlanT (Is s) t m Void
forall a b.
PlanT (Is s) t m a
-> (a -> PlanT (Is s) t m b) -> PlanT (Is s) t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        s
j
          -- If the previous event was a `E.StopThread` event, and...
          | Just E.StopThread{ThreadStopStatus
status :: EventInfo -> ThreadStopStatus
status :: ThreadStopStatus
status} <- s -> EventInfo
getEventInfo (s -> EventInfo) -> Maybe s -> Maybe EventInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe s
mi
          , --- ...it has the `ThreadFinished` status, then...
            ThreadStopStatus -> Bool
isThreadFinished ThreadStopStatus
status ->
              -- ...ignore the current event.
              Maybe s -> PlanT (Is s) t m Void
go Maybe s
mi
          --
          -- If the current event is a `E.RunThread` event, and...
          | E.RunThread{} <- s -> EventInfo
getEventInfo s
j
          , -- ...the previous event was a `E.StopThread` event, then...
            Just E.StopThread{ThreadStopStatus
status :: EventInfo -> ThreadStopStatus
status :: ThreadStopStatus
status} <- s -> EventInfo
getEventInfo (s -> EventInfo) -> Maybe s -> Maybe EventInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe s
mi
          , -- ...gather the end time of the previous event, and...
            Just Timestamp
startTimeUnixNano <- s -> Maybe Timestamp
timeUnixNano (s -> Maybe Timestamp) -> Maybe s -> Maybe Timestamp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe s
mi
          , -- ...gather the start time of the current event, and...
            Just Timestamp
endTimeUnixNano <- s -> Maybe Timestamp
timeUnixNano s
j -> do
              -- ...yield a thread state span, and...
              t -> PlanT (Is s) t m ()
t -> Plan (Is s) t ()
forall o (k :: * -> *). o -> Plan k o ()
yield (t -> PlanT (Is s) t m ())
-> (ThreadStateSpan -> t) -> ThreadStateSpan -> PlanT (Is s) t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> ThreadStateSpan -> t
setThreadStateSpan s
j (ThreadStateSpan -> PlanT (Is s) t m ())
-> ThreadStateSpan -> PlanT (Is s) t m ()
forall a b. (a -> b) -> a -> b
$
                ThreadStateSpan{threadState :: ThreadState
threadState = ThreadStopStatus -> ThreadState
Blocked ThreadStopStatus
status, ThreadId
Timestamp
endTimeUnixNano :: Timestamp
startTimeUnixNano :: Timestamp
thread :: ThreadId
thread :: ThreadId
startTimeUnixNano :: Timestamp
endTimeUnixNano :: Timestamp
..}
              Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just s
j)
          --
          -- If the current event is a `E.RunThread` event, and...
          | E.RunThread{} <- s -> EventInfo
getEventInfo s
j
          , -- ...the previous event was a `E.RunThread` event, then...
            Just E.RunThread{} <- s -> EventInfo
getEventInfo (s -> EventInfo) -> Maybe s -> Maybe EventInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe s
mi -> do
              -- ...keep the oldest event.
              Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just (s -> Maybe s) -> s -> Maybe s
forall a b. (a -> b) -> a -> b
$ s -> (s -> s) -> Maybe s -> s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe s
j ((s -> Timestamp) -> s -> s -> s
forall b a. Ord b => (a -> b) -> a -> a -> a
minBy s -> Timestamp
getEventTime s
j) Maybe s
mi)
          --
          -- If the current event is a `E.RunThread` event, and...
          | E.RunThread{} <- s -> EventInfo
getEventInfo s
j
          , -- ...there is no previous event, then...
            Maybe s -> Bool
forall a. Maybe a -> Bool
isNothing Maybe s
mi ->
              -- ...keep the current event.
              --
              -- The reason for the additional `isNothing` test is because,
              -- otherwise, this case might silently swallow any `E.StopThread`
              -- events for which `timeUnixNano` gives `Nothing`.
              -- By excluding these, they are forwarded to the catch-all case.
              Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just s
j)
          --
          -- If the current event is a `E.StopThread` event, and...
          | E.StopThread{} <- s -> EventInfo
getEventInfo s
j
          , -- ...the previous event was a `E.StopThread` event, then...
            Just E.StopThread{ThreadStopStatus
status :: EventInfo -> ThreadStopStatus
status :: ThreadStopStatus
status} <- s -> EventInfo
getEventInfo (s -> EventInfo) -> Maybe s -> Maybe EventInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe s
mi
          , -- ...gather the end time of the previous event, and...
            Just Timestamp
startTimeUnixNano <- s -> Maybe Timestamp
timeUnixNano (s -> Maybe Timestamp) -> Maybe s -> Maybe Timestamp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe s
mi
          , -- ...gather the start time of the current event, and...
            Just Timestamp
endTimeUnixNano <- s -> Maybe Timestamp
timeUnixNano s
j -> do
              -- ...yield a thread state span, and...
              t -> PlanT (Is s) t m ()
t -> Plan (Is s) t ()
forall o (k :: * -> *). o -> Plan k o ()
yield (t -> PlanT (Is s) t m ())
-> (ThreadStateSpan -> t) -> ThreadStateSpan -> PlanT (Is s) t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> ThreadStateSpan -> t
setThreadStateSpan s
j (ThreadStateSpan -> PlanT (Is s) t m ())
-> ThreadStateSpan -> PlanT (Is s) t m ()
forall a b. (a -> b) -> a -> b
$
                ThreadStateSpan{threadState :: ThreadState
threadState = ThreadStopStatus -> ThreadState
Blocked ThreadStopStatus
status, ThreadId
Timestamp
endTimeUnixNano :: Timestamp
startTimeUnixNano :: Timestamp
thread :: ThreadId
thread :: ThreadId
startTimeUnixNano :: Timestamp
endTimeUnixNano :: Timestamp
..}
              -- ...keep the current event.
              --
              -- This causes us to adopt every `E.StopThread` event, until
              -- we hit a `E.StopThread` event with the `ThreadFinished`, at
              -- which point the first clause will cause us to stick with it.
              Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just s
j)
          --
          -- If the current event is a `E.StopThread` event, and...
          | E.StopThread{} <- s -> EventInfo
getEventInfo s
j
          , -- ...the previous event was a `E.RunThread` event, then...
            Just E.RunThread{} <- s -> EventInfo
getEventInfo (s -> EventInfo) -> Maybe s -> Maybe EventInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe s
mi
          , -- ...gather the capability of the `E.RunThread` event, and...
            Just Int
cap <- s -> Maybe Int
getEventCap (s -> Maybe Int) -> Maybe s -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe s
mi
          , -- ...gather the end time of the previous event, and...
            Just Timestamp
startTimeUnixNano <- s -> Maybe Timestamp
timeUnixNano (s -> Maybe Timestamp) -> Maybe s -> Maybe Timestamp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe s
mi
          , -- ...gather the start time of the current event, and...
            Just Timestamp
endTimeUnixNano <- s -> Maybe Timestamp
timeUnixNano s
j -> do
              -- ...yield a thread state span, and...
              t -> PlanT (Is s) t m ()
t -> Plan (Is s) t ()
forall o (k :: * -> *). o -> Plan k o ()
yield (t -> PlanT (Is s) t m ())
-> (ThreadStateSpan -> t) -> ThreadStateSpan -> PlanT (Is s) t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> ThreadStateSpan -> t
setThreadStateSpan s
j (ThreadStateSpan -> PlanT (Is s) t m ())
-> ThreadStateSpan -> PlanT (Is s) t m ()
forall a b. (a -> b) -> a -> b
$
                ThreadStateSpan{threadState :: ThreadState
threadState = Int -> ThreadState
Running Int
cap, ThreadId
Timestamp
endTimeUnixNano :: Timestamp
startTimeUnixNano :: Timestamp
thread :: ThreadId
thread :: ThreadId
startTimeUnixNano :: Timestamp
endTimeUnixNano :: Timestamp
..}
              -- ...keep the current event.
              Maybe s -> PlanT (Is s) t m Void
go (s -> Maybe s
forall a. a -> Maybe a
Just s
j)
          --
          -- If the current event is any other event, then...
          | Bool
otherwise -> do
              -- ...emit an error, and...
              Verbosity -> Text -> Text -> PlanT (Is s) t m ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logWarning Verbosity
verbosity Text
"processThreadStateSpans" (Text -> PlanT (Is s) t m ())
-> (String -> Text) -> String -> PlanT (Is s) t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> PlanT (Is s) t m ()) -> String -> PlanT (Is s) t m ()
forall a b. (a -> b) -> a -> b
$
                String -> ThreadId -> String -> String
forall r. PrintfType r => String -> r
printf
                  String
"Thread %d: Unexpected event %s"
                  ThreadId
thread
                  (EventInfo -> String
showEventInfo (s -> EventInfo
getEventInfo s
j))
              --
              -- This case may trigger for any event that isn't `E.RunThread`
              -- or `E.StopThread` and for any `E.StopThread` event that comes
              -- before the first `E.RunThread` event. It may also trigger for
              -- any event for which `timeUnixNano` returns `Nothing`.
              --
              -- ...ignore it.
              Maybe s -> PlanT (Is s) t m Void
go Maybe s
mi

-------------------------------------------------------------------------------
-- Heap events
-------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- HeapAllocated

{- |
This machine processes `E.HeapAllocated` events into metrics.
-}
processHeapAllocatedData :: Process (WithStartTime Event) (Metric Word64)
processHeapAllocatedData :: Process (WithStartTime Event) (Metric Timestamp)
processHeapAllocatedData =
  PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
 -> MachineT m (Is (WithStartTime Event)) (Metric Timestamp))
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall a b. (a -> b) -> a -> b
$
    PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Timestamp) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.HeapAllocated{ThreadId
Timestamp
heapCapset :: ThreadId
allocBytes :: Timestamp
heapCapset :: EventInfo -> ThreadId
allocBytes :: EventInfo -> Timestamp
..} <- WithStartTime Event
i.value.evSpec ->
            Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Timestamp
 -> Plan (Is (WithStartTime Event)) (Metric Timestamp) ())
-> Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Timestamp -> [Attr] -> Metric Timestamp
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Timestamp
allocBytes ([Attr] -> Metric Timestamp) -> [Attr] -> Metric Timestamp
forall a b. (a -> b) -> a -> b
$
                [ Text
"evCap" Text -> Maybe Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= WithStartTime Event
i.value.evCap
                , Text
"heapCapset" Text -> ThreadId -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= ThreadId
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a.
a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-------------------------------------------------------------------------------
-- HeapSize

{- |
This machine processes `E.HeapSize` events into metrics.
-}
processHeapSizeData :: Process (WithStartTime Event) (Metric Word64)
processHeapSizeData :: Process (WithStartTime Event) (Metric Timestamp)
processHeapSizeData = PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
go
 where
  go :: PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
go =
    PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Timestamp) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.HeapSize{ThreadId
Timestamp
heapCapset :: EventInfo -> ThreadId
heapCapset :: ThreadId
sizeBytes :: Timestamp
sizeBytes :: EventInfo -> Timestamp
..} <- WithStartTime Event
i.value.evSpec -> do
            Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Timestamp
 -> Plan (Is (WithStartTime Event)) (Metric Timestamp) ())
-> Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Timestamp -> [Attr] -> Metric Timestamp
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Timestamp
sizeBytes ([Attr] -> Metric Timestamp) -> [Attr] -> Metric Timestamp
forall a b. (a -> b) -> a -> b
$
                [ Text
"evCap" Text -> Maybe Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= WithStartTime Event
i.value.evCap
                , Text
"heapCapset" Text -> ThreadId -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= ThreadId
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a.
a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-------------------------------------------------------------------------------
-- BlocksSize

{- |
This machine processes `E.BlocksSize` events into metrics.
-}
processBlocksSizeData :: Process (WithStartTime Event) (Metric Word64)
processBlocksSizeData :: Process (WithStartTime Event) (Metric Timestamp)
processBlocksSizeData =
  PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
 -> MachineT m (Is (WithStartTime Event)) (Metric Timestamp))
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall a b. (a -> b) -> a -> b
$
    PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Timestamp) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.BlocksSize{ThreadId
Timestamp
heapCapset :: EventInfo -> ThreadId
heapCapset :: ThreadId
blocksSize :: Timestamp
blocksSize :: EventInfo -> Timestamp
..} <- WithStartTime Event
i.value.evSpec -> do
            Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Timestamp
 -> Plan (Is (WithStartTime Event)) (Metric Timestamp) ())
-> Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Timestamp -> [Attr] -> Metric Timestamp
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Timestamp
blocksSize ([Attr] -> Metric Timestamp) -> [Attr] -> Metric Timestamp
forall a b. (a -> b) -> a -> b
$
                [ Text
"evCap" Text -> Maybe Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= WithStartTime Event
i.value.evCap
                , Text
"heapCapset" Text -> ThreadId -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= ThreadId
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a.
a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-------------------------------------------------------------------------------
-- HeapLive

{- |
This machine processes `E.HeapLive` events into metrics.
-}
processHeapLiveData :: Process (WithStartTime Event) (Metric Word64)
processHeapLiveData :: Process (WithStartTime Event) (Metric Timestamp)
processHeapLiveData =
  PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
 -> MachineT m (Is (WithStartTime Event)) (Metric Timestamp))
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall a b. (a -> b) -> a -> b
$
    PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Timestamp) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.HeapLive{ThreadId
Timestamp
heapCapset :: EventInfo -> ThreadId
heapCapset :: ThreadId
liveBytes :: Timestamp
liveBytes :: EventInfo -> Timestamp
..} <- WithStartTime Event
i.value.evSpec -> do
            Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Timestamp
 -> Plan (Is (WithStartTime Event)) (Metric Timestamp) ())
-> Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Timestamp -> [Attr] -> Metric Timestamp
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Timestamp
liveBytes ([Attr] -> Metric Timestamp) -> [Attr] -> Metric Timestamp
forall a b. (a -> b) -> a -> b
$
                [ Text
"evCap" Text -> Maybe Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= WithStartTime Event
i.value.evCap
                , Text
"heapCapset" Text -> ThreadId -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= ThreadId
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a.
a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-------------------------------------------------------------------------------
-- MemReturn

{- |
The type of data associated with a `E.MemReturn` event.
-}
data MemReturnData = MemReturnData
  { MemReturnData -> ThreadId
current :: !Word32
  -- ^ The number of megablocks currently allocated.
  , MemReturnData -> ThreadId
needed :: !Word32
  -- ^ The number of megablocks currently needed.
  , MemReturnData -> ThreadId
returned :: !Word32
  -- ^ The number of megablocks currently being returned to the OS.
  }

{- |
This machine processes `E.MemReturn` events into metrics.
-}
processMemReturnData :: Process (WithStartTime Event) (Metric MemReturnData)
processMemReturnData :: Process (WithStartTime Event) (Metric MemReturnData)
processMemReturnData =
  PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric MemReturnData)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m ()
 -> MachineT m (Is (WithStartTime Event)) (Metric MemReturnData))
-> PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric MemReturnData)
forall a b. (a -> b) -> a -> b
$
    PlanT
  (Is (WithStartTime Event))
  (Metric MemReturnData)
  m
  (WithStartTime Event)
Plan
  (Is (WithStartTime Event))
  (Metric MemReturnData)
  (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event))
  (Metric MemReturnData)
  m
  (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m ())
-> PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m a
-> (a
    -> PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m b)
-> PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.MemReturn{ThreadId
heapCapset :: EventInfo -> ThreadId
heapCapset :: ThreadId
current :: ThreadId
needed :: ThreadId
returned :: ThreadId
returned :: EventInfo -> ThreadId
needed :: EventInfo -> ThreadId
current :: EventInfo -> ThreadId
..} <- WithStartTime Event
i.value.evSpec -> do
            Metric MemReturnData
-> Plan (Is (WithStartTime Event)) (Metric MemReturnData) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric MemReturnData
 -> Plan (Is (WithStartTime Event)) (Metric MemReturnData) ())
-> Metric MemReturnData
-> Plan (Is (WithStartTime Event)) (Metric MemReturnData) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event
-> MemReturnData -> [Attr] -> Metric MemReturnData
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i MemReturnData{ThreadId
current :: ThreadId
needed :: ThreadId
returned :: ThreadId
current :: ThreadId
needed :: ThreadId
returned :: ThreadId
..} ([Attr] -> Metric MemReturnData) -> [Attr] -> Metric MemReturnData
forall a b. (a -> b) -> a -> b
$
                [ Text
"evCap" Text -> Maybe Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= WithStartTime Event
i.value.evCap
                , Text
"heapCapset" Text -> ThreadId -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= ThreadId
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m ()
forall a.
a -> PlanT (Is (WithStartTime Event)) (Metric MemReturnData) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-------------------------------------------------------------------------------
-- HeapProfSample

{- |
Internal helper.
The type of info table pointers.
-}
newtype InfoTablePtr = InfoTablePtr Word64
  deriving newtype (InfoTablePtr -> InfoTablePtr -> Bool
(InfoTablePtr -> InfoTablePtr -> Bool)
-> (InfoTablePtr -> InfoTablePtr -> Bool) -> Eq InfoTablePtr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InfoTablePtr -> InfoTablePtr -> Bool
== :: InfoTablePtr -> InfoTablePtr -> Bool
$c/= :: InfoTablePtr -> InfoTablePtr -> Bool
/= :: InfoTablePtr -> InfoTablePtr -> Bool
Eq, Eq InfoTablePtr
Eq InfoTablePtr =>
(Int -> InfoTablePtr -> Int)
-> (InfoTablePtr -> Int) -> Hashable InfoTablePtr
Int -> InfoTablePtr -> Int
InfoTablePtr -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> InfoTablePtr -> Int
hashWithSalt :: Int -> InfoTablePtr -> Int
$chash :: InfoTablePtr -> Int
hash :: InfoTablePtr -> Int
Hashable, Eq InfoTablePtr
Eq InfoTablePtr =>
(InfoTablePtr -> InfoTablePtr -> Ordering)
-> (InfoTablePtr -> InfoTablePtr -> Bool)
-> (InfoTablePtr -> InfoTablePtr -> Bool)
-> (InfoTablePtr -> InfoTablePtr -> Bool)
-> (InfoTablePtr -> InfoTablePtr -> Bool)
-> (InfoTablePtr -> InfoTablePtr -> InfoTablePtr)
-> (InfoTablePtr -> InfoTablePtr -> InfoTablePtr)
-> Ord InfoTablePtr
InfoTablePtr -> InfoTablePtr -> Bool
InfoTablePtr -> InfoTablePtr -> Ordering
InfoTablePtr -> InfoTablePtr -> InfoTablePtr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: InfoTablePtr -> InfoTablePtr -> Ordering
compare :: InfoTablePtr -> InfoTablePtr -> Ordering
$c< :: InfoTablePtr -> InfoTablePtr -> Bool
< :: InfoTablePtr -> InfoTablePtr -> Bool
$c<= :: InfoTablePtr -> InfoTablePtr -> Bool
<= :: InfoTablePtr -> InfoTablePtr -> Bool
$c> :: InfoTablePtr -> InfoTablePtr -> Bool
> :: InfoTablePtr -> InfoTablePtr -> Bool
$c>= :: InfoTablePtr -> InfoTablePtr -> Bool
>= :: InfoTablePtr -> InfoTablePtr -> Bool
$cmax :: InfoTablePtr -> InfoTablePtr -> InfoTablePtr
max :: InfoTablePtr -> InfoTablePtr -> InfoTablePtr
$cmin :: InfoTablePtr -> InfoTablePtr -> InfoTablePtr
min :: InfoTablePtr -> InfoTablePtr -> InfoTablePtr
Ord)

instance Show InfoTablePtr where
  showsPrec :: Int -> InfoTablePtr -> ShowS
  showsPrec :: Int -> InfoTablePtr -> String -> String
showsPrec Int
_ (InfoTablePtr Timestamp
ptr) =
    String -> String -> String
showString String
"0x" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> String -> String
forall a. Integral a => a -> String -> String
showHex Timestamp
ptr

instance Read InfoTablePtr where
  readsPrec :: Int -> ReadS InfoTablePtr
  readsPrec :: Int -> ReadS InfoTablePtr
readsPrec Int
_ = ReadP InfoTablePtr -> ReadS InfoTablePtr
forall a. ReadP a -> ReadS a
readP_to_S (Timestamp -> InfoTablePtr
InfoTablePtr (Timestamp -> InfoTablePtr)
-> ReadP Timestamp -> ReadP InfoTablePtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ReadP String
P.string String
"0x" ReadP String -> ReadP Timestamp -> ReadP Timestamp
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP Timestamp
forall a. (Eq a, Num a) => ReadP a
readHexP))

{- |
Internal helper.
The type of an info table entry, as produced by the `E.InfoTableProv` event.
-}
data InfoTable = InfoTable
  { InfoTable -> InfoTablePtr
infoTablePtr :: InfoTablePtr
  , InfoTable -> Text
infoTableName :: Text
  , InfoTable -> Int
infoTableClosureDesc :: Int
  , InfoTable -> Text
infoTableTyDesc :: Text
  , InfoTable -> Text
infoTableLabel :: Text
  , InfoTable -> Text
infoTableModule :: Text
  , InfoTable -> Text
infoTableSrcLoc :: Text
  }
  deriving (Int -> InfoTable -> String -> String
[InfoTable] -> String -> String
InfoTable -> String
(Int -> InfoTable -> String -> String)
-> (InfoTable -> String)
-> ([InfoTable] -> String -> String)
-> Show InfoTable
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> InfoTable -> String -> String
showsPrec :: Int -> InfoTable -> String -> String
$cshow :: InfoTable -> String
show :: InfoTable -> String
$cshowList :: [InfoTable] -> String -> String
showList :: [InfoTable] -> String -> String
Show)

{- |
Internal helper.
The type of the state kept by `processHeapProfSampleData`.
-}
data HeapProfSampleState = HeapProfSampleState
  { HeapProfSampleState -> Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown :: Either Bool HeapProfBreakdown
  , HeapProfSampleState -> HashMap InfoTablePtr InfoTable
infoTableMap :: HashMap InfoTablePtr InfoTable
  , HeapProfSampleState -> [Timestamp]
heapProfSampleEraStack :: [Word64]
  }
  deriving (Int -> HeapProfSampleState -> String -> String
[HeapProfSampleState] -> String -> String
HeapProfSampleState -> String
(Int -> HeapProfSampleState -> String -> String)
-> (HeapProfSampleState -> String)
-> ([HeapProfSampleState] -> String -> String)
-> Show HeapProfSampleState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> HeapProfSampleState -> String -> String
showsPrec :: Int -> HeapProfSampleState -> String -> String
$cshow :: HeapProfSampleState -> String
show :: HeapProfSampleState -> String
$cshowList :: [HeapProfSampleState] -> String -> String
showList :: [HeapProfSampleState] -> String -> String
Show)

{- |
Internal helper.
Decides whether or not `processHeapProfSampleData` should track info tables.
We track info tables until (1) we learn that the RTS is not run with @-hi@,
or (2) we see the first heap profiling sample and don't yet know for sure
that the RTS is run with @-hi@.
-}
shouldTrackInfoTableMap :: Either Bool HeapProfBreakdown -> Bool
shouldTrackInfoTableMap :: Either Bool HeapProfBreakdown -> Bool
shouldTrackInfoTableMap (Left Bool
_shouldWarn) = Bool
True
shouldTrackInfoTableMap (Right HeapProfBreakdown
HeapProfBreakdownInfoTable) = Bool
True
shouldTrackInfoTableMap Either Bool HeapProfBreakdown
_ = Bool
False

{- |
Internal helper.
Checks whether a `HeapProfBreakdown` is `HeapProfBreakdownInfoTable`.
This is needed because the ghc-events package does not define an `Eq`
instance for the `HeapProfBreakdown` type.
-}
isHeapProfBreakdownInfoTable :: HeapProfBreakdown -> Bool
isHeapProfBreakdownInfoTable :: HeapProfBreakdown -> Bool
isHeapProfBreakdownInfoTable HeapProfBreakdown
HeapProfBreakdownInfoTable = Bool
True
isHeapProfBreakdownInfoTable HeapProfBreakdown
_ = Bool
False

{- |
This machine processes `E.HeapProfSampleString` events into metrics.
Furthermore, it processes the `E.HeapProfBegin` and `E.ProgramArgs` events
to determine the heap profile breakdown, processes `E.InfoTableProv` events to
build an info table map, if necessary, and processes `E.HeapProfSampleBegin`
and `E.HeapProfSampleEnd` events to maintain an era stack.
-}
processHeapProfSampleData ::
  (MonadIO m) =>
  Verbosity ->
  Maybe HeapProfBreakdown ->
  ProcessT m (WithStartTime Event) (Metric Word64)
processHeapProfSampleData :: forall (m :: * -> *).
MonadIO m =>
Verbosity
-> Maybe HeapProfBreakdown
-> ProcessT m (WithStartTime Event) (Metric Timestamp)
processHeapProfSampleData Verbosity
verbosityThreshold Maybe HeapProfBreakdown
maybeHeapProfBreakdown =
  PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
construct (PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
 -> MachineT m (Is (WithStartTime Event)) (Metric Timestamp))
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
-> MachineT m (Is (WithStartTime Event)) (Metric Timestamp)
forall a b. (a -> b) -> a -> b
$
    HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go
      HeapProfSampleState
        { eitherShouldWarnOrHeapProfBreakdown :: Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown = Either Bool HeapProfBreakdown
-> (HeapProfBreakdown -> Either Bool HeapProfBreakdown)
-> Maybe HeapProfBreakdown
-> Either Bool HeapProfBreakdown
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Either Bool HeapProfBreakdown
forall a b. a -> Either a b
Left Bool
True) HeapProfBreakdown -> Either Bool HeapProfBreakdown
forall a b. b -> Either a b
Right Maybe HeapProfBreakdown
maybeHeapProfBreakdown
        , infoTableMap :: HashMap InfoTablePtr InfoTable
infoTableMap = HashMap InfoTablePtr InfoTable
forall a. Monoid a => a
mempty
        , heapProfSampleEraStack :: [Timestamp]
heapProfSampleEraStack = [Timestamp]
forall a. Monoid a => a
mempty
        }
 where
  -- go :: HeapProfSampleState -> PlanT (Is (WithStartTime Event)) (Metric Word64) m Void
  go :: HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go st :: HeapProfSampleState
st@HeapProfSampleState{[Timestamp]
Either Bool HeapProfBreakdown
HashMap InfoTablePtr InfoTable
eitherShouldWarnOrHeapProfBreakdown :: HeapProfSampleState -> Either Bool HeapProfBreakdown
infoTableMap :: HeapProfSampleState -> HashMap InfoTablePtr InfoTable
heapProfSampleEraStack :: HeapProfSampleState -> [Timestamp]
eitherShouldWarnOrHeapProfBreakdown :: Either Bool HeapProfBreakdown
infoTableMap :: HashMap InfoTablePtr InfoTable
heapProfSampleEraStack :: [Timestamp]
..} = do
    PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Timestamp) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event))
  (Metric Timestamp)
  m
  (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any)
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Timestamp) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \WithStartTime Event
i -> case WithStartTime Event
i.value.evSpec of
      -- Announces the heap profile breakdown, amongst other things.
      -- This event is only emitted for code compiled with GHC >=9.14.
      E.HeapProfBegin{Word8
Timestamp
HeapProfBreakdown
Text
heapProfId :: Word8
heapProfSamplingPeriod :: Timestamp
heapProfBreakdown :: HeapProfBreakdown
heapProfModuleFilter :: Text
heapProfClosureDescrFilter :: Text
heapProfTypeDescrFilter :: Text
heapProfCostCentreFilter :: Text
heapProfCostCentreStackFilter :: Text
heapProfRetainerFilter :: Text
heapProfBiographyFilter :: Text
heapProfBiographyFilter :: EventInfo -> Text
heapProfRetainerFilter :: EventInfo -> Text
heapProfCostCentreStackFilter :: EventInfo -> Text
heapProfCostCentreFilter :: EventInfo -> Text
heapProfTypeDescrFilter :: EventInfo -> Text
heapProfClosureDescrFilter :: EventInfo -> Text
heapProfModuleFilter :: EventInfo -> Text
heapProfBreakdown :: EventInfo -> HeapProfBreakdown
heapProfSamplingPeriod :: EventInfo -> Timestamp
heapProfId :: EventInfo -> Word8
..}
        | Either Bool HeapProfBreakdown -> Bool
forall a b. Either a b -> Bool
isLeft Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown ->
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st{eitherShouldWarnOrHeapProfBreakdown = Right heapProfBreakdown}
      -- Announces the arguments with which the program was called.
      -- This *may* include RTS options, which can be used to determine the
      -- heap profile breakdown for code compiled with GHC <9.14.
      E.ProgramArgs{[Text]
ThreadId
capset :: ThreadId
args :: [Text]
capset :: EventInfo -> ThreadId
args :: EventInfo -> [Text]
..}
        | Either Bool HeapProfBreakdown -> Bool
forall a b. Either a b -> Bool
isLeft Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown
        , Just HeapProfBreakdown
heapProfBreakdown <- [Text] -> Maybe HeapProfBreakdown
findHeapProfBreakdown [Text]
args ->
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st{eitherShouldWarnOrHeapProfBreakdown = Right heapProfBreakdown}
      -- Announces an info table entry.
      E.InfoTableProv{Int
Timestamp
Text
itInfo :: Timestamp
itTableName :: Text
itClosureDesc :: Int
itTyDesc :: Text
itLabel :: Text
itModule :: Text
itSrcLoc :: Text
itSrcLoc :: EventInfo -> Text
itModule :: EventInfo -> Text
itLabel :: EventInfo -> Text
itTyDesc :: EventInfo -> Text
itClosureDesc :: EventInfo -> Int
itTableName :: EventInfo -> Text
itInfo :: EventInfo -> Timestamp
..}
        | Either Bool HeapProfBreakdown -> Bool
shouldTrackInfoTableMap Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown -> do
            let infoTablePtr :: InfoTablePtr
infoTablePtr = Timestamp -> InfoTablePtr
InfoTablePtr Timestamp
itInfo
                infoTable :: InfoTable
infoTable =
                  InfoTable
                    { infoTablePtr :: InfoTablePtr
infoTablePtr = InfoTablePtr
infoTablePtr
                    , infoTableName :: Text
infoTableName = Text
itTableName
                    , infoTableClosureDesc :: Int
infoTableClosureDesc = Int
itClosureDesc
                    , infoTableTyDesc :: Text
infoTableTyDesc = Text
itTyDesc
                    , infoTableLabel :: Text
infoTableLabel = Text
itLabel
                    , infoTableModule :: Text
infoTableModule = Text
itModule
                    , infoTableSrcLoc :: Text
infoTableSrcLoc = Text
itSrcLoc
                    }
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st{infoTableMap = M.insert infoTablePtr infoTable infoTableMap}
      -- Announces the beginning of a heap profile sample.
      E.HeapProfSampleBegin{Timestamp
heapProfSampleEra :: Timestamp
heapProfSampleEra :: EventInfo -> Timestamp
..} ->
        HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st{heapProfSampleEraStack = heapProfSampleEra : heapProfSampleEraStack}
      -- Announces the end of a heap profile sample.
      E.HeapProfSampleEnd{Timestamp
heapProfSampleEra :: EventInfo -> Timestamp
heapProfSampleEra :: Timestamp
..} ->
        case [Timestamp] -> Maybe (Timestamp, [Timestamp])
forall a. [a] -> Maybe (a, [a])
L.uncons [Timestamp]
heapProfSampleEraStack of
          Maybe (Timestamp, [Timestamp])
Nothing -> do
            Verbosity
-> Text
-> Text
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logWarning Verbosity
verbosityThreshold Text
"processHeapProfSampleData" (Text -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> (String -> Text)
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String
 -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b. (a -> b) -> a -> b
$
              String -> Timestamp -> String
forall r. PrintfType r => String -> r
printf
                String
"Eventlog closed era %d, but there is no current era."
                Timestamp
heapProfSampleEra
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st
          Just (Timestamp
currentEra, [Timestamp]
heapProfSampleEraStack') -> do
            Bool
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Timestamp
currentEra Timestamp -> Timestamp -> Bool
forall a. Eq a => a -> a -> Bool
== Timestamp
heapProfSampleEra) (PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
 -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b. (a -> b) -> a -> b
$
              Verbosity
-> Text
-> Text
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logWarning Verbosity
verbosityThreshold Text
"processHeapProfSampleData" (Text -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> (String -> Text)
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String
 -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b. (a -> b) -> a -> b
$
                String -> Timestamp -> Timestamp -> String
forall r. PrintfType r => String -> r
printf
                  String
"Eventlog closed era %d, but the current era is era %d."
                  Timestamp
heapProfSampleEra
                  Timestamp
currentEra
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st{heapProfSampleEraStack = heapProfSampleEraStack'}
      -- Announces a heap profile sample.
      E.HeapProfSampleString{Word8
Timestamp
Text
heapProfId :: EventInfo -> Word8
heapProfId :: Word8
heapProfResidency :: Timestamp
heapProfLabel :: Text
heapProfLabel :: EventInfo -> Text
heapProfResidency :: EventInfo -> Timestamp
..}
        -- If there is no heap profile breakdown, issue a warning, then disable warnings.
        | Left Bool
True <- Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown -> do
            Verbosity
-> Text
-> Text
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logWarning Verbosity
verbosityThreshold Text
"processHeapProfSampleData" (Text -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> Text -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b. (a -> b) -> a -> b
$
              Text
"Cannot infer heap profile breakdown.\n\
              \         If your binary was compiled with a GHC version prior to 9.14,\n\
              \         you must also pass the heap profile type to this executable.\n\
              \         See: https://gitlab.haskell.org/ghc/ghc/-/commit/76d392a"
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st{eitherShouldWarnOrHeapProfBreakdown = Left False, infoTableMap = mempty}
        -- If the heap profile breakdown is biographical, issue a warning, then disable warnings.
        | Right HeapProfBreakdown
HeapProfBreakdownBiography <- Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown -> do
            Verbosity
-> Text
-> Text
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logWarning Verbosity
verbosityThreshold Text
"processHeapProfSampleData" (Text -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> (String -> Text)
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String
 -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ())
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m ()
forall a b. (a -> b) -> a -> b
$
              String -> String -> String
forall r. PrintfType r => String -> r
printf
                String
"Unsupported heap profile breakdown %s"
                (HeapProfBreakdown -> String
heapProfBreakdownShow HeapProfBreakdown
HeapProfBreakdownBiography)
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st{eitherShouldWarnOrHeapProfBreakdown = Left False, infoTableMap = mempty}
        -- If there is a heap profile breakdown, handle it appropriately.
        | Right HeapProfBreakdown
heapProfBreakdown <- Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown -> do
            -- If the heap profile breakdown is by info table, add the info table.
            let maybeInfoTable :: Maybe InfoTable
maybeInfoTable
                  | HeapProfBreakdown -> Bool
isHeapProfBreakdownInfoTable HeapProfBreakdown
heapProfBreakdown = do
                      !InfoTablePtr
infoTablePtr <- String -> Maybe InfoTablePtr
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
heapProfLabel)
                      InfoTablePtr -> HashMap InfoTablePtr InfoTable -> Maybe InfoTable
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup InfoTablePtr
infoTablePtr HashMap InfoTablePtr InfoTable
infoTableMap
                  | Bool
otherwise = Maybe InfoTable
forall a. Maybe a
Nothing
            Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Timestamp
 -> Plan (Is (WithStartTime Event)) (Metric Timestamp) ())
-> Metric Timestamp
-> Plan (Is (WithStartTime Event)) (Metric Timestamp) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Timestamp -> [Attr] -> Metric Timestamp
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Timestamp
heapProfResidency ([Attr] -> Metric Timestamp) -> [Attr] -> Metric Timestamp
forall a b. (a -> b) -> a -> b
$
                [ Text
"evCap" Text -> Maybe Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= WithStartTime Event
i.value.evCap
                , Text
"heapProfBreakdown" Text -> String -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= HeapProfBreakdown -> String
heapProfBreakdownShow HeapProfBreakdown
heapProfBreakdown
                , Text
"heapProfId" Text -> Word8 -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Word8
heapProfId
                , Text
"heapProfLabel" Text -> Text -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Text
heapProfLabel
                , Text
"heapProfSampleEra" Text -> Maybe Timestamp -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= ((Timestamp, [Timestamp]) -> Timestamp
forall a b. (a, b) -> a
fst ((Timestamp, [Timestamp]) -> Timestamp)
-> Maybe (Timestamp, [Timestamp]) -> Maybe Timestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Timestamp] -> Maybe (Timestamp, [Timestamp])
forall a. [a] -> Maybe (a, [a])
L.uncons [Timestamp]
heapProfSampleEraStack)
                , Text
"infoTableName" Text -> Maybe Text -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= (InfoTable -> Text) -> Maybe InfoTable -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.infoTableName) Maybe InfoTable
maybeInfoTable
                , Text
"infoTableClosureDesc" Text -> Maybe Int -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= (InfoTable -> Int) -> Maybe InfoTable -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.infoTableClosureDesc) Maybe InfoTable
maybeInfoTable
                , Text
"infoTableTyDesc" Text -> Maybe Text -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= (InfoTable -> Text) -> Maybe InfoTable -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.infoTableTyDesc) Maybe InfoTable
maybeInfoTable
                , Text
"infoTableLabel" Text -> Maybe Text -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= (InfoTable -> Text) -> Maybe InfoTable -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.infoTableLabel) Maybe InfoTable
maybeInfoTable
                , Text
"infoTableModule" Text -> Maybe Text -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= (InfoTable -> Text) -> Maybe InfoTable -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.infoTableModule) Maybe InfoTable
maybeInfoTable
                , Text
"infoTableSrcLoc" Text -> Maybe Text -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= (InfoTable -> Text) -> Maybe InfoTable -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.infoTableSrcLoc) Maybe InfoTable
maybeInfoTable
                ]
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go (HeapProfSampleState
 -> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any)
-> HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
forall a b. (a -> b) -> a -> b
$ if HeapProfBreakdown -> Bool
isHeapProfBreakdownInfoTable HeapProfBreakdown
heapProfBreakdown then HeapProfSampleState
st else HeapProfSampleState
st{infoTableMap = mempty}
      EventInfo
_otherwise -> HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Timestamp) m Any
go HeapProfSampleState
st

{- |
Parses the `HeapProfBreakdown` command-line arguments:

> heapProfBreakdownEitherReader "T" == Left HeapProfBreakdownClosureType
> heapProfBreakdownEitherReader "c" == Left HeapProfBreakdownCostCentre
> heapProfBreakdownEitherReader "m" == Left HeapProfBreakdownModule
> heapProfBreakdownEitherReader "d" == Left HeapProfBreakdownClosureDescr
> heapProfBreakdownEitherReader "y" == Left HeapProfBreakdownTypeDescr
> heapProfBreakdownEitherReader "e" == Left HeapProfBreakdownEra
> heapProfBreakdownEitherReader "r" == Left HeapProfBreakdownRetainer
> heapProfBreakdownEitherReader "b" == Left HeapProfBreakdownBiography
> heapProfBreakdownEitherReader "i" == Left HeapProfBreakdownInfoTable
-}
heapProfBreakdownEitherReader :: String -> Either String HeapProfBreakdown
heapProfBreakdownEitherReader :: String -> Either String HeapProfBreakdown
heapProfBreakdownEitherReader =
  \case
    String
"T" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownClosureType
    String
"c" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownCostCentre
    String
"m" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownModule
    String
"d" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownClosureDescr
    String
"y" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownTypeDescr
    String
"e" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownEra
    String
"r" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownRetainer
    String
"b" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownBiography
    String
"i" -> HeapProfBreakdown -> Either String HeapProfBreakdown
forall a b. b -> Either a b
Right HeapProfBreakdown
HeapProfBreakdownInfoTable
    String
str -> String -> Either String HeapProfBreakdown
forall a b. a -> Either a b
Left (String -> Either String HeapProfBreakdown)
-> String -> Either String HeapProfBreakdown
forall a b. (a -> b) -> a -> b
$ String
"Unsupported heap profile breakdown -h" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str

{- |
Shows a `HeapProfBreakdown` as its corresponding command-line flag:

> heapProfBreakdownShow HeapProfBreakdownClosureType == "-hT"
> heapProfBreakdownShow HeapProfBreakdownCostCentre == "-hc"
> heapProfBreakdownShow HeapProfBreakdownModule == "-hm"
> heapProfBreakdownShow HeapProfBreakdownClosureDescr == "-hd"
> heapProfBreakdownShow HeapProfBreakdownTypeDescr == "-hy"
> heapProfBreakdownShow HeapProfBreakdownEra == "-he"
> heapProfBreakdownShow HeapProfBreakdownRetainer == "-hr"
> heapProfBreakdownShow HeapProfBreakdownBiography == "-hb"
> heapProfBreakdownShow HeapProfBreakdownInfoTable == "-hi"
-}
heapProfBreakdownShow :: HeapProfBreakdown -> String
heapProfBreakdownShow :: HeapProfBreakdown -> String
heapProfBreakdownShow =
  (String
"-h" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (HeapProfBreakdown -> String) -> HeapProfBreakdown -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    HeapProfBreakdown
HeapProfBreakdownClosureType -> String
"T"
    HeapProfBreakdown
HeapProfBreakdownCostCentre -> String
"c"
    HeapProfBreakdown
HeapProfBreakdownModule -> String
"m"
    HeapProfBreakdown
HeapProfBreakdownClosureDescr -> String
"d"
    HeapProfBreakdown
HeapProfBreakdownTypeDescr -> String
"y"
    HeapProfBreakdown
HeapProfBreakdownEra -> String
"e"
    HeapProfBreakdown
HeapProfBreakdownRetainer -> String
"r"
    HeapProfBreakdown
HeapProfBreakdownBiography -> String
"b"
    HeapProfBreakdown
HeapProfBreakdownInfoTable -> String
"i"

{- |
Internal helper.
Determine the `HeapProfBreakdown` from the list of program arguments.

__Warning__: This scan is not fully correct. It merely scans for the presence
of arguments that, as a whole, parse with `heapProfBreakdownEitherReader`.
It does not handle @-with-rtsopts@ and does not restrict its search to those
arguments between @+RTS@ and @-RTS@ tags.
-}
findHeapProfBreakdown :: [Text] -> Maybe HeapProfBreakdown
findHeapProfBreakdown :: [Text] -> Maybe HeapProfBreakdown
findHeapProfBreakdown = [HeapProfBreakdown] -> Maybe HeapProfBreakdown
forall a. [a] -> Maybe a
listToMaybe ([HeapProfBreakdown] -> Maybe HeapProfBreakdown)
-> ([Text] -> [HeapProfBreakdown])
-> [Text]
-> Maybe HeapProfBreakdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe HeapProfBreakdown) -> [Text] -> [HeapProfBreakdown]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe HeapProfBreakdown
parseHeapProfBreakdown
 where
  parseHeapProfBreakdown :: Text -> Maybe HeapProfBreakdown
  parseHeapProfBreakdown :: Text -> Maybe HeapProfBreakdown
parseHeapProfBreakdown Text
arg
    | Text
"-h" Text -> Text -> Bool
`T.isPrefixOf` Text
arg =
        (String -> Maybe HeapProfBreakdown)
-> (HeapProfBreakdown -> Maybe HeapProfBreakdown)
-> Either String HeapProfBreakdown
-> Maybe HeapProfBreakdown
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe HeapProfBreakdown -> String -> Maybe HeapProfBreakdown
forall a b. a -> b -> a
const Maybe HeapProfBreakdown
forall a. Maybe a
Nothing) HeapProfBreakdown -> Maybe HeapProfBreakdown
forall a. a -> Maybe a
Just
          (Either String HeapProfBreakdown -> Maybe HeapProfBreakdown)
-> (Text -> Either String HeapProfBreakdown)
-> Text
-> Maybe HeapProfBreakdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String HeapProfBreakdown
heapProfBreakdownEitherReader
          (String -> Either String HeapProfBreakdown)
-> (Text -> String) -> Text -> Either String HeapProfBreakdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
          (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
2
          (Text -> Maybe HeapProfBreakdown)
-> Text -> Maybe HeapProfBreakdown
forall a b. (a -> b) -> a -> b
$ Text
arg
    | Bool
otherwise = Maybe HeapProfBreakdown
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- Decoding
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- Internal Helpers
-------------------------------------------------------------------------------

{- |
Internal helper. Construct a t`Metric` from an event with a start time
(t`WithStartTime` t`Event`), together with the measurement and any attributes.
This is a smart constructor that pulls the various timestamps out of the event.
-}
metric ::
  WithStartTime Event ->
  v ->
  [Attr] ->
  Metric v
metric :: forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i v
v [Attr]
attr =
  Metric
    { value :: v
value = v
v
    , maybeTimeUnixNano :: Maybe Timestamp
maybeTimeUnixNano = WithStartTime Event -> Maybe Timestamp
tryGetTimeUnixNano WithStartTime Event
i
    , maybeStartTimeUnixNano :: Maybe Timestamp
maybeStartTimeUnixNano = WithStartTime Event
i.maybeStartTimeUnixNano
    , attr :: [Attr]
attr = [Attr]
attr
    }

{- |
Internal helper. Return the minimal value by some projection.
-}
minBy :: (Ord b) => (a -> b) -> a -> a -> a
minBy :: forall b a. Ord b => (a -> b) -> a -> a -> a
minBy a -> b
f a
x a
y = if a -> b
f a
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< a -> b
f a
y then a
x else a
y