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

{- |
Module      : GHC.Eventlog.Live.Machine.Analysis.Heap
Description : Machines for processing eventlog data.
Stability   : experimental
Portability : portable
-}
module GHC.Eventlog.Live.Machine.Analysis.Heap (
  -- * Heap Usage
  processHeapAllocatedData,
  processHeapSizeData,
  processBlocksSizeData,
  processHeapLiveData,
  MemReturnData (..),
  processMemReturnData,
  processHeapProfSampleData,

  -- ** Heap Profile Breakdown
  heapProfBreakdownEitherReader,
  heapProfBreakdownShow,
) where

import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Either (isLeft)
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 (Process, ProcessT, await, construct, repeatedly, yield)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word (Word32, Word64)
import GHC.Eventlog.Live.Data.Attribute (Attr, (~=))
import GHC.Eventlog.Live.Data.Metric (Metric (..))
import GHC.Eventlog.Live.Logger (logWarning)
import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano)
import GHC.Eventlog.Live.Verbosity (Verbosity)
import GHC.RTS.Events (Event (..), HeapProfBreakdown (..))
import GHC.RTS.Events qualified as E
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)

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

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

{- |
This machine processes `E.HeapAllocated` events into metrics.
-}
processHeapAllocatedData :: Process (WithStartTime Event) (Metric Word64)
processHeapAllocatedData :: Process (WithStartTime Event) (Metric Word64)
processHeapAllocatedData =
  PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
 -> MachineT m (Is (WithStartTime Event)) (Metric Word64))
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall a b. (a -> b) -> a -> b
$
    PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Word64) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Word64) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Word64) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.HeapAllocated{Capset
Word64
heapCapset :: Capset
allocBytes :: Word64
heapCapset :: EventInfo -> Capset
allocBytes :: EventInfo -> Word64
..} <- WithStartTime Event
i.value.evSpec ->
            Metric Word64 -> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Word64
 -> Plan (Is (WithStartTime Event)) (Metric Word64) ())
-> Metric Word64
-> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Word64 -> [Attr] -> Metric Word64
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Word64
allocBytes ([Attr] -> Metric Word64) -> [Attr] -> Metric Word64
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 -> Capset -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Capset
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a. a -> PlanT (Is (WithStartTime Event)) (Metric Word64) 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 Word64)
processHeapSizeData = PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
Plan (Is (WithStartTime Event)) (Metric Word64) ()
go
 where
  go :: PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
go =
    PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Word64) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Word64) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Word64) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.HeapSize{Capset
Word64
heapCapset :: EventInfo -> Capset
heapCapset :: Capset
sizeBytes :: Word64
sizeBytes :: EventInfo -> Word64
..} <- WithStartTime Event
i.value.evSpec -> do
            Metric Word64 -> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Word64
 -> Plan (Is (WithStartTime Event)) (Metric Word64) ())
-> Metric Word64
-> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Word64 -> [Attr] -> Metric Word64
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Word64
sizeBytes ([Attr] -> Metric Word64) -> [Attr] -> Metric Word64
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 -> Capset -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Capset
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a. a -> PlanT (Is (WithStartTime Event)) (Metric Word64) 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 Word64)
processBlocksSizeData =
  PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
 -> MachineT m (Is (WithStartTime Event)) (Metric Word64))
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall a b. (a -> b) -> a -> b
$
    PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Word64) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Word64) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Word64) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.BlocksSize{Capset
Word64
heapCapset :: EventInfo -> Capset
heapCapset :: Capset
blocksSize :: Word64
blocksSize :: EventInfo -> Word64
..} <- WithStartTime Event
i.value.evSpec -> do
            Metric Word64 -> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Word64
 -> Plan (Is (WithStartTime Event)) (Metric Word64) ())
-> Metric Word64
-> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Word64 -> [Attr] -> Metric Word64
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Word64
blocksSize ([Attr] -> Metric Word64) -> [Attr] -> Metric Word64
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 -> Capset -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Capset
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a. a -> PlanT (Is (WithStartTime Event)) (Metric Word64) 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 Word64)
processHeapLiveData =
  PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
 -> MachineT m (Is (WithStartTime Event)) (Metric Word64))
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall a b. (a -> b) -> a -> b
$
    PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Word64) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Word64) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Word64) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      WithStartTime Event
i
        | E.HeapLive{Capset
Word64
heapCapset :: EventInfo -> Capset
heapCapset :: Capset
liveBytes :: Word64
liveBytes :: EventInfo -> Word64
..} <- WithStartTime Event
i.value.evSpec -> do
            Metric Word64 -> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Word64
 -> Plan (Is (WithStartTime Event)) (Metric Word64) ())
-> Metric Word64
-> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Word64 -> [Attr] -> Metric Word64
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Word64
liveBytes ([Attr] -> Metric Word64) -> [Attr] -> Metric Word64
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 -> Capset -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Capset
heapCapset
                ]
        | Bool
otherwise -> () -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a. a -> PlanT (Is (WithStartTime Event)) (Metric Word64) 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 -> Capset
current :: !Word32
  -- ^ The number of megablocks currently allocated.
  , MemReturnData -> Capset
