{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PartialTypeSignatures #-}
module Eventlog.Events(chunk) where

import GHC.RTS.Events hiding (Header, header, liveBytes, blocksSize)
import Prelude hiding (init, lookup)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text (Text)

import Eventlog.Types
import Eventlog.Total
import Eventlog.Args (Args(..))
import Data.List (foldl')
import Data.Function
import Data.Word
import Data.Time
import Data.Time.Clock.POSIX
import qualified Data.Map as Map
import Data.Vector.Unboxed (Vector, (!?), toList)
import Data.Maybe
import Data.Version
import Text.ParserCombinators.ReadP
import Control.Monad
import Data.Char
import System.IO
import qualified Data.Trie.Map as Trie
import Data.Map.Merge.Lazy
import Data.Functor.Identity
import qualified Data.Text.Lazy.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Aeson


type PartialHeader = Int -> Header

fromNano :: Word64 -> Double
fromNano :: Word64 -> Double
fromNano Word64
e = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
e forall a. Num a => a -> a -> a
* Double
1e-9


chunk :: Args -> FilePath -> IO ProfData
chunk :: Args -> [Char] -> IO ProfData
chunk Args
a [Char]
f = do
  (EventLog Header
_ Data
e) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Either [Char] EventLog)
readEventLogFromFile [Char]
f
  (PartialHeader
ph, BucketMap
bucket_map, Map Word32 CostCentre
ccMap, [Frame]
frames, [Trace]
traces, Map InfoTablePtr InfoTableLoc
ipes, HeapInfo
hdata, Map TickyCounterId TickyCounter
ticky_counters, [TickySample]
ticky_samples, Word64
total_allocs) <- Args
-> Data
-> IO
     (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame], [Trace],
      Map InfoTablePtr InfoTableLoc, HeapInfo,
      Map TickyCounterId TickyCounter, [TickySample], Word64)
eventsToHP Args
a Data
e
  let (Int
counts, Map Bucket (Double, Double, Maybe (Double, Double, Double))
totals) = [Frame]
-> (Int,
    Map Bucket (Double, Double, Maybe (Double, Double, Double)))
total [Frame]
frames
      -- If both keys are present, combine
      combine :: WhenMatched
  Identity
  k
  (Text, Maybe [Word32])
  (Double, Double, Maybe (Double, Double, Double))
  BucketInfo
combine = forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f z) -> WhenMatched f k x y z
zipWithAMatched (\k
_ (Text
t, Maybe [Word32]
mt) (Double
tot, Double
sd, Maybe (Double, Double, Double)
g) -> forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ Text
-> Maybe [Word32]
-> Double
-> Double
-> Maybe (Double, Double, Double)
-> BucketInfo
BucketInfo Text
t Maybe [Word32]
mt Double
tot Double
sd Maybe (Double, Double, Double)
g)
      -- If total is missing, something bad has happened
      combineMissingTotal :: Bucket -> (Text, Maybe [Word32]) -> Identity BucketInfo
      combineMissingTotal :: Bucket -> (Text, Maybe [Word32]) -> Identity BucketInfo
combineMissingTotal Bucket
k = forall a. HasCallStack => [Char] -> a
error ([Char]
"Missing total for: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Bucket
k)

      -- This case happens when we are not in CC mode
      combineMissingDesc :: Bucket -> (Double, Double, Maybe (Double, Double, Double)) -> Identity BucketInfo
      combineMissingDesc :: Bucket
-> (Double, Double, Maybe (Double, Double, Double))
-> Identity BucketInfo
combineMissingDesc (Bucket Text
t) (Double
tot, Double
sd, Maybe (Double, Double, Double)
g) = forall a. a -> Identity a
Identity (Text
-> Maybe [Word32]
-> Double
-> Double
-> Maybe (Double, Double, Double)
-> BucketInfo
BucketInfo Text
t forall a. Maybe a
Nothing Double
tot Double
sd Maybe (Double, Double, Double)
g)

      binfo :: Map Bucket BucketInfo
binfo = forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
merge (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
traverseMissing Bucket -> (Text, Maybe [Word32]) -> Identity BucketInfo
combineMissingTotal) (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
traverseMissing Bucket
-> (Double, Double, Maybe (Double, Double, Double))
-> Identity BucketInfo
combineMissingDesc) forall {k}.
WhenMatched
  Identity
  k
  (Text, Maybe [Word32])
  (Double, Double, Maybe (Double, Double, Double))
  BucketInfo
combine BucketMap
bucket_map Map Bucket (Double, Double, Maybe (Double, Double, Double))
totals

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Header
-> Map Bucket BucketInfo
-> Map Word32 CostCentre
-> [Frame]
-> [Trace]
-> HeapInfo
-> Map InfoTablePtr InfoTableLoc
-> Map TickyCounterId TickyCounter
-> [TickySample]
-> Word64
-> ProfData
ProfData (PartialHeader
ph Int
counts) Map Bucket BucketInfo
binfo Map Word32 CostCentre
ccMap [Frame]
frames [Trace]
traces HeapInfo
hdata Map InfoTablePtr InfoTableLoc
ipes Map TickyCounterId TickyCounter
ticky_counters [TickySample]
ticky_samples Word64
total_allocs)

