{-# LANGUAGE ExistentialQuantification #-}
module BenchUtils where
import qualified Data.List as L
import Data.ByteString (ByteString(..))
import Data.Word
import Text.Printf
import System.IO
import Data.Text.Internal (Text(..))
import System.Mem
import System.CPUTime
import Control.Exception
import Control.Concurrent
data Result = T | B
data F a = forall b. F (a -> b) | forall b. Flist (a -> [b])
class Forceable a where
force :: a -> IO Result
force v = v `seq` return T
instance Forceable Text
seqList = L.foldl' (flip seq) (return ())
instance Forceable [a] where
force = L.foldl' (flip seq) (return T)
instance Forceable ByteString
instance Forceable Char
instance Forceable Bool
instance Forceable Int
instance Forceable Word8
instance (Forceable a, Forceable b) => Forceable (a,b) where
force (a,b) = force a >> force b
instance (Forceable a, Forceable b, Forceable c) => Forceable (a,b,c) where
force (a,b,c) = force a >> force b >> force c
run c x tests = sequence_ $ zipWith (runTest c x) [1..] tests
runTest :: Int -> a -> Int -> (String,[F a]) -> IO ()
runTest count x n (name,tests) = do
printf "%2d " n
fn tests
printf "\t# %-16s\n" (show name)
hFlush stdout
where fn xs = case xs of
[f,g,h] -> runN count f x >> putStr "\t"
>> runN count g x >> putStr "\t"
>> runN count h x >> putStr "\t"
[f,g] -> runN count f x >> putStr "\t"
>> runN count g x >> putStr "\t\t"
[f] -> runN count f x >> putStr "\t\t\t"
_ -> return ()
run f x = performGC >> threadDelay 100 >> time f x
runN 0 f x = return ()
runN c f x = run f x >> runN (c-1) f x
time (Flist f) a = do
start <- getCPUTime
v <- seqList (f a)
end <- getCPUTime
let diff = (fromIntegral (end - start)) / 10^12
printf "%0.3f" (diff :: Double)
hFlush stdout
time (F f) a = do
start <- getCPUTime
v <- evaluate (f a)
end <- getCPUTime
let diff = (fromIntegral (end - start)) / 10^12
printf "%0.3f" (diff :: Double)
hFlush stdout
app1 f (x,y,z) = f x
app2 f (x,y,z) = f y
app3 f (x,y,z) = f z