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

import GHC.RTS.Events hiding (Header, header)
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
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 GHC.Exts.Heap.ClosureTypes

type PartialHeader = Int -> Header

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


chunk :: Args -> FilePath -> IO ProfData
chunk :: Args -> FilePath -> IO ProfData
chunk Args
a FilePath
f = do
  (EventLog Header
_ Data
e) <- (FilePath -> EventLog)
-> (EventLog -> EventLog) -> Either FilePath EventLog -> EventLog
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> EventLog
forall a. HasCallStack => FilePath -> a
error EventLog -> EventLog
forall a. a -> a
id (Either FilePath EventLog -> EventLog)
-> IO (Either FilePath EventLog) -> IO EventLog
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Either FilePath EventLog)
readEventLogFromFile FilePath
f
  (PartialHeader
ph, BucketMap
bucket_map, Map Word32 CostCentre
ccMap, [Frame]
frames, [Trace]
traces, Map InfoTablePtr InfoTableLoc
ipes) <- Args
-> Data
-> IO
     (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame], [Trace],
      Map InfoTablePtr InfoTableLoc)
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 = (k
 -> (Text, Maybe [Word32])
 -> (Double, Double, Maybe (Double, Double, Double))
 -> Identity BucketInfo)
-> WhenMatched
     Identity
     k
     (Text, Maybe [Word32])
     (Double, Double, Maybe (Double, Double, Double))
     BucketInfo
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) -> BucketInfo -> Identity BucketInfo
forall a. a -> Identity a
Identity (BucketInfo -> Identity BucketInfo)
-> BucketInfo -> Identity BucketInfo
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 = FilePath -> (Text, Maybe [Word32]) -> Identity BucketInfo
forall a. HasCallStack => FilePath -> a
error (FilePath
"Missing total for: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Bucket -> FilePath
forall a. Show a => a -> FilePath
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) = BucketInfo -> Identity BucketInfo
forall a. a -> Identity a
Identity (Text
-> Maybe [Word32]
-> Double
-> Double
-> Maybe (Double, Double, Double)
-> BucketInfo
BucketInfo Text
t Maybe [Word32]
forall a. Maybe a
Nothing Double
tot Double
sd Maybe (Double, Double, Double)
g)

      binfo :: Map Bucket BucketInfo
binfo = SimpleWhenMissing Bucket (Text, Maybe [Word32]) BucketInfo
-> SimpleWhenMissing
     Bucket (Double, Double, Maybe (Double, Double, Double)) BucketInfo
-> SimpleWhenMatched
     Bucket
     (Text, Maybe [Word32])
     (Double, Double, Maybe (Double, Double, Double))
     BucketInfo
-> BucketMap
-> Map Bucket (Double, Double, Maybe (Double, Double, Double))
-> Map Bucket BucketInfo
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 ((Bucket -> (Text, Maybe [Word32]) -> Identity BucketInfo)
-> SimpleWhenMissing Bucket (Text, Maybe [Word32]) BucketInfo
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
traverseMissing Bucket -> (Text, Maybe [Word32]) -> Identity BucketInfo
combineMissingTotal) ((Bucket
 -> (Double, Double, Maybe (Double, Double, Double))
 -> Identity BucketInfo)
-> SimpleWhenMissing
     Bucket (Double, Double, Maybe (Double, Double, Double)) BucketInfo
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) SimpleWhenMatched
  Bucket
  (Text, Maybe [Word32])
  (Double, Double, Maybe (Double, Double, Double))
  BucketInfo
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
  ProfData -> IO ProfData
forall (m :: * -> *) a. Monad m => a -> m a
return (ProfData -> IO ProfData) -> ProfData -> IO ProfData
forall a b. (a -> b) -> a -> b
$ (Header
-> Map Bucket BucketInfo
-> Map Word32 CostCentre
-> [Frame]
-> [Trace]
-> Map InfoTablePtr InfoTableLoc
-> ProfData
ProfData (PartialHeader
ph Int
counts) Map Bucket BucketInfo
binfo Map Word32 CostCentre
ccMap [Frame]
frames [Trace]
traces Map InfoTablePtr InfoTableLoc
ipes)

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

eventsToHP :: Args -> Data -> IO (PartialHeader, BucketMap, Map.Map Word32 CostCentre, [Frame], [Trace], Map.Map InfoTablePtr InfoTableLoc)
eventsToHP :: Args
-> Data
-> IO
     (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame], [Trace],
      Map InfoTablePtr InfoTableLoc)
eventsToHP Args
a (Data [Event]
es) = do
  let
      el :: EL
