-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE file.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}

-- |
-- Types and operations for statistics and profiling.  Most users
-- should import "Haxl.Core" instead of importing this module
-- directly.
--
module Haxl.Core.Stats
  (
  -- * Data-source stats
    Stats(..)
  , CallId
  , FetchStats(..)
  , Microseconds
  , Timestamp
  , DataSourceStats(..)
  , getTimestamp
  , emptyStats
  , numFetches
  , ppStats
  , ppFetchStats
  , aggregateFetchBatches

  -- * Profiling
  , Profile(..)
  , ProfileMemo(..)
  , ProfileFetch(..)
  , emptyProfile
  , ProfileKey
  , ProfileLabel
  , ProfileData(..)
  , emptyProfileData
  , AllocCount
  , LabelHitCount

  -- * Allocation
  , getAllocationCounter
  , setAllocationCounter
  ) where

import Data.Aeson
import Data.Function (on)
import Data.Maybe (mapMaybe)
import Data.HashMap.Strict (HashMap)
import Data.Int
import Data.List (intercalate, sortOn, groupBy)
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup (Semigroup)
#endif
import Data.Ord (Down(..))
import Data.Text (Text)
import Data.Time.Clock.POSIX
import Data.Typeable
import Text.Printf
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text

import GHC.Conc (getAllocationCounter, setAllocationCounter)

-- ---------------------------------------------------------------------------
-- Measuring time

type Microseconds = Int64
type Timestamp = Microseconds -- since an epoch

getTimestamp :: IO Timestamp
getTimestamp :: IO Timestamp
getTimestamp = do
  POSIXTime
t <- IO POSIXTime
getPOSIXTime -- for now, TODO better
  Timestamp -> IO Timestamp
forall (m :: * -> *) a. Monad m => a -> m a
return (POSIXTime -> Timestamp
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime
t POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000000))

-- ---------------------------------------------------------------------------
-- Stats

data DataSourceStats =
  forall a. (Typeable a, Show a, Eq a, ToJSON a) => DataSourceStats a

instance Show DataSourceStats where
  show :: DataSourceStats -> String
show (DataSourceStats a
x) = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"DataSourceStats %s" (a -> String
forall a. Show a => a -> String
show a
x)

instance Eq DataSourceStats where
  == :: DataSourceStats -> DataSourceStats -> Bool
(==) (DataSourceStats a
a) (DataSourceStats a
b) =
    a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Maybe a
forall a. a -> Maybe a
Just a
b

-- | Stats that we collect along the way.
newtype Stats = Stats [FetchStats]
  deriving (Int -> Stats -> ShowS
[Stats] -> ShowS
Stats -> String
(Int -> Stats -> ShowS)
-> (Stats -> String) -> ([Stats] -> ShowS) -> Show Stats
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stats] -> ShowS
$cshowList :: [Stats] -> ShowS
show :: Stats -> String
$cshow :: Stats -> String
showsPrec :: Int -> Stats -> ShowS
$cshowsPrec :: Int -> Stats -> ShowS
Show, [Stats] -> Encoding
[Stats] -> Value
Stats -> Encoding
Stats -> Value
(Stats -> Value)
-> (Stats -> Encoding)
-> ([Stats] -> Value)
-> ([Stats] -> Encoding)
-> ToJSON Stats
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Stats] -> Encoding
$ctoEncodingList :: [Stats] -> Encoding
toJSONList :: [Stats] -> Value
$ctoJSONList :: [Stats] -> Value
toEncoding :: Stats -> Encoding
$ctoEncoding :: Stats -> Encoding
toJSON :: Stats -> Value
$ctoJSON :: Stats -> Value
ToJSON, b -> Stats -> Stats
NonEmpty Stats -> Stats
Stats -> Stats -> Stats
(Stats -> Stats -> Stats)
-> (NonEmpty Stats -> Stats)
-> (forall b. Integral b => b -> Stats -> Stats)
-> Semigroup Stats
forall b. Integral b => b -> Stats -> Stats
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Stats -> Stats
$cstimes :: forall b. Integral b => b -> Stats -> Stats
sconcat :: NonEmpty Stats -> Stats
$csconcat :: NonEmpty Stats -> Stats
<> :: Stats -> Stats -> Stats
$c<> :: Stats -> Stats -> Stats
Semigroup, Semigroup Stats
Stats
Semigroup Stats
-> Stats
-> (Stats -> Stats -> Stats)
-> ([Stats] -> Stats)
-> Monoid Stats
[Stats] -> Stats
Stats -> Stats -> Stats
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Stats] -> Stats
$cmconcat :: [Stats] -> Stats
mappend :: Stats -> Stats -> Stats
$cmappend :: Stats -> Stats -> Stats
mempty :: Stats
$cmempty :: Stats
$cp1Monoid :: Semigroup Stats
Monoid)

