module Hyperion.Run
(
runBenchmark
, shuffle
, reorder
, filtered
, uniform
, SamplingStrategy(..)
, defaultStrategy
, fixed
, sample
, geometric
, timeBound
, geometricSeries
) where
import Control.DeepSeq
import Control.Exception (evaluate)
import Control.Lens (foldMapOf)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, bracket)
import Control.Monad.State.Class (MonadState)
import Control.Monad.State.Strict (StateT, evalStateT, get, put)
import Control.Monad.Trans (MonadTrans(..))
import Data.Int
import Data.List (mapAccumR)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (ViewL((:<)), viewl)
import qualified Data.Vector.Unboxed as Unboxed
import Hyperion.Analysis (identifiers)
import Hyperion.Benchmark
import Hyperion.Internal
import Hyperion.Measurement
import qualified System.Clock as Clock
import System.Random (RandomGen(..))
import qualified System.Random.Shuffle as SRS
import Text.Show.Functions ()
newtype StateT' s m a = StateT' { unStateT' :: StateT s m a }
deriving (Functor, Applicative, Monad, MonadCatch, MonadMask, MonadThrow, MonadState s, MonadTrans)
instance (Monad m, Monoid a) => Monoid (StateT' s m a) where
mempty = lift (return mempty)
mappend m1 m2 = mappend <$> m1 <*> m2
newtype SamplingStrategy = SamplingStrategy (Batch () -> IO Sample)
deriving (Monoid, Show)
runBenchmark
:: (BenchmarkId -> Maybe SamplingStrategy)
-> Benchmark
-> IO (HashMap BenchmarkId Sample)
runBenchmark istrategy bk0 =
evalStateT (unStateT' (go bk0)) (foldMapOf identifiers return bk0)
where
go (Bench _ batch) = do
ident <- pop
case (istrategy ident) of
Nothing -> return HashMap.empty
Just (SamplingStrategy f) ->
HashMap.singleton ident <$> lift (f batch)
go (Group _ bks) = foldMap (go) bks
go (Bracket ini fini g) =
bracket (lift (ini >>= evaluate . force)) (lift . fini) (go . g . Resource)
go (Series xs g) = foldMap (go . g) xs
pop = do
x :< xs <- viewl <$> get
put xs
return x
chrono :: IO () -> IO Int64
chrono act = do
start <- Clock.getTime Clock.Monotonic
act
end <- Clock.getTime Clock.Monotonic
return $ fromIntegral $ Clock.toNanoSecs $ Clock.diffTimeSpec start end
fixed :: Int64 -> SamplingStrategy
fixed _batchSize = SamplingStrategy $ \batch -> do
_duration <- chrono $ runBatch batch _batchSize
return $ Sample $ Unboxed.singleton Measurement{..}
sample :: Int64 -> SamplingStrategy -> SamplingStrategy
sample n strategy = mconcat $ replicate (fromIntegral n) strategy
timeBound
:: Clock.TimeSpec
-> [Int64]
-> SamplingStrategy
timeBound maxTime batchSizes = SamplingStrategy $ \batch -> do
start <- Clock.getTime Clock.Monotonic
go batch start batchSizes mempty
where
go batch start (_batchSize:bss) smpl = do
_duration <- chrono $ runBatch batch _batchSize
let smpl' = smpl `mappend` (Sample $ Unboxed.singleton Measurement{..})
now <- Clock.getTime Clock.Monotonic
if Clock.diffTimeSpec start now > maxTime
then return smpl'
else go batch start bss smpl'
go _ _ _ s = return s
uniform :: SamplingStrategy -> (BenchmarkId -> Maybe SamplingStrategy)
uniform = const . Just
filtered
:: (BenchmarkId -> Bool)
-> SamplingStrategy
-> (BenchmarkId -> Maybe SamplingStrategy)
filtered p ss bid =
if p bid then Just ss else Nothing
defaultStrategy :: SamplingStrategy
defaultStrategy = geometric 100 20 1.2
geometric
:: Int64
-> Int64
-> Double
-> SamplingStrategy
geometric nSamples limit ratio =
foldMap (\size -> sample nSamples (fixed size)) (geometricSeries ratio limit)
geometricSeries
:: Double
-> Int64
-> [Int64]
geometricSeries ratio limit =
if ratio > 1
then
takeWhile (<= limit) $
squish $
map truncate $
map (ratio^) ([1..] :: [Int])
else
error "Geometric ratio must be bigger than 1"
squish :: (Eq a) => [a] -> [a]
squish ys = foldr go [] ys
where go x xs = x : dropWhile (==x) xs
shuffle :: RandomGen g => g -> [a] -> [a]
shuffle gen xs = SRS.shuffle' xs (length xs) gen
splitn :: RandomGen g => Int -> g -> [g]
splitn n gen = snd $ mapAccumR (flip (const split)) gen [1..n]
reorder
:: RandomGen g
=> (g -> [Benchmark] -> [Benchmark])
-> (g -> [Benchmark] -> [Benchmark])
reorder shuf gen0 bks0 =
shuf gen0 (zipWith go (splitn (length bks0) gen0) bks0)
where
go _ bk@(Bench _ _) = bk
go gen (Group name bks) =
Group name (shuf gen (zipWith go (splitn (length bks) gen) bks))
go gen (Bracket ini fini f) =
Bracket ini fini (\x -> go gen (f x))
go gen (Series xs f) =
Series xs (\x -> go gen (f x))