el@EL{[(InfoTablePtr, InfoTableLoc)]
[Trace]
[FrameEL]
Maybe FilePath
Maybe [Text]
Maybe Word64
Maybe (Version, Text)
Maybe HeapProfBreakdown
Maybe FrameEL
Word64
Map Word32 CostCentre
BucketMap
CCSMap
end :: EL -> Word64
start :: EL -> Word64
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
programInvocation :: EL -> Maybe FilePath
end :: Word64
start :: Word64
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)
programInvocation :: Maybe FilePath
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) []
  (Text -> IO ()) -> Maybe Text -> IO ()
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)
  (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame], [Trace],
 Map InfoTablePtr InfoTableLoc)
-> IO
     (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame], [Trace],
      Map InfoTablePtr InfoTableLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PartialHeader, BucketMap, Map Word32 CostCentre, [Frame],
  [Trace], Map InfoTablePtr InfoTableLoc)
 -> IO
      (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame], [Trace],
       Map InfoTablePtr InfoTableLoc))
-> (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame],
    [Trace], Map InfoTablePtr InfoTableLoc)
-> IO
     (PartialHeader, BucketMap, Map Word32 CostCentre, [Frame], [Trace],
      Map InfoTablePtr InfoTableLoc)
forall a b. (a -> b) -> a -> b
$ (EL -> PartialHeader
elHeader EL
el, EL -> BucketMap
elBucketMap EL
el, Map Word32 CostCentre
ccMap, Frame
fir Frame -> [Frame] -> [Frame]
forall a. a -> [a] -> [a]
: [Frame] -> [Frame]
forall a. [a] -> [a]
reverse (Frame
lasFrame -> [Frame] -> [Frame]
forall a. a -> [a] -> [a]
: [FrameEL] -> [Frame]
normalise [FrameEL]
frames) , [Trace]
traces, [(InfoTablePtr, InfoTableLoc)] -> Map InfoTablePtr InfoTableLoc
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(InfoTablePtr, InfoTableLoc)]
ipes)

normalise :: [FrameEL] -> [Frame]
normalise :: [FrameEL] -> [Frame]
normalise = (FrameEL -> Frame) -> [FrameEL] -> [Frame]
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 FilePath
programInvocation :: !(Maybe FilePath)
  , 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 -> Word64
start :: !Word64
  , EL -> Word64
end :: !Word64 } deriving Int -> EL -> FilePath -> FilePath
[EL] -> FilePath -> FilePath
EL -> FilePath
(Int -> EL -> FilePath -> FilePath)
-> (EL -> FilePath) -> ([EL] -> FilePath -> FilePath) -> Show EL
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [EL] -> FilePath -> FilePath
$cshowList :: [EL] -> FilePath -> FilePath
show :: EL -> FilePath
$cshow :: EL -> FilePath
showsPrec :: Int -> EL -> FilePath -> FilePath
$cshowsPrec :: Int -> EL -> FilePath -> FilePath
Show


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

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


data CCStack = CCStack { CCStack -> Int
ccsId :: Int, CCStack -> Text
ccsName :: Text } deriving Int -> CCStack -> FilePath -> FilePath
[CCStack] -> FilePath -> FilePath
CCStack -> FilePath
(Int -> CCStack -> FilePath -> FilePath)
-> (CCStack -> FilePath)
-> ([CCStack] -> FilePath -> FilePath)
-> Show CCStack
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [CCStack] -> FilePath -> FilePath
$cshowList :: [CCStack] -> FilePath -> FilePath
show :: CCStack -> FilePath
$cshow :: CCStack -> FilePath
showsPrec :: Int -> CCStack -> FilePath -> FilePath
$cshowsPrec :: Int -> CCStack -> FilePath -> FilePath
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 = [Word32] -> [Word32]
forall a. [a] -> [a]
reverse ([Word32] -> [Word32]) -> [Word32] -> [Word32]
forall a b. (a -> b) -> a -> b
$ Vector Word32 -> [Word32]
forall a. Unbox a => Vector a -> [a]
toList Vector Word32
k
  in case [Word32] -> TMap Word32 CCStack -> Maybe CCStack
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 = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"(" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
uniq FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
") "
              short_bucket_info :: Text
short_bucket_info = Text
sid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
              bucket_info :: (Text, Maybe [Word32])
bucket_info = (Text
short_bucket_info, [Word32] -> Maybe [Word32]
forall a. a -> Maybe a
Just [Word32]
kl)
              bucket_key :: Bucket