checkGHCVersion :: EL -> Maybe Text
checkGHCVersion :: EL -> Maybe Text
checkGHCVersion EL { ident :: EL -> Maybe (Version, Text)
ident = Just (Version
version,Text
_)}
  | Version
version forall a. Ord a => a -> a -> Bool
<= [Int] -> Version
makeVersion [Int
8,Int
4,Int
4]  =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"Warning: The eventlog has been generated with ghc-"
           forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Version -> [Char]
showVersion Version
version)
           forall a. Semigroup a => a -> a -> a
<> Text
", which does not support profiling events in the eventlog."
checkGHCVersion EL { pargs :: EL -> Maybe [Text]
pargs = Just [Text]
args, ident :: EL -> Maybe (Version, Text)
ident = Just (Version
version,Text
_)}
  | Version
version forall a. Ord a => a -> a -> Bool
> [Int] -> Version
makeVersion [Int
8,Int
4,Int
4] Bool -> Bool -> Bool
&&
    Version
version forall a. Ord a => a -> a -> Bool
<= [Int] -> Version
makeVersion [Int
8,Int
9,Int
0] Bool -> Bool -> Bool
&&
    (Text
"-hr" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
args Bool -> Bool -> Bool
|| Text
"-hb" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
args) =
     forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"Warning: The eventlog has been generated with ghc-"
            forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Version -> [Char]
showVersion Version
version)
            forall a. Semigroup a => a -> a -> a
<> Text
", which does not support biographical or retainer profiling."
checkGHCVersion EL
_ = forall a. Maybe a
Nothing

eventsToHP :: Args -> Data -> IO (PartialHeader, BucketMap, Map.Map Word32 CostCentre, [Frame], [Trace]
                                 , Map.Map InfoTablePtr InfoTableLoc, HeapInfo, Map.Map TickyCounterId TickyCounter, [TickySample]
                                 , Word64)
eventsToHP :: Args
-> Data
-> IO
     (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame], [Trace],
      Map InfoTablePtr InfoTableLoc, HeapInfo,
      Map TickyCounterId TickyCounter, [TickySample], Word64)
eventsToHP Args
a (Data [Event]
es) = do
  let
      el :: EL
el@EL{[(InfoTablePtr, InfoTableLoc)]
[TickySample]
[TickyCounter]
[Trace]
[HeapSample]
[FrameEL]
Maybe [Char]
Maybe [Text]
Maybe Word64
Maybe (Version, Text)
Maybe HeapProfBreakdown
Maybe FrameEL
Word64
Map Word32 Word64
Map Word32 CostCentre
BucketMap
CCSMap
total_allocs :: EL -> Map Word32 Word64
end :: EL -> Word64
start :: EL -> Word64
ticky_counter :: EL -> [TickyCounter]
ticky_samples :: EL -> [TickySample]
ipes :: EL -> [(InfoTablePtr, InfoTableLoc)]
traces :: EL -> [Trace]
frames :: EL -> [FrameEL]
samples :: EL -> Maybe FrameEL
clocktimeSec :: EL -> Word64
ccsMap :: EL -> CCSMap
bucketMap :: EL -> BucketMap
ccMap :: EL -> Map Word32 CostCentre
heapProfileType :: EL -> Maybe HeapProfBreakdown
samplingRate :: EL -> Maybe Word64
blocksSize :: EL -> [HeapSample]
liveBytes :: EL -> [HeapSample]
heapSize :: EL -> [HeapSample]
programInvocation :: EL -> Maybe [Char]
total_allocs :: Map Word32 Word64
end :: Word64
start :: Word64
ticky_counter :: [TickyCounter]
ticky_samples :: [TickySample]
ipes :: [(InfoTablePtr, InfoTableLoc)]
traces :: [Trace]
frames :: [FrameEL]
samples :: Maybe FrameEL
clocktimeSec :: Word64
ccsMap :: CCSMap
bucketMap :: BucketMap
ccMap :: Map Word32 CostCentre
heapProfileType :: Maybe HeapProfBreakdown
samplingRate :: Maybe Word64
ident :: Maybe (Version, Text)
blocksSize :: [HeapSample]
liveBytes :: [HeapSample]
heapSize :: [HeapSample]
programInvocation :: Maybe [Char]
pargs :: Maybe [Text]
pargs :: EL -> Maybe [Text]
ident :: EL -> Maybe (Version, Text)
..} = Args -> [Event] -> EL
foldEvents Args
a [Event]
es
      fir :: Frame
fir = Double -> [Sample] -> Frame
Frame (Word64 -> Double
fromNano Word64
start) []
      las :: Frame
las = Double -> [Sample] -> Frame
Frame (Word64 -> Double
fromNano Word64
end) []
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr) (EL -> Maybe Text
checkGHCVersion EL
el)
  let heapInfo :: HeapInfo
