{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# OPTIONS_GHC -Wall #-}

-- | Space performance measurement.
module Perf.Space
  ( SpaceStats (..),
    ssToList,
    spaceLabels,
    space,
    allocation,
  )
where

import Control.Monad.State.Lazy
import Data.String
import Data.Text (Text)
import Data.Word
import GHC.Stats
import Perf.Types
import System.Mem
import Prelude hiding (cycle)

-- | GHC allocation statistics.
data SpaceStats = SpaceStats {SpaceStats -> Word64
allocatedBytes :: Word64, SpaceStats -> Word32
gcollects :: Word32, SpaceStats -> Word64
maxLiveBytes :: Word64, SpaceStats -> Word64
gcLiveBytes :: Word64, SpaceStats -> Word64
maxMem :: Word64} deriving (ReadPrec [SpaceStats]
ReadPrec SpaceStats
Int -> ReadS SpaceStats
ReadS [SpaceStats]
(Int -> ReadS SpaceStats)
-> ReadS [SpaceStats]
-> ReadPrec SpaceStats
-> ReadPrec [SpaceStats]
-> Read SpaceStats
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SpaceStats]
$creadListPrec :: ReadPrec [SpaceStats]
readPrec :: ReadPrec SpaceStats
$creadPrec :: ReadPrec SpaceStats
readList :: ReadS [SpaceStats]
$creadList :: ReadS [SpaceStats]
readsPrec :: Int -> ReadS SpaceStats
$creadsPrec :: Int -> ReadS SpaceStats
Read, Int -> SpaceStats -> ShowS
[SpaceStats] -> ShowS
SpaceStats -> String
(Int -> SpaceStats -> ShowS)
-> (SpaceStats -> String)
-> ([SpaceStats] -> ShowS)
-> Show SpaceStats
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpaceStats] -> ShowS
$cshowList :: [SpaceStats] -> ShowS
show :: SpaceStats -> String
$cshow :: SpaceStats -> String
showsPrec :: Int -> SpaceStats -> ShowS
$cshowsPrec :: Int -> SpaceStats -> ShowS
Show, SpaceStats -> SpaceStats -> Bool
(SpaceStats -> SpaceStats -> Bool)
-> (SpaceStats -> SpaceStats -> Bool) -> Eq SpaceStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpaceStats -> SpaceStats -> Bool
$c/= :: SpaceStats -> SpaceStats -> Bool
== :: SpaceStats -> SpaceStats -> Bool
$c== :: SpaceStats -> SpaceStats -> Bool
Eq)

-- | Convert 'SpaceStats' to a list of numbers.
ssToList :: Num a => SpaceStats -> [a]
ssToList :: SpaceStats -> [a]
ssToList (SpaceStats Word64
x1 Word32
x2 Word64
x3 Word64
x4 Word64
x5) = [Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x1, Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x2, Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x3, Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x4, Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x5]

instance Semigroup SpaceStats where
  <> :: SpaceStats -> SpaceStats -> SpaceStats
(<>) = SpaceStats -> SpaceStats -> SpaceStats
addSpace

instance Monoid SpaceStats where
  mempty :: SpaceStats
mempty = Word64 -> Word32 -> Word64 -> Word64 -> Word64 -> SpaceStats
SpaceStats Word64
0 Word32
0 Word64
0 Word64
0 Word64
0

instance Num SpaceStats where
  + :: SpaceStats -> SpaceStats -> SpaceStats
(+) = SpaceStats -> SpaceStats -> SpaceStats
addSpace
  (-) = SpaceStats -> SpaceStats -> SpaceStats
diffSpace
  * :: SpaceStats -> SpaceStats -> SpaceStats
(*) = String -> SpaceStats -> SpaceStats -> SpaceStats
forall a. HasCallStack => String -> a
error String
"SpaceStats times"
  abs :: SpaceStats -> SpaceStats
abs = String -> SpaceStats -> SpaceStats
forall a. HasCallStack => String -> a
error String
"SpaceStats abs"
  signum :: SpaceStats -> SpaceStats
signum = String -> SpaceStats -> SpaceStats
forall a. HasCallStack => String -> a
error String
"SpaceStats signum"
  fromInteger :: Integer -> SpaceStats