needed :: !Word32
  -- ^ The number of megablocks currently needed.
  , MemReturnData -> Capset
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{Capset
heapCapset :: EventInfo -> Capset
heapCapset :: Capset
current :: Capset
needed :: Capset
returned :: Capset
returned :: EventInfo -> Capset
needed :: EventInfo -> Capset
current :: EventInfo -> Capset
..} <- 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{Capset
current :: Capset
needed :: Capset
returned :: Capset
current :: Capset
needed :: Capset
returned :: Capset
..} ([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 -> Capset -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= Capset
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 -> ShowS
showsPrec Int
_ (InfoTablePtr Word64
ptr) =
    String -> ShowS
showString String
"0x" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word64
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 (Word64 -> InfoTablePtr
InfoTablePtr (Word64 -> InfoTablePtr) -> ReadP Word64 -> ReadP InfoTablePtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ReadP String
P.string String
"0x" ReadP String -> ReadP Word64 -> ReadP Word64
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP Word64
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 -> ShowS
[InfoTable] -> ShowS
InfoTable -> String
(Int -> InfoTable -> ShowS)
-> (InfoTable -> String)
-> ([InfoTable] -> ShowS)
-> Show InfoTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InfoTable -> ShowS
showsPrec :: Int -> InfoTable -> ShowS
$cshow :: InfoTable -> String
show :: InfoTable -> String
$cshowList :: [InfoTable] -> ShowS
showList :: [InfoTable] -> ShowS
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 -> [Word64]
heapProfSampleEraStack :: [Word64]
  }
  deriving (Int -> HeapProfSampleState -> ShowS
[HeapProfSampleState] -> ShowS
HeapProfSampleState -> String
(Int -> HeapProfSampleState -> ShowS)
-> (HeapProfSampleState -> String)
-> ([HeapProfSampleState] -> ShowS)
-> Show HeapProfSampleState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeapProfSampleState -> ShowS
showsPrec :: Int -> HeapProfSampleState -> ShowS
$cshow :: HeapProfSampleState -> String
show :: HeapProfSampleState -> String
$cshowList :: [HeapProfSampleState] -> ShowS
showList :: [HeapProfSampleState] -> ShowS
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 Word64)
processHeapProfSampleData Verbosity
verbosityThreshold Maybe HeapProfBreakdown
maybeHeapProfBreakdown =
  PlanT (Is (WithStartTime Event)) (Metric Word64) m Any
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
construct (PlanT (Is (WithStartTime Event)) (Metric Word64) m Any
 -> MachineT m (Is (WithStartTime Event)) (Metric Word64))
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m Any
-> MachineT m (Is (WithStartTime Event)) (Metric Word64)
forall a b. (a -> b) -> a -> b
$
    HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Word64) 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 :: [Word64]
heapProfSampleEraStack = [Word64]
forall a. Monoid a => a
mempty
        }
 where
  -- go :: HeapProfSampleState -> PlanT (Is (WithStartTime Event)) (Metric Word64) m Void
  go :: HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m Any
go st :: HeapProfSampleState
st@HeapProfSampleState{[Word64]
Either Bool HeapProfBreakdown
HashMap InfoTablePtr InfoTable
eitherShouldWarnOrHeapProfBreakdown :: HeapProfSampleState -> Either Bool HeapProfBreakdown
infoTableMap :: HeapProfSampleState -> HashMap InfoTablePtr InfoTable
heapProfSampleEraStack :: HeapProfSampleState -> [Word64]
eitherShouldWarnOrHeapProfBreakdown :: Either Bool HeapProfBreakdown
infoTableMap :: HashMap InfoTablePtr InfoTable
heapProfSampleEraStack :: [Word64]
..} = do
    PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
Plan
  (Is (WithStartTime Event)) (Metric Word64) (WithStartTime Event)
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT
  (Is (WithStartTime Event)) (Metric Word64) m (WithStartTime Event)
-> (WithStartTime Event
    -> PlanT (Is (WithStartTime Event)) (Metric Word64) m Any)
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m Any
forall a b.
PlanT (Is (WithStartTime Event)) (Metric Word64) m a
-> (a -> PlanT (Is (WithStartTime Event)) (Metric Word64) m b)
-> PlanT (Is (WithStartTime Event)) (Metric Word64) 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
Word64
HeapProfBreakdown
Text
heapProfId :: Word8
heapProfSamplingPeriod :: Word64
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 -> Word64
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 Word64) 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]
Capset
capset :: Capset
args :: [Text]
capset :: EventInfo -> Capset
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 Word64) m Any
go HeapProfSampleState
st{eitherShouldWarnOrHeapProfBreakdown = Right heapProfBreakdown}
      -- Announces an info table entry.
      E.InfoTableProv{Int
Word64
Text
itInfo :: Word64
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 -> Word64
..}
        | Either Bool HeapProfBreakdown -> Bool
shouldTrackInfoTableMap Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown -> do
            let infoTablePtr :: InfoTablePtr