heapInfo = [HeapSample] -> [HeapSample] -> [HeapSample] -> HeapInfo
HeapInfo (forall a. [a] -> [a]
reverse [HeapSample]
heapSize) (forall a. [a] -> [a]
reverse [HeapSample]
blocksSize) (forall a. [a] -> [a]
reverse [HeapSample]
liveBytes)

      ticky_counter_map :: Map TickyCounterId TickyCounter
ticky_counter_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> TickyCounterId
TickyCounterId (TickyCounter -> Word64
tickyCtrId TickyCounter
t) , TickyCounter
t) | TickyCounter
t <- [TickyCounter]
ticky_counter]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (EL -> PartialHeader
elHeader EL
el, EL -> BucketMap
elBucketMap EL
el, Map Word32 CostCentre
ccMap, Frame
fir forall a. a -> [a] -> [a]
: forall a. [a] -> [a]
reverse (Frame
lasforall a. a -> [a] -> [a]
: [FrameEL] -> [Frame]
normalise [FrameEL]
frames)
           , forall a. [a] -> [a]
reverse [Trace]
traces, forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(InfoTablePtr, InfoTableLoc)]
ipes, HeapInfo
heapInfo, Map TickyCounterId TickyCounter
ticky_counter_map
           , [TickySample]
ticky_samples
           , forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Map Word32 Word64
total_allocs))

normalise :: [FrameEL] -> [Frame]
normalise :: [FrameEL] -> [Frame]
normalise = forall a b. (a -> b) -> [a] -> [b]
map (\(FrameEL Word64
t [Sample]
ss) -> Double -> [Sample] -> Frame
Frame (Word64 -> Double
fromNano Word64
t) [Sample]
ss)

type BucketMap = Map.Map Bucket (Text, Maybe [Word32])

data EL = EL
  { EL -> Maybe [Text]
pargs :: !(Maybe [Text])
  , EL -> Maybe [Char]
programInvocation :: !(Maybe FilePath)
  , EL -> [HeapSample]
heapSize :: ![HeapSample]
  , EL -> [HeapSample]
liveBytes :: ![HeapSample]
  , EL -> [HeapSample]
blocksSize :: ![HeapSample]
  , EL -> Maybe (Version, Text)
ident :: Maybe (Version, Text)
  , EL -> Maybe Word64
samplingRate :: !(Maybe Word64)
  , EL -> Maybe HeapProfBreakdown
heapProfileType :: !(Maybe HeapProfBreakdown)
  , EL -> Map Word32 CostCentre
ccMap :: !(Map.Map Word32 CostCentre)
  -- At the moment bucketMap and CCS map are quite similar, cost centre profiling
  -- is the only mode to populate the bucket map
  , EL -> BucketMap
bucketMap :: BucketMap
  , EL -> CCSMap
ccsMap :: CCSMap
  , EL -> Word64
clocktimeSec :: !Word64
  , EL -> Maybe FrameEL
samples :: !(Maybe FrameEL)
  , EL -> [FrameEL]
frames :: ![FrameEL]
  , EL -> [Trace]
traces :: ![Trace]
  , EL -> [(InfoTablePtr, InfoTableLoc)]
ipes :: ![(InfoTablePtr, InfoTableLoc)]
  , EL -> [TickySample]
ticky_samples :: ![TickySample]
  , EL -> [TickyCounter]
ticky_counter :: ![TickyCounter]
  , EL -> Word64
start :: !Word64
  , EL -> Word64
end :: !Word64
  , EL -> Map Word32 Word64
total_allocs :: !(Map.Map Capset Word64) } deriving Int -> EL -> ShowS
[EL] -> ShowS
EL -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EL] -> ShowS
$cshowList :: [EL] -> ShowS
show :: EL -> [Char]
$cshow :: EL -> [Char]
showsPrec :: Int -> EL -> ShowS
$cshowsPrec :: Int -> EL -> ShowS
Show




data FrameEL = FrameEL Word64 [Sample] deriving Int -> FrameEL -> ShowS
[FrameEL] -> ShowS
FrameEL -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FrameEL] -> ShowS
$cshowList :: [FrameEL] -> ShowS
show :: FrameEL -> [Char]
$cshow :: FrameEL -> [Char]
showsPrec :: Int -> FrameEL -> ShowS
$cshowsPrec :: Int -> FrameEL -> ShowS
Show

data CCSMap = CCSMap (Trie.TMap Word32 CCStack) Int deriving Int -> CCSMap -> ShowS
[CCSMap] -> ShowS
CCSMap -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CCSMap] -> ShowS
$cshowList :: [CCSMap] -> ShowS
show :: CCSMap -> [Char]
$cshow :: CCSMap -> [Char]
showsPrec :: Int -> CCSMap -> ShowS
$cshowsPrec :: Int -> CCSMap -> ShowS
Show


