{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

{-# 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 AllocCount
getTimestamp = do
  POSIXTime
t <- IO POSIXTime
getPOSIXTime -- for now, TODO better
  AllocCount -> IO AllocCount
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (POSIXTime -> AllocCount
forall b. Integral b => POSIXTime -> b
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 -> String -> String
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 -> String -> String
[Stats] -> String -> String
Stats -> String
(Int -> Stats -> String -> String)
-> (Stats -> String) -> ([Stats] -> String -> String) -> Show Stats
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Stats -> String -> String
showsPrec :: Int -> Stats -> String -> String
$cshow :: Stats -> String
show :: Stats -> String
$cshowList :: [Stats] -> String -> String
showList :: [Stats] -> String -> String
Show, [Stats] -> Value
[Stats] -> Encoding
Stats -> Bool
Stats -> Value
Stats -> Encoding
(Stats -> Value)
-> (Stats -> Encoding)
-> ([Stats] -> Value)
-> ([Stats] -> Encoding)
-> (Stats -> Bool)
-> ToJSON Stats
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Stats -> Value
toJSON :: Stats -> Value
$ctoEncoding :: Stats -> Encoding
toEncoding :: Stats -> Encoding
$ctoJSONList :: [Stats] -> Value
toJSONList :: [Stats] -> Value
$ctoEncodingList :: [Stats] -> Encoding
toEncodingList :: [Stats] -> Encoding
$comitField :: Stats -> Bool
omitField :: Stats -> Bool
ToJSON, 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
$c<> :: Stats -> Stats -> Stats
<> :: Stats -> Stats -> Stats
$csconcat :: NonEmpty Stats -> Stats
sconcat :: NonEmpty Stats -> Stats
$cstimes :: forall b. Integral b => b -> Stats -> Stats
stimes :: forall b. Integral b => b -> 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
$cmempty :: Stats
mempty :: Stats
$cmappend :: Stats -> Stats -> Stats
mappend :: Stats -> Stats -> Stats
$cmconcat :: [Stats] -> Stats
mconcat :: [Stats] -> 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ [
      if FetchStats -> AllocCount -> AllocCount -> Bool
fetchWasRunning FetchStats
rs
          (AllocCount
minStartTime AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
+ (AllocCount
t AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
- AllocCount
1) AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
* AllocCount
usPerDash)
          (AllocCount
minStartTime AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
+ AllocCount
t AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
* AllocCount
usPerDash)
        then FetchStats -> Char
fetchSymbol FetchStats
rs
        else Char
'-'
      | AllocCount
t <- [AllocCount
1..AllocCount
numDashes]
      ]
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - " String -> String -> String
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 :: AllocCount
numDashes = AllocCount
50
    getStart :: FetchStats -> Maybe AllocCount
getStart FetchStats{Int
AllocCount
[Int]
ProfileLabel
fetchDataSource :: ProfileLabel
fetchBatchSize :: Int
fetchStart :: AllocCount
fetchDuration :: AllocCount
fetchSpace :: AllocCount
fetchFailures :: Int
fetchIgnoredFailures :: Int
fetchBatchId :: Int
fetchIds :: [Int]
fetchDataSource :: FetchStats -> ProfileLabel
fetchBatchSize :: FetchStats -> Int
fetchStart :: FetchStats -> AllocCount
fetchDuration :: FetchStats -> AllocCount
fetchSpace :: FetchStats -> AllocCount
fetchFailures :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchBatchId :: FetchStats -> Int
fetchIds :: FetchStats -> [Int]
..} = AllocCount -> Maybe AllocCount
forall a. a -> Maybe a
Just AllocCount
fetchStart
    getStart FetchWait{AllocCount
HashMap ProfileLabel Int
fetchWaitReqs :: HashMap ProfileLabel Int
fetchWaitStart :: AllocCount
fetchWaitDuration :: AllocCount
fetchWaitReqs :: FetchStats -> HashMap ProfileLabel Int
fetchWaitStart :: FetchStats -> AllocCount
fetchWaitDuration :: FetchStats -> AllocCount
..} = AllocCount -> Maybe AllocCount
forall a. a -> Maybe a
Just AllocCount
fetchWaitStart
    getStart FetchStats
_ = Maybe AllocCount
forall a. Maybe a
Nothing
    getEnd :: FetchStats -> Maybe AllocCount
getEnd FetchStats{Int
AllocCount
[Int]
ProfileLabel
fetchDataSource :: FetchStats -> ProfileLabel
fetchBatchSize :: FetchStats -> Int
fetchStart :: FetchStats -> AllocCount
fetchDuration :: FetchStats -> AllocCount
fetchSpace :: FetchStats -> AllocCount
fetchFailures :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchBatchId :: FetchStats -> Int
fetchIds :: FetchStats -> [Int]
fetchDataSource :: ProfileLabel
fetchBatchSize :: Int
fetchStart :: AllocCount
fetchDuration :: AllocCount
fetchSpace :: AllocCount
fetchFailures :: Int
fetchIgnoredFailures :: Int
fetchBatchId :: Int
fetchIds :: [Int]
..} = AllocCount -> Maybe AllocCount
forall a. a -> Maybe a
Just (AllocCount -> Maybe AllocCount) -> AllocCount -> Maybe AllocCount
forall a b. (a -> b) -> a -> b
$ AllocCount
fetchStart AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
+ AllocCount
fetchDuration
    getEnd FetchWait{AllocCount
HashMap ProfileLabel Int
fetchWaitReqs :: FetchStats -> HashMap ProfileLabel Int
fetchWaitStart :: FetchStats -> AllocCount
fetchWaitDuration :: FetchStats -> AllocCount
fetchWaitReqs :: HashMap ProfileLabel Int
fetchWaitStart :: AllocCount
fetchWaitDuration :: AllocCount
..} = AllocCount -> Maybe AllocCount
forall a. a -> Maybe a
Just (AllocCount -> Maybe AllocCount) -> AllocCount -> Maybe AllocCount
forall a b. (a -> b) -> a -> b
$ AllocCount
fetchWaitStart AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
+ AllocCount
fetchWaitDuration
    getEnd FetchStats
_ = Maybe AllocCount
forall a. Maybe a
Nothing
    minStartTime :: AllocCount
minStartTime = [AllocCount] -> AllocCount
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([AllocCount] -> AllocCount) -> [AllocCount] -> AllocCount
forall a b. (a -> b) -> a -> b
$ (FetchStats -> Maybe AllocCount) -> [FetchStats] -> [AllocCount]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FetchStats -> Maybe AllocCount
getStart [FetchStats]
validFetchStats
    endTime :: AllocCount
endTime = [AllocCount] -> AllocCount
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([AllocCount] -> AllocCount) -> [AllocCount] -> AllocCount
forall a b. (a -> b) -> a -> b
$ (FetchStats -> Maybe AllocCount) -> [FetchStats] -> [AllocCount]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FetchStats -> Maybe AllocCount
getEnd [FetchStats]
validFetchStats
    usPerDash :: AllocCount
usPerDash = (AllocCount
endTime AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
- AllocCount
minStartTime) AllocCount -> AllocCount -> AllocCount
forall a. Integral a => a -> a -> a
`div` AllocCount
numDashes
    fetchSymbol :: FetchStats -> Char
fetchSymbol FetchStats{} = Char
'*'
    fetchSymbol FetchWait{} = Char
'.'
    fetchSymbol FetchStats
_ = Char
'?'
    fetchWasRunning :: FetchStats -> Timestamp -> Timestamp -> Bool
    fetchWasRunning :: FetchStats -> AllocCount -> AllocCount -> Bool
fetchWasRunning fs :: FetchStats
fs@FetchStats{} AllocCount
t1 AllocCount
t2 =
      (FetchStats -> AllocCount
fetchStart FetchStats
fs AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
+ FetchStats -> AllocCount
fetchDuration FetchStats
fs) AllocCount -> AllocCount -> Bool
forall a. Ord a => a -> a -> Bool
>= AllocCount
t1 Bool -> Bool -> Bool
&& FetchStats -> AllocCount
fetchStart FetchStats
fs AllocCount -> AllocCount -> Bool
forall a. Ord a => a -> a -> Bool
< AllocCount
t2
    fetchWasRunning fw :: FetchStats
fw@FetchWait{} AllocCount
t1 AllocCount
t2 =
      (FetchStats -> AllocCount
fetchWaitStart FetchStats
fw AllocCount -> AllocCount -> AllocCount
forall a. Num a => a -> a -> a
+ FetchStats -> AllocCount
fetchWaitDuration FetchStats
fw) AllocCount -> AllocCount -> Bool
forall a. Ord a => a -> a -> Bool
>= AllocCount
t1 Bool -> Bool -> Bool
&& FetchStats -> AllocCount
fetchWaitStart FetchStats
fw AllocCount -> AllocCount -> Bool
forall a. Ord a => a -> a -> Bool
< AllocCount
t2
    fetchWasRunning FetchStats
_ AllocCount
_ AllocCount
_ = 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 -> ProfileLabel
fetchDataSource :: Text
    , FetchStats -> Int
fetchBatchSize :: {-# UNPACK #-} !Int
    , FetchStats -> AllocCount
fetchStart :: {-# UNPACK #-} !Timestamp
    , FetchStats -> AllocCount
fetchDuration :: {-# UNPACK #-} !Microseconds
    , FetchStats -> AllocCount
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 -> AllocCount
memoSpace :: {-# UNPACK #-} !Int64
    }
  | FetchWait
    { FetchStats -> HashMap ProfileLabel Int
fetchWaitReqs :: HashMap Text Int
       -- ^ What DataSources had requests that were being waited for
    , FetchStats -> AllocCount
fetchWaitStart :: {-# UNPACK #-} !Timestamp
    , FetchStats -> AllocCount
fetchWaitDuration :: {-# UNPACK #-} !Microseconds
    }
  | FetchDataSourceStats
    { FetchStats -> Int
fetchDsStatsCallId :: CallId
    , FetchStats -> ProfileLabel
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
$c== :: FetchStats -> FetchStats -> Bool
== :: FetchStats -> FetchStats -> Bool
$c/= :: FetchStats -> FetchStats -> Bool
/= :: FetchStats -> FetchStats -> Bool
Eq, Int -> FetchStats -> String -> String
[FetchStats] -> String -> String
FetchStats -> String
(Int -> FetchStats -> String -> String)
-> (FetchStats -> String)
-> ([FetchStats] -> String -> String)
-> Show FetchStats
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FetchStats -> String -> String
showsPrec :: Int -> FetchStats -> String -> String
$cshow :: FetchStats -> String
show :: FetchStats -> String
$cshowList :: [FetchStats] -> String -> String
showList :: [FetchStats] -> String -> String
Show)

-- | Pretty-print RoundStats.
ppFetchStats :: FetchStats -> String
ppFetchStats :: FetchStats -> String
ppFetchStats FetchStats{Int
AllocCount
[Int]
ProfileLabel
fetchDataSource :: FetchStats -> ProfileLabel
fetchBatchSize :: FetchStats -> Int
fetchStart :: FetchStats -> AllocCount
fetchDuration :: FetchStats -> AllocCount
fetchSpace :: FetchStats -> AllocCount
fetchFailures :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchBatchId :: FetchStats -> Int
fetchIds :: FetchStats -> [Int]
fetchDataSource :: ProfileLabel
fetchBatchSize :: Int
fetchStart :: AllocCount
fetchDuration :: AllocCount
fetchSpace :: AllocCount
fetchFailures :: Int
fetchIgnoredFailures :: Int
fetchBatchId :: Int
fetchIds :: [Int]
..} =
  String -> String -> Int -> Double -> AllocCount -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%s: %d fetches (%.2fms, %d bytes, %d failures)"
    (ProfileLabel -> String
Text.unpack ProfileLabel
fetchDataSource) Int
fetchBatchSize
    (AllocCount -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral AllocCount
fetchDuration Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000 :: Double)  AllocCount
fetchSpace Int
fetchFailures
ppFetchStats (FetchCall String
r [String]
ss Int
_) = String -> String
forall a. Show a => a -> String
show String
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:[String] -> String
forall a. Show a => a -> String
show [String]
ss
ppFetchStats MemoCall{} = String
""
ppFetchStats FetchWait{AllocCount
HashMap ProfileLabel Int
fetchWaitReqs :: FetchStats -> HashMap ProfileLabel Int
fetchWaitStart :: FetchStats -> AllocCount
fetchWaitDuration :: FetchStats -> AllocCount
fetchWaitReqs :: HashMap ProfileLabel Int
fetchWaitStart :: AllocCount
fetchWaitDuration :: AllocCount
..}
  | HashMap ProfileLabel Int -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap ProfileLabel Int
fetchWaitReqs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> String
msg String
"unexpected: Blocked on nothing"
  | HashMap ProfileLabel Int -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap ProfileLabel Int
fetchWaitReqs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 =
    String -> String
msg (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Blocked on %s"
      (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String -> ProfileLabel -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%s (%d reqs)" ProfileLabel
ds Int
c
                       | (ProfileLabel
ds,Int
c) <- HashMap ProfileLabel Int -> [(ProfileLabel, Int)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap ProfileLabel Int
fetchWaitReqs])
  | Bool
otherwise = String -> String
msg (String -> String) -> String -> String
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 ProfileLabel Int -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap ProfileLabel Int
fetchWaitReqs)
                        ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ HashMap ProfileLabel Int -> [Int]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap ProfileLabel Int
fetchWaitReqs)
  where
    msg :: String -> String
    msg :: String -> String
msg String
x = String -> String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%s (%.2fms)"
                String
x
                (AllocCount -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral AllocCount
fetchWaitDuration Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000 :: Double)
ppFetchStats FetchDataSourceStats{Int
ProfileLabel
DataSourceStats
fetchBatchId :: FetchStats -> Int
fetchDsStatsCallId :: FetchStats -> Int
fetchDsStatsDataSource :: FetchStats -> ProfileLabel
fetchDsStatsStats :: FetchStats -> DataSourceStats
fetchDsStatsCallId :: Int
fetchDsStatsDataSource :: ProfileLabel
fetchDsStatsStats :: DataSourceStats
fetchBatchId :: Int
..} =
  String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s (stats): %s" (ProfileLabel -> String
Text.unpack ProfileLabel
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 :: forall a. ([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
AllocCount
[Int]
ProfileLabel
fetchDataSource :: FetchStats -> ProfileLabel
fetchBatchSize :: FetchStats -> Int
fetchStart :: FetchStats -> AllocCount
fetchDuration :: FetchStats -> AllocCount
fetchSpace :: FetchStats -> AllocCount
fetchFailures :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchBatchId :: FetchStats -> Int
fetchIds :: FetchStats -> [Int]
fetchDataSource :: ProfileLabel
fetchBatchSize :: Int
fetchStart :: AllocCount
fetchDuration :: AllocCount
fetchSpace :: AllocCount
fetchFailures :: Int
fetchIgnoredFailures :: Int
fetchBatchId :: Int
fetchIds :: [Int]
..} = [Pair] -> Value
object
    [ Key
"type" Key -> ProfileLabel -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ProfileLabel
"FetchStats" :: Text)
    , Key
"datasource" Key -> ProfileLabel -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProfileLabel
fetchDataSource
    , Key
"fetches" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
fetchBatchSize
    , Key
"start" Key -> AllocCount -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AllocCount
fetchStart
    , Key
"duration" Key -> AllocCount -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AllocCount
fetchDuration
    , Key
"allocation" Key -> AllocCount -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AllocCount
fetchSpace
    , Key
"failures" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
fetchFailures
    , Key
"ignoredFailures" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
fetchIgnoredFailures
    , Key
"batchid" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
fetchBatchId
    , Key
"fetchids" Key -> [Int] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int]
fetchIds
    ]
  toJSON (FetchCall String
req [String]
strs Int
fid) = [Pair] -> Value
object
    [ Key
"type" Key -> ProfileLabel -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ProfileLabel
"FetchCall" :: Text)
    , Key
"request" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
req
    , Key
"stack" Key -> [String] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [String]
strs
    , Key
"fetchid" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
fid
    ]
  toJSON (MemoCall Int
cid AllocCount
allocs) = [Pair] -> Value
object
    [ Key
"type" Key -> ProfileLabel -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ProfileLabel
"MemoCall" :: Text)
    , Key
"callid" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
cid
    , Key
"allocation" Key -> AllocCount -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AllocCount
allocs
    ]
  toJSON FetchWait{AllocCount
HashMap ProfileLabel Int
fetchWaitReqs :: FetchStats -> HashMap ProfileLabel Int
fetchWaitStart :: FetchStats -> AllocCount
fetchWaitDuration :: FetchStats -> AllocCount
fetchWaitReqs :: HashMap ProfileLabel Int
fetchWaitStart :: AllocCount
fetchWaitDuration :: AllocCount
..} = [Pair] -> Value
object
    [ Key
"type" Key -> ProfileLabel -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ProfileLabel
"FetchWait" :: Text)
    , Key
"duration" Key -> AllocCount -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AllocCount
fetchWaitDuration
    ]
  toJSON FetchDataSourceStats{Int
ProfileLabel
DataSourceStats
fetchBatchId :: FetchStats -> Int
fetchDsStatsCallId :: FetchStats -> Int
fetchDsStatsDataSource :: FetchStats -> ProfileLabel
fetchDsStatsStats :: FetchStats -> DataSourceStats
fetchDsStatsCallId :: Int
fetchDsStatsDataSource :: ProfileLabel
fetchDsStatsStats :: DataSourceStats
fetchBatchId :: Int
..} = [Pair] -> Value
object
    [ Key
"type" Key -> ProfileLabel -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ProfileLabel
"FetchDataSourceStats" :: Text)
    , Key
"datasource" Key -> ProfileLabel -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProfileLabel
fetchDsStatsDataSource
    , Key
"stats" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DataSourceStats -> Value
sjson DataSourceStats
fetchDsStatsStats
    , Key
"batchid" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e 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 a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Int
fetchBatchSize | FetchStats{Int
AllocCount
[Int]
ProfileLabel
fetchDataSource :: FetchStats -> ProfileLabel
fetchBatchSize :: FetchStats -> Int
fetchStart :: FetchStats -> AllocCount
fetchDuration :: FetchStats -> AllocCount
fetchSpace :: FetchStats -> AllocCount
fetchFailures :: FetchStats -> Int
fetchIgnoredFailures :: FetchStats -> Int
fetchBatchId :: FetchStats -> Int
fetchIds :: FetchStats -> [Int]
fetchBatchSize :: Int
fetchDataSource :: ProfileLabel
fetchStart :: AllocCount
fetchDuration :: AllocCount
fetchSpace :: AllocCount
fetchFailures :: Int
fetchIgnoredFailures :: Int
fetchBatchId :: Int
fetchIds :: [Int]
..} <- [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 -> String -> String
[ProfileFetch] -> String -> String
ProfileFetch -> String
(Int -> ProfileFetch -> String -> String)
-> (ProfileFetch -> String)
-> ([ProfileFetch] -> String -> String)
-> Show ProfileFetch
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ProfileFetch -> String -> String
showsPrec :: Int -> ProfileFetch -> String -> String
$cshow :: ProfileFetch -> String
show :: ProfileFetch -> String
$cshowList :: [ProfileFetch] -> String -> String
showList :: [ProfileFetch] -> String -> String
Show, ProfileFetch -> ProfileFetch -> Bool
(ProfileFetch -> ProfileFetch -> Bool)
-> (ProfileFetch -> ProfileFetch -> Bool) -> Eq ProfileFetch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProfileFetch -> ProfileFetch -> Bool
== :: ProfileFetch -> ProfileFetch -> Bool
$c/= :: ProfileFetch -> ProfileFetch -> Bool
/= :: ProfileFetch -> ProfileFetch -> Bool
Eq)

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

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

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

data ProfileData = ProfileData
  { ProfileData -> AllocCount
profileAllocs :: {-# UNPACK #-} !AllocCount
     -- ^ allocations made by this label
  , ProfileData -> [ProfileFetch]
profileFetches :: [ProfileFetch]
     -- ^ fetches made in this label
  , ProfileData -> AllocCount
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 -> AllocCount
profileTime :: {-# UNPACK #-} !Microseconds
     -- ^ amount of time spent in computation at this label
  }
  deriving Int -> ProfileData -> String -> String
[ProfileData] -> String -> String
ProfileData -> String
(Int -> ProfileData -> String -> String)
-> (ProfileData -> String)
-> ([ProfileData] -> String -> String)
-> Show ProfileData
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ProfileData -> String -> String
showsPrec :: Int -> ProfileData -> String -> String
$cshow :: ProfileData -> String
show :: ProfileData -> String
$cshowList :: [ProfileData] -> String -> String
showList :: [ProfileData] -> String -> String
Show

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