-- | Pretty-print Stats.
ppStats :: Stats -> String
ppStats :: Stats -> String
ppStats (Stats [FetchStats]
rss) =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
    [ String
"["
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ [
      if FetchStats -> Timestamp -> Timestamp -> Bool
fetchWasRunning FetchStats
rs
          (Timestamp
minStartTime Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+ (Timestamp
t Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
- Timestamp
1) Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
* Timestamp
usPerDash)
          (Timestamp
minStartTime Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+ Timestamp
t Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
* Timestamp
usPerDash)
        then FetchStats -> Char
fetchSymbol FetchStats
rs
        else Char
'-'
      | Timestamp
t <- [Timestamp
1..Timestamp
numDashes]
      ]
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FetchStats -> String
ppFetchStats FetchStats
rs
    | (Int
i, FetchStats
rs) <- [Int] -> [FetchStats] -> [(Int, FetchStats)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1::Int)..] [FetchStats]
validFetchStats ]
  where
    isFetchStats :: FetchStats -> Bool
isFetchStats FetchStats{} = Bool
True
    isFetchStats FetchWait{} = Bool
True
    isFetchStats FetchDataSourceStats{} = Bool
True
    isFetchStats FetchStats
_ = Bool
False
    validFetchStats :: [FetchStats]
validFetchStats = (FetchStats -> Bool) -> [FetchStats] -> [FetchStats]
forall a. (a -> Bool) -> [a] -> [a]
filter FetchStats -> Bool
isFetchStats ([FetchStats] -> [FetchStats]
forall a. [a] -> [a]
reverse [FetchStats]
rss)
    numDashes :: Timestamp
numDashes = Timestamp
50
    getStart :: FetchStats -> Maybe Timestamp
getStart FetchStats{Int
Timestamp
[Int]
Text
fetchIds :: FetchStats -> [Int]
fetchBatchId :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchFailures :: FetchStats -> Int
fetchSpace :: FetchStats -> Timestamp
fetchDuration :: FetchStats -> Timestamp
fetchStart :: FetchStats -> Timestamp
fetchBatchSize :: FetchStats -> Int
fetchDataSource :: FetchStats -> Text
fetchIds :: [Int]
fetchBatchId :: Int
fetchIgnoredFailures :: Int
fetchFailures :: Int
fetchSpace :: Timestamp
fetchDuration :: Timestamp
fetchStart :: Timestamp
fetchBatchSize :: Int
fetchDataSource :: Text
..} = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just Timestamp
fetchStart
    getStart FetchWait{Timestamp
HashMap Text Int
fetchWaitDuration :: FetchStats -> Timestamp
fetchWaitStart :: FetchStats -> Timestamp
fetchWaitReqs :: FetchStats -> HashMap Text Int
fetchWaitDuration :: Timestamp
fetchWaitStart :: Timestamp
fetchWaitReqs :: HashMap Text Int
..} = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just Timestamp
fetchWaitStart
    getStart FetchStats
_ = Maybe Timestamp
forall a. Maybe a
Nothing
    getEnd :: FetchStats -> Maybe Timestamp
getEnd FetchStats{Int
Timestamp
[Int]
Text
fetchIds :: [Int]
fetchBatchId :: Int
fetchIgnoredFailures :: Int
fetchFailures :: Int
fetchSpace :: Timestamp
fetchDuration :: Timestamp
fetchStart :: Timestamp
fetchBatchSize :: Int
fetchDataSource :: Text
fetchIds :: FetchStats -> [Int]
fetchBatchId :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchFailures :: FetchStats -> Int
fetchSpace :: FetchStats -> Timestamp
fetchDuration :: FetchStats -> Timestamp
fetchStart :: FetchStats -> Timestamp
fetchBatchSize :: FetchStats -> Int
fetchDataSource :: FetchStats -> Text
..} = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just (Timestamp -> Maybe Timestamp) -> Timestamp -> Maybe Timestamp
forall a b. (a -> b) -> a -> b
$ Timestamp
fetchStart Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+ Timestamp
fetchDuration
    getEnd FetchWait{Timestamp
HashMap Text Int
fetchWaitDuration :: Timestamp
fetchWaitStart :: Timestamp
fetchWaitReqs :: HashMap Text Int
fetchWaitDuration :: FetchStats -> Timestamp
fetchWaitStart :: FetchStats -> Timestamp
fetchWaitReqs :: FetchStats -> HashMap Text Int
..} = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just (Timestamp -> Maybe Timestamp) -> Timestamp -> Maybe Timestamp
forall a b. (a -> b) -> a -> b
$ Timestamp
fetchWaitStart Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+ Timestamp
fetchWaitDuration
    getEnd FetchStats
