-
Notifications
You must be signed in to change notification settings - Fork 22
/
BenchThroughput.hs
240 lines (201 loc) · 7.29 KB
/
BenchThroughput.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
-----------------------------------------------------------------------------
-- |
-- Module : BenchThroughput
-- Copyright : Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Simon Meier <iridcode@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-- This benchmark is based on 'tests/Benchmark.hs' from the 'binary-0.5.0.2'
-- package.
--
-- Benchmark the throughput of 'blaze-builder' and 'binary' for serializing
-- sequences of 'Word8' .. 'Word64' values in little-endian, big-endian, and
-- "host-endian" formats.
--
-- The results on a Core2 Duo T7500 with Linux 2.6.32-24 i686 and GHC 6.12.3
-- are as follows:
--
-- Using the Blaze.Builder directly (i.e. not encapsulated in a writer monad
-- as Put is doing it) gives the best scalability. Up to 'Word32', it holds
-- that the bigger the chunk size, the bigger the relative speedup of using
-- the Blaze.Builder. For 'Word64', the speedup is not as impressive.
-- Probably due to the more expensive writes.
--
-----------------------------------------------------------------------------
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
-- The different serialization functions
----------------------------------------
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
-- memBench (mb*10)
putStrLn ""
putStrLn "Binary serialisation benchmarks:"
-- do bytewise
-- sequence_
-- [ test wordSize chunkSize Host mb
-- | wordSize <- [1]
-- , chunkSize <- [1,2,4,8,16]
-- ]
-- now Word16 .. Word64
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 -- no endianess for Word8
]
-- putStrLn "checking equality of serialization results:"
-- sequence_ compares
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 -- no endianess for Word8
]
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 ()
-- renderableToWindow (toRenderable layout) 640 480
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)
-- getSeconds <- time $ evaluate sum
-- print (L.length bs, sum)
let putThroughput = fromIntegral mb / putSeconds
-- getThroughput = fromIntegral mb / getSeconds
_ <- printf "%6.1f MB/s write\n"
putThroughput
-- getThroughput
-- (getThroughput/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