data CCStack = CCStack { CCStack -> Int
ccsId :: Int, CCStack -> Text
ccsName :: Text } deriving Int -> CCStack -> ShowS
[CCStack] -> ShowS
CCStack -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CCStack] -> ShowS
$cshowList :: [CCStack] -> ShowS
show :: CCStack -> [Char]
$cshow :: CCStack -> [Char]
showsPrec :: Int -> CCStack -> ShowS
$cshowsPrec :: Int -> CCStack -> ShowS
Show

getCCSId :: EL -> Vector Word32 -> (CCStack, EL)
getCCSId :: EL -> Vector Word32 -> (CCStack, EL)
getCCSId el :: EL
el@EL { ccsMap :: EL -> CCSMap
ccsMap = (CCSMap TMap Word32 CCStack
trie Int
uniq), ccMap :: EL -> Map Word32 CostCentre
ccMap = Map Word32 CostCentre
ccMap } Vector Word32
k  =
  let kl :: [Word32]
kl = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
toList Vector Word32
k
  in case forall c a. Ord c => [c] -> TMap c a -> Maybe a
Trie.lookup [Word32]
kl TMap Word32 CCStack
trie of
        Just CCStack
n -> (CCStack
n, EL
el)
        Maybe CCStack
Nothing ->
          let new_stack :: CCStack
new_stack = Int -> Text -> CCStack
CCStack Int
uniq Text
name

              sid :: Text
sid = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
uniq forall a. [a] -> [a] -> [a]
++ [Char]
") "
              short_bucket_info :: Text
short_bucket_info = Text
sid forall a. Semigroup a => a -> a -> a
<> Text
name
              bucket_info :: (Text, Maybe [Word32])
bucket_info = (Text
short_bucket_info, forall a. a -> Maybe a
Just [Word32]
kl)
              bucket_key :: Bucket
bucket_key = Text -> Bucket
Bucket ([Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Int
uniq))
          in (CCStack
new_stack, EL
el { ccsMap :: CCSMap
ccsMap = TMap Word32 CCStack -> Int -> CCSMap
CCSMap (forall c a. Ord c => [c] -> a -> TMap c a -> TMap c a
Trie.insert [Word32]
kl CCStack
new_stack TMap Word32 CCStack
trie) (Int
uniq forall a. Num a => a -> a -> a
+ Int
1)
                            , bucketMap :: BucketMap
bucketMap = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Bucket
bucket_key (Text, Maybe [Word32])
bucket_info (EL -> BucketMap
bucketMap EL
el) })
  where
    name :: Text
name = forall a. a -> Maybe a -> a
fromMaybe Text
"MAIN" forall a b. (a -> b) -> a -> b
$ do
             Word32
cid <- (Vector Word32
k forall a. Unbox a => Vector a -> Int -> Maybe a
!? Int
0)
             CC{Text
label :: CostCentre -> Text
label :: Text
label} <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word32
cid Map Word32 CostCentre
ccMap
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
label


initEL :: EL
initEL :: EL
initEL = EL
  { pargs :: Maybe [Text]
pargs = forall a. Maybe a
Nothing
  , ident :: Maybe (Version, Text)
ident = forall a. Maybe a
Nothing
  , samplingRate :: Maybe Word64
samplingRate = forall a. Maybe a
Nothing
  , heapProfileType :: Maybe HeapProfBreakdown
heapProfileType = forall a. Maybe a
Nothing
  , clocktimeSec :: Word64
clocktimeSec = Word64
0
  , samples :: Maybe FrameEL
samples = forall a. Maybe a
Nothing
  , heapSize :: [HeapSample]
heapSize = []
  , liveBytes :: [HeapSample]
liveBytes = []
  , blocksSize :: [HeapSample]
blocksSize = []
  , frames :: [FrameEL]
frames = []
  , traces :: [Trace]
traces = []
  , ipes :: [(InfoTablePtr, InfoTableLoc)]
ipes = []
  , start :: Word64
start = Word64
0
  , end :: Word64
end = Word64
0
  , ccMap :: Map Word32 CostCentre
ccMap = forall k a. Map k a
Map.empty
  , ccsMap :: CCSMap
ccsMap =  TMap Word32 CCStack -> Int -> CCSMap
CCSMap forall c a. TMap c a
Trie.empty Int
0
  , bucketMap :: BucketMap
bucketMap = forall k a. Map k a
Map.empty
  , programInvocation :: Maybe [Char]
programInvocation = forall a. Maybe a
Nothing
  , ticky_samples :: [TickySample]
ticky_samples = []
  , ticky_counter :: [TickyCounter]
ticky_counter = []
  , total_allocs :: Map Word32 Word64
total_allocs  = forall k a. Map k a
Map.empty
  }

foldEvents :: Args -> [Event] -> EL
foldEvents :: Args -> [Event] -> EL
foldEvents Args
a [Event]
es =
  let res :: EL
res = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Args -> EL -> Event -> EL
folder Args
a) EL
initEL [Event]
es
  in Word64 -> EL -> EL
addFrame Word64
0 EL
res