_ = Maybe Timestamp
forall a. Maybe a
Nothing
    minStartTime :: Timestamp
minStartTime = [Timestamp] -> Timestamp
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Timestamp] -> Timestamp) -> [Timestamp] -> Timestamp
forall a b. (a -> b) -> a -> b
$ (FetchStats -> Maybe Timestamp) -> [FetchStats] -> [Timestamp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FetchStats -> Maybe Timestamp
getStart [FetchStats]
validFetchStats
    endTime :: Timestamp
endTime = [Timestamp] -> Timestamp
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Timestamp] -> Timestamp) -> [Timestamp] -> Timestamp
forall a b. (a -> b) -> a -> b
$ (FetchStats -> Maybe Timestamp) -> [FetchStats] -> [Timestamp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FetchStats -> Maybe Timestamp
getEnd [FetchStats]
validFetchStats
    usPerDash :: Timestamp
usPerDash = (Timestamp
endTime Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
- Timestamp
minStartTime) Timestamp -> Timestamp -> Timestamp
forall a. Integral a => a -> a -> a
`div` Timestamp
numDashes
    fetchSymbol :: FetchStats -> Char
fetchSymbol FetchStats{} = Char
'*'
    fetchSymbol FetchWait{} = Char
'.'
    fetchSymbol FetchStats
_ = Char
'?'
    fetchWasRunning :: FetchStats -> Timestamp -> Timestamp -> Bool
    fetchWasRunning :: FetchStats -> Timestamp -> Timestamp -> Bool
fetchWasRunning fs :: FetchStats
fs@FetchStats{} Timestamp
t1 Timestamp
t2 =
      (FetchStats -> Timestamp
fetchStart FetchStats
fs Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+ FetchStats -> Timestamp
fetchDuration FetchStats
fs) Timestamp -> Timestamp -> Bool
forall a. Ord a => a -> a -> Bool
>= Timestamp
t1 Bool -> Bool -> Bool
&& FetchStats -> Timestamp
fetchStart FetchStats
fs Timestamp -> Timestamp -> Bool
forall a. Ord a => a -> a -> Bool
< Timestamp
t2
    fetchWasRunning fw :: FetchStats
fw@FetchWait{} Timestamp
t1 Timestamp
t2 =
      (FetchStats -> Timestamp
fetchWaitStart FetchStats
fw Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+ FetchStats -> Timestamp
fetchWaitDuration FetchStats
fw) Timestamp -> Timestamp -> Bool
forall a. Ord a => a -> a -> Bool
>= Timestamp
t1 Bool -> Bool -> Bool
&& FetchStats -> Timestamp
fetchWaitStart FetchStats
fw Timestamp -> Timestamp -> Bool
forall a. Ord a => a -> a -> Bool
< Timestamp
t2
    fetchWasRunning FetchStats
_ Timestamp
_ Timestamp
_ = Bool
False

type CallId = Int

-- | Maps data source name to the number of requests made in that round.
-- The map only contains entries for sources that made requests in that
-- round.
data FetchStats
    -- | Timing stats for a (batched) data fetch
  = FetchStats
    { FetchStats -> Text
fetchDataSource :: Text
    , FetchStats -> Int
fetchBatchSize :: {-# UNPACK #-} !Int
    , FetchStats -> Timestamp
fetchStart :: {-# UNPACK #-} !Timestamp
    , FetchStats -> Timestamp
fetchDuration :: {-# UNPACK #-} !Microseconds
    , FetchStats -> Timestamp
fetchSpace :: {-# UNPACK #-} !Int64
    , FetchStats -> Int
fetchFailures :: {-# UNPACK #-} !Int
    , FetchStats -> Int
fetchIgnoredFailures :: {-# UNPACK #-} !Int
    , FetchStats -> Int
fetchBatchId :: {-# UNPACK #-} !Int
    , FetchStats -> [Int]
fetchIds :: [CallId]
    }

    -- | The stack trace of a call to 'dataFetch'.  These are collected
    -- only when profiling and reportLevel is 5 or greater.
  | FetchCall
    { FetchStats -> String
fetchReq :: String
    , FetchStats -> [String]
fetchStack :: [String]
    , FetchStats -> Int
fetchStatId :: {-# UNPACK #-} !CallId
    }
  | MemoCall
    { FetchStats -> Int
memoStatId :: {-# UNPACK #-} !CallId
    , FetchStats -> Timestamp
memoSpace :: {-# UNPACK #-} !Int64
    }
  | FetchWait
    { FetchStats -> HashMap Text Int
fetchWaitReqs :: HashMap Text Int
       -- ^ What DataSources had requests that were being waited for
    , FetchStats -> Timestamp
fetchWaitStart :: {-# UNPACK #-} !Timestamp
    , FetchStats -> Timestamp
fetchWaitDuration :: {-# UNPACK #-} !Microseconds
    }
  | FetchDataSourceStats
    { FetchStats -> Int
fetchDsStatsCallId :: CallId
    , FetchStats -> Text
fetchDsStatsDataSource :: Text
    , FetchStats -> DataSourceStats
fetchDsStatsStats :: DataSourceStats
    , fetchBatchId :: {-# UNPACK #-} !Int
    }
  deriving (FetchStats -> FetchStats -> Bool
(FetchStats -> FetchStats -> Bool)
-> (FetchStats -> FetchStats -> Bool) -> Eq FetchStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FetchStats -> FetchStats -> Bool
$c/= :: FetchStats -> FetchStats -> Bool
== :: FetchStats -> FetchStats -> Bool
$c== :: FetchStats -> FetchStats -> Bool
Eq, Int -> FetchStats -> ShowS
[FetchStats] -> ShowS
FetchStats -> String
(Int -> FetchStats -> ShowS)
-> (FetchStats -> String)
-> ([FetchStats] -> ShowS)
-> Show FetchStats
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FetchStats] -> ShowS
$cshowList :: [FetchStats] -> ShowS
show :: FetchStats -> String
$cshow :: FetchStats -> String
showsPrec :: Int -> FetchStats -> ShowS
$cshowsPrec :: Int -> FetchStats -> ShowS
Show)

-- | Pretty-print RoundStats.
ppFetchStats :: FetchStats -> String
ppFetchStats :: FetchStats -> String
ppFetchStats FetchStats{Int
Timestamp
[Int]
Text
fetchIds :: [Int]
fetchBatchId :: Int
fetchIgnoredFailures :: Int
fetchFailures :: Int
fetchSpace :: Timestamp
fetchDuration :: Timestamp
fetchStart :: Timestamp
fetchBatchSize :: Int
fetchDataSource :: Text
fetchIds :: FetchStats -> [Int]
fetchBatchId :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchFailures :: FetchStats -> Int
fetchSpace :: FetchStats -> Timestamp
fetchDuration :: FetchStats -> Timestamp
fetchStart :: FetchStats -> Timestamp
fetchBatchSize :: FetchStats -> Int
fetchDataSource :: FetchStats -> Text
..} =
  String -> String -> Int -> Double -> Timestamp -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%s: %d fetches (%.2fms, %d bytes, %d failures)"
    (Text -> String
Text.unpack Text
fetchDataSource) Int
fetchBatchSize
    (Timestamp -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Timestamp
fetchDuration Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000 :: Double)  Timestamp
fetchSpace Int
fetchFailures
ppFetchStats (FetchCall String
r [String]
ss Int
_) = ShowS
forall a. Show a => a -> String
show String
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:[String] -> String
forall a. Show a => a -> String
show [String]
ss
ppFetchStats MemoCall{} = String
""
ppFetchStats FetchWait{Timestamp
HashMap Text Int
fetchWaitDuration :: Timestamp
fetchWaitStart :: Timestamp
fetchWaitReqs :: HashMap Text Int
fetchWaitDuration :: FetchStats -> Timestamp
fetchWaitStart :: FetchStats -> Timestamp
fetchWaitReqs :: FetchStats -> HashMap Text Int
..}
  | HashMap Text Int -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap Text Int
fetchWaitReqs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ShowS
msg String
"unexpected: Blocked on nothing"
  | HashMap Text Int -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap Text Int
fetchWaitReqs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 =
    ShowS
msg ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Blocked on %s"
      (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String -> Text -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%s (%d reqs)" Text
ds Int
c
                       | (Text
ds,Int
c) <- HashMap Text Int -> [(Text, Int)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text Int
fetchWaitReqs])
  | Bool
otherwise = ShowS
msg ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Blocked on %d sources (%d reqs)"
                        (HashMap Text Int -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap Text Int
fetchWaitReqs)
                        ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ HashMap Text Int -> [Int]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap Text Int
fetchWaitReqs)
  where
    msg :: String -> String
    msg :: ShowS
msg String
x = String -> String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%s (%.2fms)"
                String
x
                (Timestamp -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Timestamp
fetchWaitDuration Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000 :: Double)
ppFetchStats FetchDataSourceStats{Int
Text
DataSourceStats
fetchBatchId :: Int
fetchDsStatsStats :: DataSourceStats
fetchDsStatsDataSource :: Text
fetchDsStatsCallId :: Int
fetchDsStatsStats :: FetchStats -> DataSourceStats
fetchDsStatsDataSource :: FetchStats -> Text
fetchDsStatsCallId :: FetchStats -> Int
fetchBatchId :: FetchStats -> Int
..} =
  String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s (stats): %s" (Text -> String
Text.unpack Text
fetchDsStatsDataSource)
    (DataSourceStats -> String
forall a. Show a => a -> String
show DataSourceStats
fetchDsStatsStats)

-- | Aggregate stats merging FetchStats from the same dispatched batch into one.
aggregateFetchBatches :: ([FetchStats] -> a) -> Stats -> [a]
aggregateFetchBatches :: ([FetchStats] -> a) -> Stats -> [a]
aggregateFetchBatches [FetchStats] -> a
agg (Stats [FetchStats]
fetches) =
      ([FetchStats] -> a) -> [[FetchStats]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [FetchStats] -> a
agg ([[FetchStats]] -> [a]) -> [[FetchStats]] -> [a]
forall a b. (a -> b) -> a -> b
$
      (FetchStats -> FetchStats -> Bool)
-> [FetchStats] -> [[FetchStats]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> (FetchStats -> Int) -> FetchStats -> FetchStats -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` FetchStats -> Int
fetchBatchId) ([FetchStats] -> [[FetchStats]]) -> [FetchStats] -> [[FetchStats]]
forall a b. (a -> b) -> a -> b
$
      (FetchStats -> Down Int) -> [FetchStats] -> [FetchStats]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int) -> (FetchStats -> Int) -> FetchStats -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FetchStats -> Int
fetchBatchId)
      [FetchStats
f | f :: FetchStats
f@FetchStats{} <- [FetchStats]
fetches]

instance ToJSON FetchStats where
  toJSON :: FetchStats -> Value
toJSON FetchStats{Int
Timestamp
[Int]
Text
fetchIds :: [Int]
fetchBatchId :: Int
fetchIgnoredFailures :: Int
fetchFailures :: Int
fetchSpace :: Timestamp
fetchDuration :: Timestamp
fetchStart :: Timestamp
fetchBatchSize :: Int
fetchDataSource :: Text
fetchIds :: FetchStats -> [Int]
fetchBatchId :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchFailures :: FetchStats -> Int
fetchSpace :: FetchStats -> Timestamp
fetchDuration :: FetchStats -> Timestamp
fetchStart :: FetchStats -> Timestamp
fetchBatchSize :: FetchStats -> Int
fetchDataSource :: FetchStats -> Text
..} = [Pair] -> Value
object
    [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"FetchStats" :: Text)
    , Key
"datasource" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
fetchDataSource
    , Key
"fetches" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
fetchBatchSize
    , Key
"start" Key -> Timestamp -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Timestamp
fetchStart
    , Key
"duration" Key -> Timestamp -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Timestamp
fetchDuration
    , Key
"allocation" Key -> Timestamp -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Timestamp
fetchSpace
    , Key
"failures" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
fetchFailures
    , Key
"ignoredFailures" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
fetchIgnoredFailures
    , Key
"batchid" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
fetchBatchId
    , Key
"fetchids" Key -> [Int] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Int]
fetchIds
    ]
  toJSON (FetchCall String
req [String]
strs Int
fid) = [Pair] -> Value
object
    [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"FetchCall" :: Text)
    , Key
"request" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
req
    , Key
"stack" Key -> [String] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [String]
strs
    , Key
"fetchid" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
fid
    ]
  toJSON (MemoCall Int
cid Timestamp
allocs) = [Pair] -> Value
object
    [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"MemoCall" :: Text)
    , Key
"callid" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
cid
    , Key
"allocation" Key -> Timestamp -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Timestamp
allocs
    ]
  toJSON FetchWait{Timestamp
HashMap Text Int
fetchWaitDuration :: Timestamp
fetchWaitStart :: Timestamp
fetchWaitReqs :: HashMap Text Int
fetchWaitDuration :: FetchStats -> Timestamp
fetchWaitStart :: FetchStats -> Timestamp
fetchWaitReqs :: FetchStats -> HashMap Text Int
..} = [Pair] -> Value
object
    [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"FetchWait" :: Text)
    , Key
"duration" Key -> Timestamp -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Timestamp
fetchWaitDuration
    ]
  toJSON FetchDataSourceStats{Int
Text
DataSourceStats
fetchBatchId :: Int
fetchDsStatsStats :: DataSourceStats
fetchDsStatsDataSource :: Text
fetchDsStatsCallId :: Int
fetchDsStatsStats :: FetchStats -> DataSourceStats
fetchDsStatsDataSource :: FetchStats -> Text
fetchDsStatsCallId :: FetchStats -> Int
fetchBatchId :: FetchStats -> Int
..} = [Pair] -> Value
object
    [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"FetchDataSourceStats" :: Text)
    , Key
"datasource" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
fetchDsStatsDataSource
    , Key
"stats" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DataSourceStats -> Value
sjson DataSourceStats
fetchDsStatsStats
    , Key
"batchid" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
fetchBatchId
    ]
    where
      sjson :: DataSourceStats -> Value
sjson (DataSourceStats a
s) = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
s

emptyStats :: Stats
emptyStats :: Stats
emptyStats = [FetchStats] -> Stats
Stats []

numFetches :: Stats -> Int
numFetches :: Stats -> Int
numFetches (Stats [FetchStats]
rs) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Int
fetchBatchSize | FetchStats{Int
Timestamp
[Int]
Text
fetchIds :: [Int]
fetchBatchId :: Int
fetchIgnoredFailures :: Int
fetchFailures :: Int
fetchSpace :: Timestamp
fetchDuration :: Timestamp
fetchStart :: Timestamp
fetchDataSource :: Text
fetchBatchSize :: Int
fetchIds :: FetchStats -> [Int]
fetchBatchId :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchFailures :: FetchStats -> Int
fetchSpace :: FetchStats -> Timestamp
fetchDuration :: FetchStats -> Timestamp
fetchStart :: FetchStats -> Timestamp
fetchBatchSize :: FetchStats -> Int
fetchDataSource :: FetchStats -> Text
..} <- [FetchStats]
rs ]


-- ---------------------------------------------------------------------------
-- Profiling

type ProfileLabel = Text
type AllocCount = Int64
type LabelHitCount = Int64
type ProfileKey = Int64

data ProfileFetch = ProfileFetch
  { ProfileFetch -> Int
profileFetchFetchId :: {-# UNPACK #-} !CallId
  , ProfileFetch -> Int
profileFetchMemoId ::  {-# UNPACK #-} !CallId
  , ProfileFetch -> Bool
profileFetchWasCached :: !Bool
  }
  deriving (Int -> ProfileFetch -> ShowS
[ProfileFetch] -> ShowS
ProfileFetch -> String
(Int -> ProfileFetch -> ShowS)
-> (ProfileFetch -> String)
-> ([ProfileFetch] -> ShowS)
-> Show ProfileFetch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProfileFetch] -> ShowS
$cshowList :: [ProfileFetch] -> ShowS
show :: ProfileFetch -> String
$cshow :: ProfileFetch -> String
showsPrec :: Int -> ProfileFetch -> ShowS
$cshowsPrec :: Int -> ProfileFetch -> ShowS
Show, ProfileFetch -> ProfileFetch -> Bool
(ProfileFetch -> ProfileFetch -> Bool)
-> (ProfileFetch -> ProfileFetch -> Bool) -> Eq ProfileFetch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProfileFetch -> ProfileFetch -> Bool
$c/= :: ProfileFetch -> ProfileFetch -> Bool
== :: ProfileFetch -> ProfileFetch -> Bool
$c== :: ProfileFetch -> ProfileFetch -> Bool
Eq)

data ProfileMemo = ProfileMemo
  { ProfileMemo -> Int
profileMemoId :: {-# UNPACK #-} !CallId
  , ProfileMemo -> Bool
profileMemoWasCached :: !Bool
  }
  deriving (Int -> ProfileMemo -> ShowS
[ProfileMemo] -> ShowS
ProfileMemo -> String
(Int -> ProfileMemo -> ShowS)
-> (ProfileMemo -> String)
-> ([ProfileMemo] -> ShowS)
-> Show ProfileMemo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProfileMemo] -> ShowS
$cshowList :: [ProfileMemo] -> ShowS
show :: ProfileMemo -> String
$cshow :: ProfileMemo -> String
showsPrec :: Int -> ProfileMemo -> ShowS
$cshowsPrec :: Int -> ProfileMemo -> ShowS
Show, ProfileMemo -> ProfileMemo -> Bool
(ProfileMemo -> ProfileMemo -> Bool)
-> (ProfileMemo -> ProfileMemo -> Bool) -> Eq ProfileMemo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProfileMemo -> ProfileMemo -> Bool
$c/= :: ProfileMemo -> ProfileMemo -> Bool
== :: ProfileMemo -> ProfileMemo -> Bool
$c== :: ProfileMemo -> ProfileMemo -> Bool
Eq)

data Profile = Profile
  { Profile -> HashMap Timestamp ProfileData
profile      :: HashMap ProfileKey ProfileData
     -- ^ Data per key (essentially per call stack)
  , Profile -> HashMap (Text, Timestamp) Timestamp
profileTree :: HashMap (ProfileLabel, ProfileKey) ProfileKey
     -- ^ (label, parent) -> current. The exception is the root which will have
     -- ("MAIN", 0) -> 0
  , Profile -> Timestamp
profileNextKey :: ProfileKey
     -- ^ Provides a unique key per callstack
  }

emptyProfile :: Profile
emptyProfile :: Profile
emptyProfile = HashMap Timestamp ProfileData
-> HashMap (Text, Timestamp) Timestamp -> Timestamp -> Profile
Profile HashMap Timestamp ProfileData
forall k v. HashMap k v
HashMap.empty ((Text, Timestamp)
-> Timestamp -> HashMap (Text, Timestamp) Timestamp
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton (Text
"MAIN", Timestamp
0) Timestamp
0) Timestamp
1

data ProfileData = ProfileData
  { ProfileData -> Timestamp
profileAllocs :: {-# UNPACK #-} !AllocCount
     -- ^ allocations made by this label
  , ProfileData -> [ProfileFetch]
profileFetches :: [ProfileFetch]
     -- ^ fetches made in this label
  , ProfileData -> Timestamp
profileLabelHits :: {-# UNPACK #-} !LabelHitCount
     -- ^ number of hits at this label
  , ProfileData -> [ProfileMemo]
profileMemos :: [ProfileMemo]
     -- ^ memo and a boolean representing if it was cached at the time
  , ProfileData -> Timestamp
profileTime :: {-# UNPACK #-} !Microseconds
     -- ^ amount of time spent in computation at this label
  }
  deriving Int -> ProfileData -> ShowS
[ProfileData] -> ShowS
ProfileData -> String
(Int -> ProfileData -> ShowS)
-> (ProfileData -> String)
-> ([ProfileData] -> ShowS)
-> Show ProfileData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProfileData] -> ShowS
$cshowList :: [ProfileData] -> ShowS
show :: ProfileData -> String
$cshow :: ProfileData -> String
showsPrec :: Int -> ProfileData -> ShowS
$cshowsPrec :: Int -> ProfileData -> ShowS
Show

emptyProfileData :: ProfileData
emptyProfileData :: ProfileData
emptyProfileData = Timestamp
-> [ProfileFetch]
-> Timestamp
-> [ProfileMemo]
-> Timestamp
-> ProfileData
ProfileData Timestamp
0 [] Timestamp
0 [] Timestamp
0