bucket_key = Text -> Bucket
Bucket (FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
uniq))
          in (CCStack
new_stack, EL
el { ccsMap :: CCSMap
ccsMap = TMap Word32 CCStack -> Int -> CCSMap
CCSMap ([Word32] -> CCStack -> TMap Word32 CCStack -> TMap Word32 CCStack
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                            , bucketMap :: BucketMap
bucketMap = Bucket -> (Text, Maybe [Word32]) -> 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 = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"MAIN" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ do
             Word32
cid <- (Vector Word32
k Vector Word32 -> Int -> Maybe Word32
forall a. Unbox a => Vector a -> Int -> Maybe a
!? Int
0)
             CC{Text
label :: CostCentre -> Text
label :: Text
label} <- Word32 -> Map Word32 CostCentre -> Maybe CostCentre
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word32
cid Map Word32 CostCentre
ccMap
             Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
label


initEL :: EL
initEL :: EL
initEL = EL :: Maybe [Text]
-> Maybe FilePath
-> Maybe (Version, Text)
-> Maybe Word64
-> Maybe HeapProfBreakdown
-> Map Word32 CostCentre
-> BucketMap
-> CCSMap
-> Word64
-> Maybe FrameEL
-> [FrameEL]
-> [Trace]
-> [(InfoTablePtr, InfoTableLoc)]
-> Word64
-> Word64
-> EL
EL
  { pargs :: Maybe [Text]
pargs = Maybe [Text]
forall a. Maybe a
Nothing
  , ident :: Maybe (Version, Text)
ident = Maybe (Version, Text)
forall a. Maybe a
Nothing
  , samplingRate :: Maybe Word64
samplingRate = Maybe Word64
forall a. Maybe a
Nothing
  , heapProfileType :: Maybe HeapProfBreakdown
heapProfileType = Maybe HeapProfBreakdown
forall a. Maybe a
Nothing
  , clocktimeSec :: Word64
clocktimeSec = Word64
0
  , samples :: Maybe FrameEL
samples = Maybe FrameEL
forall a. Maybe a
Nothing
  , 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 = Map Word32 CostCentre
forall k a. Map k a
Map.empty
  , ccsMap :: CCSMap
ccsMap =  TMap Word32 CCStack -> Int -> CCSMap
CCSMap TMap Word32 CCStack
forall c a. TMap c a
Trie.empty Int
0
  , bucketMap :: BucketMap
bucketMap = BucketMap
forall k a. Map k a
Map.empty
  , programInvocation :: Maybe FilePath
programInvocation = Maybe FilePath
forall a. Maybe a
Nothing
  }

foldEvents :: Args -> [Event] -> EL
foldEvents :: Args -> [Event] -> EL
foldEvents Args
a [Event]
es =
  let res :: EL
res = (EL -> Event -> EL) -> EL -> [Event] -> EL
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 EL -> (EL -> EL) -> EL
forall a b. a -> (a -> b) -> b
&
  Word64 -> EL -> EL
updateLast Word64
t (EL -> EL) -> (EL -> EL) -> EL -> EL
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 EL -> EL
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 EL -> EL
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 FilePath
inv -> FilePath -> EL -> EL
addInvocation FilePath
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 Word64 -> Word64 -> Bool
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) (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
res))
      --IPE ptr name desc ty lbl smod sloc -> addInfoTableLoc (InfoTablePtr ptr,
      --                                        InfoTableLoc name (parseClosureType desc) ty lbl smod sloc)
      EventInfo
_ -> EL -> EL
forall a. a -> a
id

_parseClosureType :: Text -> ClosureType
-- IPEs do not distinguish different CONSTR types, yet
_parseClosureType :: Text -> ClosureType
_parseClosureType Text
"0" = ClosureType
CONSTR
_parseClosureType Text
ct = Int -> ClosureType
forall a. Enum a => Int -> a
toEnum (Int -> ClosureType) -> (Text -> Int) -> Text -> ClosureType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Read Int => FilePath -> Int
forall a. Read a => FilePath -> a
read @Int (FilePath -> Int) -> (Text -> FilePath) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> ClosureType) -> Text -> ClosureType
forall a b. (a -> b) -> a -> b
$ Text
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 (InfoTablePtr, InfoTableLoc)
-> [(InfoTablePtr, InfoTableLoc)] -> [(InfoTablePtr, InfoTableLoc)]
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 = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
sr, heapProfileType :: Maybe HeapProfBreakdown
heapProfileType = HeapProfBreakdown -> Maybe HeapProfBreakdown
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 = (FilePath -> Text) -> (Version, FilePath) -> (Version, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
T.pack ((Version, FilePath) -> (Version, Text))
-> Maybe (Version, FilePath) -> Maybe (Version, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> Maybe (Version, FilePath)
parseIdent (Text -> FilePath
T.unpack Text
s)) }