infoTablePtr = Word64 -> InfoTablePtr
InfoTablePtr Word64
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 Word64) m Any
go HeapProfSampleState
st{infoTableMap = M.insert infoTablePtr infoTable infoTableMap}
      -- Announces the beginning of a heap profile sample.
      E.HeapProfSampleBegin{Word64
heapProfSampleEra :: Word64
heapProfSampleEra :: EventInfo -> Word64
..} ->
        HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m Any
go HeapProfSampleState
st{heapProfSampleEraStack = heapProfSampleEra : heapProfSampleEraStack}
      -- Announces the end of a heap profile sample.
      E.HeapProfSampleEnd{Word64
heapProfSampleEra :: EventInfo -> Word64
heapProfSampleEra :: Word64
..} ->
        case [Word64] -> Maybe (Word64, [Word64])
forall a. [a] -> Maybe (a, [a])
L.uncons [Word64]
heapProfSampleEraStack of
          Maybe (Word64, [Word64])
Nothing -> do
            Verbosity
-> Text -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Verbosity -> Text -> m ()
logWarning Verbosity
verbosityThreshold (Text -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> (String -> Text)
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> String -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a b. (a -> b) -> a -> b
$
              String -> Word64 -> String
forall r. PrintfType r => String -> r
printf
                String
"Eventlog closed era %d, but there is no current era."
                Word64
heapProfSampleEra
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m Any
go HeapProfSampleState
st
          Just (Word64
currentEra, [Word64]
heapProfSampleEraStack') -> do
            Bool
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word64
currentEra Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
heapProfSampleEra) (PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
 -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a b. (a -> b) -> a -> b
$
              Verbosity
-> Text -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Verbosity -> Text -> m ()
logWarning Verbosity
verbosityThreshold (Text -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> (String -> Text)
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> String -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a b. (a -> b) -> a -> b
$
                String -> Word64 -> Word64 -> String
forall r. PrintfType r => String -> r
printf
                  String
"Eventlog closed era %d, but the current era is era %d."
                  Word64
heapProfSampleEra
                  Word64
currentEra
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m Any
go HeapProfSampleState
st{heapProfSampleEraStack = heapProfSampleEraStack'}
      -- Announces a heap profile sample.
      E.HeapProfSampleString{Word8
Word64
Text
heapProfId :: EventInfo -> Word8
heapProfId :: Word8
heapProfResidency :: Word64
heapProfLabel :: Text
heapProfLabel :: EventInfo -> Text
heapProfResidency :: EventInfo -> Word64
..}
        -- If there is no heap profile breakdown, issue a warning, then disable warnings.
        | Left Bool
True <- Either Bool HeapProfBreakdown
eitherShouldWarnOrHeapProfBreakdown -> do
            Verbosity
-> Text -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Verbosity -> Text -> m ()
logWarning Verbosity
verbosityThreshold (Text -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> Text -> PlanT (Is (WithStartTime Event)) (Metric Word64) 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 Word64) 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 -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Verbosity -> Text -> m ()
logWarning Verbosity
verbosityThreshold (Text -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> (String -> Text)
-> String
-> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ())
-> String -> PlanT (Is (WithStartTime Event)) (Metric Word64) m ()
forall a b. (a -> b) -> a -> b
$
              String -> ShowS
forall r. PrintfType r => String -> r
printf
                String
"Unsupported heap profile breakdown %s"
                (HeapProfBreakdown -> String
heapProfBreakdownShow HeapProfBreakdown
HeapProfBreakdownBiography)
            HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Word64) 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 Word64 -> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall o (k :: * -> *). o -> Plan k o ()
yield (Metric Word64
 -> Plan (Is (WithStartTime Event)) (Metric Word64) ())
-> Metric Word64
-> Plan (Is (WithStartTime Event)) (Metric Word64) ()
forall a b. (a -> b) -> a -> b
$
              WithStartTime Event -> Word64 -> [Attr] -> Metric Word64
forall v. WithStartTime Event -> v -> [Attr] -> Metric v
metric WithStartTime Event
i Word64
heapProfResidency ([Attr] -> Metric Word64) -> [Attr] -> Metric Word64
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 Word64 -> Attr
forall v. IsAttrValue v => Text -> v -> Attr
~= ((Word64, [Word64]) -> Word64
forall a b. (a, b) -> a
fst ((Word64, [Word64]) -> Word64)
-> Maybe (Word64, [Word64]) -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64] -> Maybe (Word64, [Word64])
forall a. [a] -> Maybe (a, [a])
L.uncons [Word64]
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 Word64) m Any
go (HeapProfSampleState
 -> PlanT (Is (WithStartTime Event)) (Metric Word64) m Any)
-> HeapProfSampleState
-> PlanT (Is (WithStartTime Event)) (Metric Word64) 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 Word64) 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 -> ShowS
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 -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS
-> (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

-------------------------------------------------------------------------------
-- 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 Word64
maybeTimeUnixNano = WithStartTime Event -> Maybe Word64
tryGetTimeUnixNano WithStartTime Event
i
    , maybeStartTimeUnixNano :: Maybe Word64
maybeStartTimeUnixNano = WithStartTime Event
i.maybeStartTimeUnixNano
    , attr :: [Attr]
attr = [Attr]
attr
    }