folder :: Args -> EL -> Event -> EL
folder :: Args -> EL -> Event -> EL
folder Args
a EL
el (Event Word64
t EventInfo
e Maybe Int
_) = EL
el forall a b. a -> (a -> b) -> b
&
  Word64 -> EL -> EL
updateLast Word64
t forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    case EventInfo
e of
      -- Traces
      -- Messages and UserMessages correspond to high-frequency "traceEvent" or "traceEventIO" events from Debug.Trace and
      -- are only included if "--include-trace-events" has been specified.
      -- For low-frequency events "traceMarker" or "traceMarkerIO" should be used, which generate "UserMarker" events.
      Message Text
s -> if Args -> Bool
traceEvents Args
a then Args -> Trace -> EL -> EL
addTrace Args
a (Double -> Text -> Trace
Trace (Word64 -> Double
fromNano Word64
t) Text
s) else forall a. a -> a
id
      UserMessage Text
s -> if Args -> Bool
traceEvents Args
a then Args -> Trace -> EL -> EL
addTrace Args
a (Double -> Text -> Trace
Trace (Word64 -> Double
fromNano Word64
t) Text
s) else forall a. a -> a
id
      UserMarker Text
s -> Args -> Trace -> EL -> EL
addTrace Args
a (Double -> Text -> Trace
Trace (Word64 -> Double
fromNano Word64
t) Text
s)
      -- Information about the program
      RtsIdentifier Word32
_ Text
ident -> Text -> EL -> EL
addIdent Text
ident
      ProgramArgs Word32
_ [Text]
as -> [Text] -> EL -> EL
addArgs [Text]
as
      ProgramInvocation [Char]
inv -> [Char] -> EL -> EL
addInvocation [Char]
inv
      WallClockTime Word32
_ Word64
s Word32
_ -> Word64 -> EL -> EL
addClocktime Word64
s
      -- Profiling Events
      HeapProfBegin { Word64
heapProfSamplingPeriod :: EventInfo -> Word64
heapProfSamplingPeriod :: Word64
heapProfSamplingPeriod, HeapProfBreakdown
heapProfBreakdown :: EventInfo -> HeapProfBreakdown
heapProfBreakdown :: HeapProfBreakdown
heapProfBreakdown } -> Word64 -> HeapProfBreakdown -> EL -> EL
addHeapProfBegin Word64
heapProfSamplingPeriod HeapProfBreakdown
heapProfBreakdown
      HeapProfCostCentre Word32
cid Text
l Text
m Text
loc HeapProfFlags
_  -> Word32 -> CostCentre -> EL -> EL
addCostCentre Word32
cid (Word32 -> Text -> Text -> Text -> CostCentre
CC Word32
cid Text
l Text
m Text
loc)
      HeapProfSampleBegin {}
        | Word64
t forall a. Ord a => a -> a -> Bool
>= Word64
1 -> Word64 -> EL -> EL
addFrame Word64
t
      HeapBioProfSampleBegin { heapProfSampleTime :: EventInfo -> Word64
heapProfSampleTime = Word64
t' } -> Word64 -> EL -> EL
addFrame Word64
t'
      HeapProfSampleCostCentre Word8
_hid Word64
r Word8
d Vector Word32
s -> Word64 -> Word8 -> Vector Word32 -> EL -> EL
addCCSample Word64
r Word8
d Vector Word32
s
      HeapProfSampleString Word8
_hid Word64
res Text
k -> Sample -> EL -> EL
addSample (Bucket -> Double -> Sample
Sample (Text -> Bucket
Bucket Text
k) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
res))
      InfoTableProv Word64
ptr Text
name Int
desc Text
ty Text
lbl Text
smod Text
sloc -> (InfoTablePtr, InfoTableLoc) -> EL -> EL
addInfoTableLoc (Word64 -> InfoTablePtr
InfoTablePtr Word64
ptr,
                                              Text -> ClosureType -> Text -> Text -> Text -> Text -> InfoTableLoc
InfoTableLoc Text
name (Int -> ClosureType
parseClosureType Int
desc) Text
ty Text
lbl Text
smod Text
sloc)
      HeapSize Word32
_ Word64
b -> Word64 -> Word64 -> EL -> EL
addHeapSize Word64
t Word64
b
      HeapLive Word32
_ Word64
b -> Word64 -> Word64 -> EL -> EL
addHeapLive Word64
t Word64
b
      BlocksSize Word32
_ Word64
b -> Word64 -> Word64 -> EL -> EL
addBlocksSize Word64
t Word64
b
      TickyCounterDef Word64
defid Word16
arity Text
_ Text
name Word64
tid (Just Text
json_desc) -> Word64 -> Word16 -> Text -> Word64 -> Text -> EL -> EL
addTickyDef Word64
defid Word16
arity Text
name Word64
tid Text
json_desc
      TickyCounterSample Word64
defid Word64
entries Word64
allocs Word64
allocd -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> EL -> EL
addTickySample Word64
t Word64
defid Word64
entries Word64
allocs Word64
allocd

      HeapAllocated Word32