parseIdent :: String -> Maybe (Version, String)
parseIdent :: FilePath -> Maybe (Version, FilePath)
parseIdent FilePath
s = [(Version, FilePath)] -> Maybe (Version, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Version, FilePath)] -> Maybe (Version, FilePath))
-> [(Version, FilePath)] -> Maybe (Version, FilePath)
forall a b. (a -> b) -> a -> b
$ (ReadP Version -> FilePath -> [(Version, FilePath)])
-> FilePath -> ReadP Version -> [(Version, FilePath)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReadP Version -> FilePath -> [(Version, FilePath)]
forall a. ReadP a -> ReadS a
readP_to_S FilePath
s (ReadP Version -> [(Version, FilePath)])
-> ReadP Version -> [(Version, FilePath)]
forall a b. (a -> b) -> a -> b
$ do
  ReadP FilePath -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP FilePath -> ReadP ()) -> ReadP FilePath -> ReadP ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ReadP FilePath
string FilePath
"GHC-"
  [Int
v1, Int
v2, Int
v3] <- Int -> ReadP Int -> ReadP [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 (ReadP Int
intP ReadP Int -> ReadP () -> ReadP Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP Char -> ReadP ()
forall a. ReadP a -> ReadP ()
optional (Char -> ReadP Char
char Char
'.'))
  ReadP ()
skipSpaces
  Version -> ReadP Version
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> Version
makeVersion [Int
v1,Int
v2,Int
v3])
  where
    intP :: ReadP Int
intP = do
      FilePath
x <- (Char -> Bool) -> ReadP FilePath
munch1 Char -> Bool
isDigit
      Int -> ReadP Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ReadP Int) -> Int -> ReadP Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
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 = Word32
-> CostCentre -> Map Word32 CostCentre -> Map Word32 CostCentre
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 = FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
stack_id)
  in Sample -> EL -> EL
addSample (Bucket -> Double -> Sample
Sample (Text -> Bucket
Bucket Text
sample_string) (Word64 -> Double
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 = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
as }

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


-- | 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 ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text -> Text -> Bool) -> Text -> Text -> Bool
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) =
  (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text -> Text -> Bool) -> Text -> Text -> Bool
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) =
  (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text -> Text -> Bool) -> Text -> Text -> Bool
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 ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text -> Text -> Bool) -> Text -> Text -> Bool
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 Trace -> [Trace] -> [Trace]
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 = FrameEL -> Maybe FrameEL
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 ([Sample] -> [Sample]
forall a. [a] -> [a]
reverse [Sample]
ss) FrameEL -> [FrameEL] -> [FrameEL]
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 (FrameEL -> FrameEL) -> Maybe FrameEL -> Maybe FrameEL
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
sSample -> [Sample] -> [Sample]
forall 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 = Word64 -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
sec
  in
    FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%Y-%m-%d, %H:%M %Z" (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
posixTime)

elHeader :: EL -> PartialHeader
elHeader :: EL -> PartialHeader
elHeader EL{[(InfoTablePtr, InfoTableLoc)]
[Trace]
[FrameEL]
Maybe FilePath
Maybe [Text]
Maybe Word64
Maybe (Version, Text)
Maybe HeapProfBreakdown
Maybe FrameEL
Word64
Map Word32 CostCentre
BucketMap
CCSMap
end :: Word64
start :: Word64
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)
programInvocation :: Maybe FilePath
pargs :: Maybe [Text]
end :: EL -> Word64
start :: EL -> Word64
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
programInvocation :: EL -> Maybe FilePath
pargs :: EL -> Maybe [Text]
ident :: EL -> Maybe (Version, Text)
..} =
  let title :: Text
title = Text -> ([Text] -> Text) -> Maybe [Text] -> Text
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 = FilePath -> Text
T.pack (FilePath -> Text)
-> (Maybe Word64 -> FilePath) -> Maybe Word64 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (Word64 -> FilePath) -> Maybe Word64 -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"<Not available>" (Double -> FilePath
forall a. Show a => a -> FilePath
show (Double -> FilePath) -> (Word64 -> Double) -> Word64 -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
fromNano) (Maybe Word64 -> Text) -> Maybe Word64 -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Word64
samplingRate
  in \Int
v -> Text
-> Text
-> Maybe HeapProfBreakdown
-> Text
-> Text
-> Text
-> Int
-> Maybe FilePath
-> Header
Header Text
title Text
date Maybe HeapProfBreakdown
heapProfileType Text
ppSamplingRate Text
"" Text
"" Int
v (Text -> FilePath
T.unpack (Text -> FilePath) -> ([Text] -> Text) -> [Text] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. [a] -> a
head ([Text] -> FilePath) -> Maybe [Text] -> Maybe FilePath
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