module BenchThroughput (main) where
import qualified Throughput.BinaryBuilder as BinaryBuilder
import qualified Throughput.BinaryPut as BinaryPut
import qualified Throughput.BinaryBuilderDeclarative as BinaryBuilderDecl
import qualified Throughput.BlazeBuilder as BlazeBuilder
import qualified Throughput.BlazePut as BlazePut
import qualified Throughput.BlazeBuilderDeclarative as BlazeBuilderDecl
import Throughput.Utils
import Throughput.Memory
import qualified Data.ByteString.Lazy as L
import Debug.Trace
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Control.Exception
import Control.Monad
import System.CPUTime
import Numeric
import Text.Printf
import System.Environment
import System.IO
import Data.Maybe
import Data.Accessor
import Data.Colour
import Data.Colour.Names
import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Gtk
supportAllSizes f wS cS e i = return $ f wS cS e i
blazeLineStyle = solidLine 1 . opaque
binaryLineStyle = dashedLine 1 [5, 5] . opaque
blazeBuilder =
( "BlazeBuilder"
, blazeLineStyle green
, supportAllSizes $ BlazeBuilder.serialize)
blazeBuilderDecl =
( "BlazeBuilderDecl"
, blazeLineStyle blue
, supportAllSizes $ BlazeBuilderDecl.serialize)
blazePut =
( "BlazePut"
, blazeLineStyle red
, supportAllSizes $ BlazePut.serialize)
binaryBuilder =
( "BinaryBuilder"
, binaryLineStyle green
, supportAllSizes $ BinaryBuilder.serialize)
binaryBuilderDecl =
( "BinaryBuilderDecl"
, binaryLineStyle blue
, BinaryBuilderDecl.serialize)
binaryPut =
( "BinaryPut"
, binaryLineStyle red
, supportAllSizes $ BinaryPut.serialize)
main :: IO ()
main = do
mb <- getArgs >>= readIO . head
putStrLn ""
putStrLn "Binary serialisation benchmarks:"
let lift f wS cS e i = return $ f wS cS e i
serializers =
[ blazeBuilder , blazeBuilderDecl , blazePut
, binaryBuilder, binaryBuilderDecl, binaryPut
]
wordSizes = [1,2,4,8]
chunkSizes = [1,2,4,8,16]
endians = [Host,Big,Little]
let compares =
[ compareResults serialize wordSize chunkSize end mb
| wordSize <- wordSizes
, chunkSize <- chunkSizes
, end <- endians
, serialize <- serializers
, wordSize /= 1 || end == Host
]
let serializes =
[ [ ( serialize
, [ (chunkSize, test serialize wordSize chunkSize end mb)
| chunkSize <- [1,2,4,8,16]
]
)
| serialize <- serializers
]
| wordSize <- [1,2,4,8]
, end <- [Host,Big,Little]
, wordSize /= 1 || end == Host
]
putStrLn "\n\nbenchmarking serialization speed:"
results <- mapM mkChart serializes
print results
mkChart :: [((String,CairoLineStyle,a), [(Int, IO (Maybe Double))])] -> IO ()
mkChart task = do
lines <- catMaybes `liftM` mapM measureSerializer task
let plottedLines = flip map lines $ \ ((name,lineStyle,_), points) ->
plot_lines_title ^= name $
plot_lines_style ^= lineStyle $
plot_lines_values ^= [points] $
defaultPlotLines
let layout =
defaultLayout1
{ layout1_plots_ = map (Right . toPlot) plottedLines }
return ()
measureSerializer :: (a, [(Int, IO (Maybe Double))]) -> IO (Maybe (a, [(Int,Double)]))
measureSerializer (info, tests) = do
optPoints <- forM tests $ \ (x, test) -> do
optY <- test
case optY of
Nothing -> return Nothing
Just y -> return $ Just (x, y)
case catMaybes optPoints of
[] -> return Nothing
points -> return $ Just (info, points)
time :: IO a -> IO Double
time action = do
start <- getCPUTime
action
end <- getCPUTime
return $! (fromIntegral (end - start)) / (10^12)
test :: (String, a, Int -> Int -> Endian -> Int -> Maybe L.ByteString)
-> Int -> Int -> Endian -> Int -> IO (Maybe Double)
test (serializeName, _, serialize) wordSize chunkSize end mb = do
let bytes :: Int
bytes = mb * 2^20
iterations = bytes `div` wordSize
case serialize wordSize chunkSize end iterations of
Nothing -> return Nothing
Just bs -> do
_ <- printf "%17s: %dMB of Word%-2d in chunks of %2d (%6s endian):"
serializeName (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)
putSeconds <- time $ evaluate (L.length bs)
let putThroughput = fromIntegral mb / putSeconds
_ <- printf "%6.1f MB/s write\n"
putThroughput
hFlush stdout
return $ Just putThroughput
compareResults :: (String, a, Int -> Int -> Endian -> Int -> Maybe L.ByteString)
-> Int -> Int -> Endian -> Int -> IO ()
compareResults (serializeName, _, serialize) wordSize chunkSize end mb0 = do
let mb :: Int
mb = max 1 (mb0 `div` 100)
bytes :: Int
bytes = mb * 2^20
iterations = bytes `div` wordSize
bs0 = BinaryBuilder.serialize wordSize chunkSize end iterations
case serialize wordSize chunkSize end iterations of
Nothing -> return ()
Just bs1 -> do
_ <- printf "%17s: %dMB of Word%-2d in chunks of %2d (%6s endian):"
serializeName (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)
if (bs0 == bs1)
then putStrLn " Ok"
else putStrLn " Failed"
hFlush stdout