cp Word64
alloc_bytes -> Word32 -> Word64 -> EL -> EL
addHeapAllocated Word32
cp Word64
alloc_bytes
      EventInfo
_ -> forall a. a -> a
id

addHeapAllocated :: Capset -> Word64 -> EL -> EL
-- The counter is the total since the start of the program.
addHeapAllocated :: Word32 -> Word64 -> EL -> EL
addHeapAllocated Word32
cid Word64
w64 EL
el = EL
el { total_allocs :: Map Word32 Word64
total_allocs = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Word32
cid Word64
w64 (EL -> Map Word32 Word64
total_allocs EL
el)}

parseClosureType :: Int -> ClosureType
parseClosureType :: Int -> ClosureType
parseClosureType Int
ct = forall a. Enum a => Int -> a
toEnum Int
ct

addInfoTableLoc :: (InfoTablePtr, InfoTableLoc) -> EL -> EL
addInfoTableLoc :: (InfoTablePtr, InfoTableLoc) -> EL -> EL
addInfoTableLoc (InfoTablePtr, InfoTableLoc)
itl EL
el = EL
el { ipes :: [(InfoTablePtr, InfoTableLoc)]
ipes = (InfoTablePtr, InfoTableLoc)
itl forall a. a -> [a] -> [a]
: EL -> [(InfoTablePtr, InfoTableLoc)]
ipes EL
el }

addHeapProfBegin :: Word64 -> HeapProfBreakdown -> EL -> EL
addHeapProfBegin :: Word64 -> HeapProfBreakdown -> EL -> EL
addHeapProfBegin Word64
sr HeapProfBreakdown
hptype EL
el = EL
el { samplingRate :: Maybe Word64
samplingRate = forall a. a -> Maybe a
Just Word64
sr, heapProfileType :: Maybe HeapProfBreakdown
heapProfileType = forall a. a -> Maybe a
Just HeapProfBreakdown
hptype }

addIdent :: Text -> EL -> EL
addIdent :: Text -> EL -> EL
addIdent Text
s EL
el = EL
el { ident :: Maybe (Version, Text)
ident = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Maybe (Version, [Char])
parseIdent (Text -> [Char]
T.unpack Text
s)) }

parseIdent :: String -> Maybe (Version, String)
parseIdent :: [Char] -> Maybe (Version, [Char])
parseIdent [Char]
s = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. ReadP a -> ReadS a
readP_to_S [Char]
s forall a b. (a -> b) -> a -> b
$ do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ [Char] -> ReadP [Char]
string [Char]
"GHC-"
  [Int
v1, Int
v2, Int
v3] <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 (ReadP Int
intP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. ReadP a -> ReadP ()
optional (Char -> ReadP Char
char Char
'.'))
  ReadP ()
skipSpaces
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> Version
makeVersion [Int
v1,Int
v2,Int
v3])
  where
    intP :: ReadP Int
intP = do
      [Char]
x <- (Char -> Bool) -> ReadP [Char]
munch1 Char -> Bool
isDigit
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> a
read [Char]
x

addCostCentre :: Word32 -> CostCentre -> EL -> EL
addCostCentre :: Word32 -> CostCentre -> EL -> EL
addCostCentre Word32
s CostCentre
cc EL
el = EL
el { ccMap :: Map Word32 CostCentre
ccMap = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Word32
s CostCentre
cc (EL -> Map Word32 CostCentre
ccMap EL
el) }

addCCSample :: Word64 -> Word8 -> Vector Word32 -> EL -> EL
addCCSample :: Word64 -> Word8 -> Vector Word32 -> EL -> EL
addCCSample Word64
res Word8
_sd Vector Word32
st EL
el =
  let (CCStack Int
stack_id Text
_tid, EL
el') = EL -> Vector Word32 -> (CCStack, EL)
getCCSId EL
el Vector Word32
st
      -- TODO: Can do better than this by differentiating normal samples form stack samples
      sample_string :: Text
sample_string = [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Int
stack_id)
  in Sample -> EL -> EL
addSample (Bucket -> Double -> Sample
Sample (Text -> Bucket
Bucket Text
sample_string) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
res)) EL
el'


addClocktime :: Word64 -> EL -> EL
addClocktime :: Word64 -> EL -> EL
addClocktime Word64
s EL
el = EL
el { clocktimeSec :: Word64
clocktimeSec = Word64
s }

addArgs :: [Text] -> EL -> EL
addArgs :: [Text] -> EL -> EL
addArgs [Text]
as EL
el = EL
el { pargs :: Maybe [Text]
pargs = forall a. a -> Maybe a
Just [Text]
as }

addInvocation :: String -> EL -> EL
addInvocation :: [Char] -> EL -> EL
addInvocation [Char]
inv EL
el = EL
el { programInvocation :: Maybe [Char]
programInvocation = forall a. a -> Maybe a
Just [Char]
inv }