fromInteger Integer
n = Word64 -> Word32 -> Word64 -> Word64 -> Word64 -> SpaceStats
SpaceStats (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)

diffSpace :: SpaceStats -> SpaceStats -> SpaceStats
diffSpace :: SpaceStats -> SpaceStats -> SpaceStats
diffSpace (SpaceStats Word64
x1 Word32
x2 Word64
x3 Word64
x4 Word64
x5) (SpaceStats Word64
x1' Word32
x2' Word64
x3' Word64
x4' Word64
x5') = Word64 -> Word32 -> Word64 -> Word64 -> Word64 -> SpaceStats
SpaceStats (Word64
x1' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
x1) (Word32
x2' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
x2) (Word64
x3' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
x3) (Word64
x4' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
x4) (Word64
x5' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
x5)

addSpace :: SpaceStats -> SpaceStats -> SpaceStats
addSpace :: SpaceStats -> SpaceStats -> SpaceStats
addSpace (SpaceStats Word64
x1 Word32
x2 Word64
x3 Word64
x4 Word64
x5) (SpaceStats Word64
x1' Word32
x2' Word64
x3' Word64
x4' Word64
x5') = Word64 -> Word32 -> Word64 -> Word64 -> Word64 -> SpaceStats
SpaceStats (Word64
x1' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x1) (Word32
x2' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
x2) (Word64
x3' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x3) (Word64
x4' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x4) (Word64
x5' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x5)

getSpace :: RTSStats -> SpaceStats
getSpace :: RTSStats -> SpaceStats
getSpace RTSStats
s = Word64 -> Word32 -> Word64 -> Word64 -> Word64 -> SpaceStats
SpaceStats (RTSStats -> Word64
allocated_bytes RTSStats
s) (RTSStats -> Word32
gcs RTSStats
s) (RTSStats -> Word64
max_live_bytes RTSStats
s) (GCDetails -> Word64
gcdetails_live_bytes (RTSStats -> GCDetails
gc RTSStats
s)) (RTSStats -> Word64
max_mem_in_use_bytes RTSStats
s)

-- | Labels for 'SpaceStats'.
spaceLabels :: [Text]
spaceLabels :: [Text]
spaceLabels = [Text
"allocated", Text
"gcollects", Text
"maxLiveBytes", Text
"gcLiveBytes", Text
"MaxMem"]

-- | A allocation 'StepMeasure' with a flag to determine if 'performGC' should run prior to the measurement.
space :: Bool -> StepMeasure IO SpaceStats
space :: Bool -> StepMeasure IO SpaceStats
space Bool
p = IO SpaceStats
-> (SpaceStats -> IO SpaceStats) -> StepMeasure IO SpaceStats
forall (m :: * -> *) t i. m i -> (i -> m t) -> StepMeasure m t
StepMeasure (Bool -> IO SpaceStats
start Bool
p) SpaceStats -> IO SpaceStats
stop
  where
    start :: Bool -> IO SpaceStats
start Bool
p' = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
p' IO ()
performGC
      RTSStats -> SpaceStats
getSpace (RTSStats -> SpaceStats) -> IO RTSStats -> IO SpaceStats
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
getRTSStats
    stop :: SpaceStats -> IO SpaceStats
stop SpaceStats
s = do
      SpaceStats
s' <- RTSStats -> SpaceStats
getSpace (RTSStats -> SpaceStats) -> IO RTSStats -> IO SpaceStats
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
getRTSStats
      SpaceStats -> IO SpaceStats
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpaceStats -> IO SpaceStats) -> SpaceStats -> IO SpaceStats
forall a b. (a -> b) -> a -> b
$ SpaceStats -> SpaceStats -> SpaceStats
diffSpace SpaceStats
s SpaceStats
s'
{-# INLINEABLE space #-}

newtype Bytes = Bytes {Bytes -> Word64
unbytes :: Word64}
  deriving (Int -> Bytes -> ShowS
[Bytes] -> ShowS
Bytes -> String
(Int -> Bytes -> ShowS)
-> (Bytes -> String) -> ([Bytes] -> ShowS) -> Show Bytes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bytes] -> ShowS
$cshowList :: [Bytes] -> ShowS
show :: Bytes -> String
$cshow :: Bytes -> String
showsPrec :: Int -> Bytes -> ShowS
$cshowsPrec :: Int -> Bytes -> ShowS
Show, ReadPrec [Bytes]
ReadPrec Bytes
Int -> ReadS Bytes
ReadS [Bytes]
(Int -> ReadS Bytes)
-> ReadS [Bytes]
-> ReadPrec Bytes
-> ReadPrec [Bytes]
-> Read Bytes
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Bytes]
$creadListPrec :: ReadPrec [Bytes]
readPrec :: ReadPrec Bytes
$creadPrec :: ReadPrec Bytes
readList :: ReadS [Bytes]
$creadList :: ReadS [Bytes]
readsPrec :: Int -> ReadS Bytes
$creadsPrec :: Int -> ReadS Bytes
Read, Bytes -> Bytes -> Bool
(Bytes -> Bytes -> Bool) -> (Bytes -> Bytes -> Bool) -> Eq Bytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bytes -> Bytes -> Bool
$c/= :: Bytes -> Bytes -> Bool
== :: Bytes -> Bytes -> Bool
$c== :: Bytes -> Bytes -> Bool
Eq, Eq Bytes
Eq Bytes
-> (Bytes -> Bytes -> Ordering)
-> (Bytes -> Bytes -> Bool)
-> (Bytes -> Bytes -> Bool)
-> (Bytes -> Bytes -> Bool)
-> (Bytes -> Bytes -> Bool)
-> (Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes -> Bytes)
-> Ord Bytes
Bytes -> Bytes -> Bool
Bytes -> Bytes -> Ordering
Bytes -> Bytes -> Bytes
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Bytes -> Bytes -> Bytes
$cmin :: Bytes -> Bytes -> Bytes
max :: Bytes -> Bytes -> Bytes
$cmax :: Bytes -> Bytes -> Bytes
>= :: Bytes -> Bytes -> Bool
$c>= :: Bytes -> Bytes -> Bool
> :: Bytes -> Bytes -> Bool
$c> :: Bytes -> Bytes -> Bool
<= :: Bytes -> Bytes -> Bool
$c<= :: Bytes -> Bytes -> Bool
< :: Bytes -> Bytes -> Bool
$c< :: Bytes -> Bytes -> Bool
compare :: Bytes -> Bytes -> Ordering
$ccompare :: Bytes -> Bytes -> Ordering
$cp1Ord :: Eq Bytes
Ord, Integer -> Bytes
Bytes -> Bytes
Bytes -> Bytes -> Bytes
(Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes)
-> (Bytes -> Bytes)
-> (Bytes -> Bytes)
-> (Integer -> Bytes)
-> Num Bytes
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Bytes
$cfromInteger :: Integer -> Bytes
signum :: Bytes -> Bytes
$csignum :: Bytes -> Bytes
abs :: Bytes -> Bytes
$cabs :: Bytes -> Bytes
negate :: Bytes -> Bytes
$cnegate :: Bytes -> Bytes
* :: Bytes -> Bytes -> Bytes
$c* :: Bytes -> Bytes -> Bytes
- :: Bytes -> Bytes -> Bytes
$c- :: Bytes -> Bytes -> Bytes
+ :: Bytes -> Bytes -> Bytes
$c+ :: Bytes -> Bytes -> Bytes
Num, Num Bytes
Ord Bytes
Num Bytes -> Ord Bytes -> (Bytes -> Rational) -> Real Bytes
Bytes -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Bytes -> Rational
$ctoRational :: Bytes -> Rational
$cp2Real :: Ord Bytes
$cp1Real :: Num Bytes
Real, Int -> Bytes
Bytes -> Int
Bytes -> [Bytes]
Bytes -> Bytes
Bytes -> Bytes -> [Bytes]
Bytes -> Bytes -> Bytes -> [Bytes]
(Bytes -> Bytes)
-> (Bytes -> Bytes)
-> (Int -> Bytes)
-> (Bytes -> Int)
-> (Bytes -> [Bytes])
-> (Bytes -> Bytes -> [Bytes])
-> (Bytes -> Bytes -> [Bytes])
-> (Bytes -> Bytes -> Bytes -> [Bytes])
-> Enum Bytes
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Bytes -> Bytes -> Bytes -> [Bytes]
$cenumFromThenTo :: Bytes -> Bytes -> Bytes -> [Bytes]
enumFromTo :: Bytes -> Bytes -> [Bytes]
$cenumFromTo :: Bytes -> Bytes -> [Bytes]
enumFromThen :: Bytes -> Bytes -> [Bytes]
$cenumFromThen :: Bytes -> Bytes -> [Bytes]
enumFrom :: Bytes -> [Bytes]
$cenumFrom :: Bytes -> [Bytes]
fromEnum :: Bytes -> Int
$cfromEnum :: Bytes -> Int
toEnum :: Int -> Bytes
$ctoEnum :: Int -> Bytes
pred :: Bytes -> Bytes
$cpred :: Bytes -> Bytes
succ :: Bytes -> Bytes
$csucc :: Bytes -> Bytes
Enum, Enum Bytes
Real Bytes
Real Bytes
-> Enum Bytes
-> (Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes -> Bytes)
-> (Bytes -> Bytes -> (Bytes, Bytes))
-> (Bytes -> Bytes -> (Bytes, Bytes))
-> (Bytes -> Integer)
-> Integral Bytes
Bytes -> Integer
Bytes -> Bytes -> (Bytes, Bytes)
Bytes -> Bytes -> Bytes
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: Bytes -> Integer
$ctoInteger :: Bytes -> Integer
divMod :: Bytes -> Bytes -> (Bytes, Bytes)
$cdivMod :: Bytes -> Bytes -> (Bytes, Bytes)
quotRem :: Bytes -> Bytes -> (Bytes, Bytes)
$cquotRem :: Bytes -> Bytes -> (Bytes, Bytes)
mod :: Bytes -> Bytes -> Bytes
$cmod :: Bytes -> Bytes -> Bytes
div :: Bytes -> Bytes -> Bytes
$cdiv :: Bytes -> Bytes -> Bytes
rem :: Bytes -> Bytes -> Bytes
$crem :: Bytes -> Bytes -> Bytes
quot :: Bytes -> Bytes -> Bytes
$cquot :: Bytes -> Bytes -> Bytes
$cp2Integral :: Enum Bytes
$cp1Integral :: Real Bytes
Integral)

instance Semigroup Bytes where
  <> :: Bytes -> Bytes -> Bytes
(<>) = Bytes -> Bytes -> Bytes
forall a. Num a => a -> a -> a
(+)

instance Monoid Bytes where
  mempty :: Bytes
mempty = Bytes
0

-- | Measure memory allocation, with a flag to run 'performGC' prior to the measurement.
allocation :: Bool -> StepMeasure IO Bytes
allocation :: Bool -> StepMeasure IO Bytes
allocation Bool
p = IO Bytes -> (Bytes -> IO Bytes) -> StepMeasure IO Bytes
forall (m :: * -> *) t i. m i -> (i -> m t) -> StepMeasure m t
StepMeasure (Bool -> IO Bytes
start Bool
p) Bytes -> IO Bytes
stop
  where
    start :: Bool -> IO Bytes
start Bool
p' = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
p' IO ()
performGC
      Word64 -> Bytes
Bytes (Word64 -> Bytes) -> (RTSStats -> Word64) -> RTSStats -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTSStats -> Word64
allocated_bytes (RTSStats -> Bytes) -> IO RTSStats -> IO Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
getRTSStats
    stop :: Bytes -> IO Bytes
stop Bytes
s = do
      Bytes
s' <- Word64 -> Bytes
Bytes (Word64 -> Bytes) -> (RTSStats -> Word64) -> RTSStats -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTSStats -> Word64
allocated_bytes (RTSStats -> Bytes) -> IO RTSStats -> IO Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
getRTSStats
      Bytes -> IO Bytes
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> Bytes -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Bytes
s' Bytes -> Bytes -> Bytes
forall a. Num a => a -> a -> a
- Bytes
s
{-# INLINEABLE allocation #-}