addHeapLive :: Timestamp -> Word64 -> EL -> EL
addHeapLive :: Word64 -> Word64 -> EL -> EL
addHeapLive Word64
t Word64
s EL
el = EL
el { liveBytes :: [HeapSample]
liveBytes = Double -> Word64 -> HeapSample
HeapSample (Word64 -> Double
fromNano Word64
t) Word64
s forall a. a -> [a] -> [a]
: EL -> [HeapSample]
liveBytes EL
el }

addHeapSize :: Timestamp -> Word64 -> EL -> EL
addHeapSize :: Word64 -> Word64 -> EL -> EL
addHeapSize Word64
t Word64
s EL
el = EL
el { heapSize :: [HeapSample]
heapSize = Double -> Word64 -> HeapSample
HeapSample (Word64 -> Double
fromNano Word64
t) Word64
s forall a. a -> [a] -> [a]
: EL -> [HeapSample]
heapSize EL
el }

addBlocksSize :: Timestamp -> Word64 -> EL -> EL
addBlocksSize :: Word64 -> Word64 -> EL -> EL
addBlocksSize Word64
t Word64
s EL
el = EL
el { blocksSize :: [HeapSample]
blocksSize = Double -> Word64 -> HeapSample
HeapSample (Word64 -> Double
fromNano Word64
t) Word64
s forall a. a -> [a] -> [a]
: EL -> [HeapSample]
blocksSize EL
el}

addTickyDef :: Word64 -> Word16 -> Text -> Word64 -> Text -> EL -> EL
addTickyDef :: Word64 -> Word16 -> Text -> Word64 -> Text -> EL -> EL
addTickyDef Word64
a Word16
b Text
d Word64
e Text
ticky_json EL
el =
  case forall a. FromJSON a => ByteString -> Maybe a
decode (Text -> ByteString
TE.encodeUtf8 (Text -> Text
TL.fromStrict Text
ticky_json)) of
    Just TickyCounterArgs
argInfo -> EL
el { ticky_counter :: [TickyCounter]
ticky_counter = Word64
-> Word16
-> TickyCounterArgs
-> Text
-> InfoTablePtr
-> TickyCounter
TickyCounter Word64
a Word16
b TickyCounterArgs
argInfo Text
d (Word64 -> InfoTablePtr
InfoTablePtr Word64
e) forall a. a -> [a] -> [a]
: EL -> [TickyCounter]
ticky_counter EL
el }
    Maybe TickyCounterArgs
Nothing   -> EL
el

addTickySample :: Timestamp -> Word64 -> Word64 -> Word64 -> Word64 -> EL -> EL
addTickySample :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> EL -> EL
addTickySample Word64
t Word64
a Word64
b Word64
c Word64
d EL
el = EL
el { ticky_samples :: [TickySample]
ticky_samples = Word64 -> Word64 -> Word64 -> Word64 -> Double -> TickySample
TickySample Word64
a Word64
b Word64
c Word64
d (Word64 -> Double
fromNano Word64
t) forall a. a -> [a] -> [a]
: EL -> [TickySample]
ticky_samples EL
el }


-- | Decide whether to include a trace based on the "includes" and
-- "excludes" options.
--
-- If a trace satisfies an `-i` flag then it is certainly included.
--
-- For example for a trace called "eventlog2html" then `-i eventlog -x
-- html` will still include the trace because the `-i` option matches.
--
-- If a trace doesn't match an `-i` flag then it is excluded if it matches
-- a `-x` flag.
--
filterTrace :: [Text] -> [Text] -> Trace -> Bool
filterTrace :: [Text] -> [Text] -> Trace -> Bool
filterTrace []       []       Trace
_             = Bool
True
filterTrace []       [Text]
excludes (Trace Double
_ Text
trc) =
  Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
T.isInfixOf Text
trc) [Text]
excludes)
filterTrace [Text]
includes []       (Trace Double
_ Text
trc) =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
T.isInfixOf Text
trc) [Text]
includes
filterTrace [Text]
includes [Text]
excludes (Trace Double
_ Text
trc) =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
T.isInfixOf Text
trc) [Text]
includes
    Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
T.isInfixOf Text
trc) [Text]
excludes)

addTrace :: Args -> Trace -> EL -> EL
addTrace :: Args -> Trace -> EL -> EL
addTrace Args
a Trace
t EL
el | Args -> Bool
noTraces Args
a = EL
el
                | Trace -> Bool
prop Trace
t     = EL
el { traces :: [Trace]
traces = Trace
t forall a. a -> [a] -> [a]
: EL -> [Trace]
traces EL
el }
                | Bool
otherwise  = EL
el
  where
    prop :: Trace -> Bool
prop = [Text] -> [Text] -> Trace -> Bool
filterTrace (Args -> [Text]
includeStr Args
a) (Args -> [Text]
excludeStr Args
a)

addFrame :: Word64 -> EL -> EL
addFrame :: Word64 -> EL -> EL
addFrame Word64
t EL
el =
  EL
el { samples :: Maybe FrameEL
samples = forall a. a -> Maybe a
Just (Word64 -> [Sample] -> FrameEL
FrameEL Word64
t [])
     , frames :: [FrameEL]
frames = Maybe FrameEL -> [FrameEL] -> [FrameEL]
sampleToFrames (EL -> Maybe FrameEL
samples EL
el) (EL -> [FrameEL]
frames EL
el) }

sampleToFrames :: Maybe FrameEL -> [FrameEL]
                                -> [FrameEL]
sampleToFrames :: Maybe FrameEL -> [FrameEL] -> [FrameEL]
sampleToFrames (Just (FrameEL Word64
t [Sample]
ss)) [FrameEL]
fs = Word64 -> [Sample] -> FrameEL
FrameEL Word64
t (forall a. [a] -> [a]
reverse [Sample]
ss) forall a. a -> [a] -> [a]
: [FrameEL]
fs
sampleToFrames Maybe FrameEL
Nothing [FrameEL]
fs = [FrameEL]
fs

addSample :: Sample -> EL -> EL
addSample :: Sample -> EL -> EL
addSample Sample
s EL
el = EL
el { samples :: Maybe FrameEL
samples = FrameEL -> FrameEL
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EL -> Maybe FrameEL
samples EL
el) }
  where
    go :: FrameEL -> FrameEL
go (FrameEL Word64
t [Sample]
ss) = Word64 -> [Sample] -> FrameEL
FrameEL Word64
t (Sample
sforall a. a -> [a] -> [a]
:[Sample]
ss)

updateLast :: Word64 -> EL -> EL
updateLast :: Word64 -> EL -> EL
updateLast Word64
t EL
el = EL
el { end :: Word64
end = Word64
t }

formatDate :: Word64 -> T.Text
formatDate :: Word64 -> Text
formatDate Word64
sec =
  let posixTime :: POSIXTime
      posixTime :: POSIXTime
posixTime = forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
sec
  in
    [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y-%m-%d, %H:%M %Z" (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
posixTime)

elHeader :: EL -> PartialHeader
elHeader :: EL -> PartialHeader
elHeader EL{[(InfoTablePtr, InfoTableLoc)]
[TickySample]
[TickyCounter]
[Trace]
[HeapSample]
[FrameEL]
Maybe [Char]
Maybe [Text]
Maybe Word64
Maybe (Version, Text)
Maybe HeapProfBreakdown
Maybe FrameEL
Word64
Map Word32 Word64
Map Word32 CostCentre
BucketMap
CCSMap
total_allocs :: Map Word32 Word64
end :: Word64
start :: Word64
ticky_counter :: [TickyCounter]
ticky_samples :: [TickySample]
ipes :: [(InfoTablePtr, InfoTableLoc)]
traces :: [Trace]
frames :: [FrameEL]
samples :: Maybe FrameEL
clocktimeSec :: Word64
ccsMap :: CCSMap
bucketMap :: BucketMap
ccMap :: Map Word32 CostCentre
heapProfileType :: Maybe HeapProfBreakdown
samplingRate :: Maybe Word64
ident :: Maybe (Version, Text)
blocksSize :: [HeapSample]
liveBytes :: [HeapSample]
heapSize :: [HeapSample]
programInvocation :: Maybe [Char]
pargs :: Maybe [Text]
total_allocs :: EL -> Map Word32 Word64
end :: EL -> Word64
start :: EL -> Word64
ticky_counter :: EL -> [TickyCounter]
ticky_samples :: EL -> [TickySample]
ipes :: EL -> [(InfoTablePtr, InfoTableLoc)]
traces :: EL -> [Trace]
frames :: EL -> [FrameEL]
samples :: EL -> Maybe FrameEL
clocktimeSec :: EL -> Word64
ccsMap :: EL -> CCSMap
bucketMap :: EL -> BucketMap
ccMap :: EL -> Map Word32 CostCentre
heapProfileType :: EL -> Maybe HeapProfBreakdown
samplingRate :: EL -> Maybe Word64
blocksSize :: EL -> [HeapSample]
liveBytes :: EL -> [HeapSample]
heapSize :: EL -> [HeapSample]
programInvocation :: EL -> Maybe [Char]
pargs :: EL -> Maybe [Text]
ident :: EL -> Maybe (Version, Text)
..} =
  let title :: Text
title = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" [Text] -> Text
T.unwords Maybe [Text]
pargs
      date :: Text
date = Word64 -> Text
formatDate Word64
clocktimeSec
      ppSamplingRate :: Text
ppSamplingRate = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"<Not available>" (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
fromNano) forall a b. (a -> b) -> a -> b
$ Maybe Word64
samplingRate
  in \Int
v -> Text
-> Text
-> Maybe HeapProfBreakdown
-> Text
-> Text
-> Text
-> Int
-> Maybe [Char]
-> Header
Header Text
title Text
date Maybe HeapProfBreakdown
heapProfileType Text
ppSamplingRate Text
"" Text
"" Int
v (Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Text]
pargs)


elBucketMap :: EL -> BucketMap
elBucketMap :: EL -> BucketMap
elBucketMap = EL -> BucketMap
bucketMap