git.iko.soy/streamly
on a819eb7 help sign in
streamly/benchmark/Streamly/Benchmark/Data/Serialize.hs
455 lines 12 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
3#undef FUSION_CHECK
4#ifdef FUSION_CHECK
5{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-}
6#endif
8-- |
9-- Module : Streamly.Benchmark.Data.Serialize
10-- Copyright : (c) 2023 Composewell
11-- License : BSD-3-Clause
12-- Maintainer : streamly@composewell.com
14module Main (main) where
16-------------------------------------------------------------------------------
17-- Imports
18-------------------------------------------------------------------------------
20import Control.DeepSeq (NFData(..))
21import Control.Exception (assert)
22import Control.Monad (replicateM_)
23import GHC.Generics (Generic)
24import System.Random (randomRIO)
25#ifndef USE_UNBOX
26import Test.QuickCheck (Arbitrary, arbitrary)
27#endif
29#ifdef USE_UNBOX
30import Data.Proxy (Proxy(..))
31import Streamly.Internal.Data.Unbox
32#else
33import Control.DeepSeq (force)
34import Test.QuickCheck (oneof, generate)
35import Streamly.Internal.Data.Unbox (newBytes)
36import Streamly.Internal.Data.Serialize
37#endif
39#ifdef USE_TH
40#ifdef USE_UNBOX
41import Streamly.Internal.Data.Unbox.TH
42#else
43import Streamly.Internal.Data.Serialize.TH
44#endif
45#endif
47import Gauge
48import Streamly.Benchmark.Common
50#ifdef USE_UNBOX
51#define SERIALIZE_CLASS Unbox
52#define DERIVE_CLASS deriveUnbox
53#define SERIALIZE_OP pokeByteIndex
54#define DESERIALIZE_OP peekByteIndex
55#else
56#define SERIALIZE_CLASS Serialize
57#define DERIVE_CLASS deriveSerialize
58#define SERIALIZE_OP serialize
59#define DESERIALIZE_OP deserialize
60#endif
62-------------------------------------------------------------------------------
63-- Types
64-------------------------------------------------------------------------------
66data Unit = Unit
67 deriving (Generic, Show, Eq)
69#ifndef USE_TH
70instance SERIALIZE_CLASS Unit
71#else
72$(DERIVE_CLASS ''Unit)
73#endif
75data Sum2
76 = Sum21
77 | Sum22
78 deriving (Generic, Show, Eq)
80#ifndef USE_TH
81instance SERIALIZE_CLASS Sum2
82#else
83$(DERIVE_CLASS ''Sum2)
84#endif
86data Sum25
87 = Sum251
88 | Sum252
89 | Sum253
90 | Sum254
91 | Sum255
92 | Sum256
93 | Sum257
94 | Sum258
95 | Sum259
96 | Sum2510
97 | Sum2511
98 | Sum2512
99 | Sum2513
100 | Sum2514
101 | Sum2515
102 | Sum2516
103 | Sum2517
104 | Sum2518
105 | Sum2519
106 | Sum2520
107 | Sum2521
108 | Sum2522
109 | Sum2523
110 | Sum2524
111 | Sum2525
112 deriving (Generic, Show, Eq)
114#ifndef USE_TH
115instance SERIALIZE_CLASS Sum25
116#else
117$(DERIVE_CLASS ''Sum25)
118#endif
120data Product25
121 = Product25
122 Int
123 Int
124 Int
125 Int
126 Int
127 Int
128 Int
129 Int
130 Int
131 Int
132 Int
133 Int
134 Int
135 Int
136 Int
137 Int
138 Int
139 Int
140 Int
141 Int
142 Int
143 Int
144 Int
145 Int
146 Int
147 deriving (Generic, Show)
149#ifndef USE_TH
150instance SERIALIZE_CLASS Product25
151#else
152$(DERIVE_CLASS ''Product25)
153#endif
155-- XXX derived Eq instance is not inlined
156instance Eq Product25 where
157 {-# INLINE (==) #-}
158 (==)
159 (Product25 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25)
160 (Product25 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25)
161 = a1 == b1
162 && a2 == b2
163 && a3 == b3
164 && a4 == b4
165 && a5 == b5
166 && a6 == b6
167 && a7 == b7
168 && a8 == b8
169 && a9 == b9
170 && a10 == b10
171 && a11 == b11
172 && a12 == b12
173 && a13 == b13
174 && a14 == b14
175 && a15 == b15
176 && a16 == b16
177 && a17 == b17
178 && a18 == b18
179 && a19 == b19
180 && a20 == b20
181 && a21 == b21
182 && a22 == b22
183 && a23 == b23
184 && a24 == b24
185 && a25 == b25
187-------------------------------------------------------------------------------
189-- Simple non-recursive ADT
190data CustomDT1
191 = CDT1C1
192 | CDT1C2 Int
193 | CDT1C3 Int Int
194 deriving (Generic, Show, Eq)
196#ifndef USE_TH
197instance SERIALIZE_CLASS CustomDT1
198#else
199$(DERIVE_CLASS ''CustomDT1)
200#endif
202-------------------------------------------------------------------------------
204{-# INLINE getSize #-}
205getSize :: forall a. SERIALIZE_CLASS a => a -> Int
206#ifdef USE_UNBOX
207getSize _ = sizeOf (Proxy :: Proxy a)
208#else
209getSize val =
210 case size :: Size a of
211 ConstSize x -> x
212 VarSize f -> f val
213#endif
215#ifndef USE_UNBOX
216{-# INLINE sizeOfOnce #-}
217sizeOfOnce :: forall a. Serialize a => a -> Int
218sizeOfOnce val = getSize val
220-- Recursive ADT
221data BinTree a
222 = Tree (BinTree a) (BinTree a)
223 | Leaf a
224 deriving (Show, Read, Eq, Generic)
226-- XXX If a is ConstSize we can use an array to represent the binary tree. If
227-- the tree is balanced space wastage would be minimum.
228#ifndef USE_TH
229instance Serialize (BinTree a)
230#else
231$(deriveSerialize ''BinTree)
232#endif
234instance NFData a => NFData (BinTree a) where
235 rnf (Leaf a) = rnf a `seq` ()
236 rnf (Tree l r) = rnf l `seq` rnf r `seq` ()
238instance Arbitrary a => Arbitrary (BinTree a) where
239 arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]
241mkBinTree :: (Arbitrary a) => Int -> IO (BinTree a)
242mkBinTree = go (generate $ arbitrary)
244 where
246 go r 0 = Leaf <$> r
247 go r n = Tree <$> go r (n - 1) <*> go r (n - 1)
249{-
250prop :: Property
251prop = forAll arbitrary (ioProperty . test)
253 where
255 test :: BinTree Int -> IO Bool
256 test t = do
257 let n =
258 case size :: Size (BinTree Int) of
259 ConstSize x -> x
260 VarSize f -> f t
261 arr <- newBytes n
262 _ <- serialize 0 arr t
263 (_, t1) <- deserialize 0 arr
264 return $ t1 == t
266runQC :: IO ()
267runQC = quickCheckWith stdArgs {maxSuccess = 100} prop
268-}
269#endif
271-------------------------------------------------------------------------------
272-- Helpers
273-------------------------------------------------------------------------------
275{-# INLINE pokeTimes #-}
276pokeTimes :: forall a. SERIALIZE_CLASS a => a -> Int -> IO ()
277pokeTimes val times = do
278 -- XXX Size computation should also be part of the loop measuring
279 -- serialization cost.
280 let n = getSize val
281 arr <- newBytes n
282 replicateM_ times $ do
283 SERIALIZE_OP 0 arr val
285{-# INLINE peekTimes #-}
286peekTimes :: forall a. (Eq a, SERIALIZE_CLASS a) => Int -> a -> Int -> IO ()
287peekTimes n val times = do
288 arr <- newBytes n
289 _ <- SERIALIZE_OP 0 arr val
290 replicateM_ times $ do
291#ifdef USE_UNBOX
292 val1
293#else
294 (_, val1)
295#endif
296 <- DESERIALIZE_OP 0 arr
297 -- Ensure that we are actually constructing the type and using it.
298 -- Otherwise we may just read the values and discard them.
299 -- The comparison adds to the cost though.
300 --
301 if (val1 /= val)
302 then error "peek: no match"
303 else return ()
305{-# INLINE roundtrip #-}
306roundtrip :: forall a. (Eq a, SERIALIZE_CLASS a) => a -> Int -> IO ()
307roundtrip val times = do
308 -- XXX Size computation should also be part of the loop measuring
309 -- serialization cost.
310 let n = getSize val
311 arr <- newBytes n
312 replicateM_ times $ do
313 _ <- SERIALIZE_OP 0 arr val
314#ifdef USE_UNBOX
315 val1
316#else
317 (_, val1)
318#endif
319 <- DESERIALIZE_OP 0 arr
320 assert (val == val1) (pure ())
321 -- So that the compiler does not optimize it out
322 if (val1 /= val)
323 then error "roundtrip: no match"
324 else return ()
326benchSink :: NFData b => String -> Int -> (Int -> IO b) -> Benchmark
327benchSink name times f = bench name (nfIO (randomRIO (times, times) >>= f))
329-------------------------------------------------------------------------------
330-- Benchmarks
331-------------------------------------------------------------------------------
333-- Times is scaled by the number of constructors to normalize
334#ifdef USE_UNBOX
335allBenchmarks :: Int -> [Benchmark]
336allBenchmarks times =
337#else
338allBenchmarks :: BinTree Int -> [Int] -> Int -> [Benchmark]
339allBenchmarks tInt lInt times =
340#endif
341 [ bgroup "sizeOf"
342 [
343#ifndef USE_UNBOX
344 bench "bintree-int" $ nf sizeOfOnce tInt
345 , bench "list-int" $ nf sizeOfOnce lInt
346#endif
347 ]
348 , bgroup "poke"
349 [ benchSink "C1" times
350 (pokeTimes CDT1C1)
351 , benchSink "C2" (times `div` 2)
352 (pokeTimes (CDT1C2 5))
353 , benchSink "C3" (times `div` 3)
354 (pokeTimes (CDT1C3 5 2))
355 , benchSink "Sum2" times
356 (pokeTimes Sum21)
357 , benchSink "Sum25" times
358 (pokeTimes Sum2525)
359 , benchSink "Product25" (times `div` 26)
360 (pokeTimes (Product25 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))
361#ifndef USE_UNBOX
362 , benchSink "bintree-int" 1
363 (pokeTimes tInt)
364 , benchSink "list-int" 1
365 (pokeTimes lInt)
366#endif
367 ]
368 , bgroup "peek"
369 [ let !n = getSize Unit
370 in benchSink "Unit" times (peekTimes n Unit)
371 , let !n = getSize CDT1C1
372 in benchSink "C1" times (peekTimes n CDT1C1)
373 , let val = CDT1C2 5
374 !n = getSize val
375 in benchSink "C2" (times `div` 2) (peekTimes n val)
376 , let val = CDT1C3 5 2
377 !n = getSize val
378 in benchSink "C3" (times `div` 3) (peekTimes n val)
379 , let !n = getSize Sum21
380 in benchSink "Sum2" times (peekTimes n Sum21)
381 , let !n = getSize Sum2525
382 in benchSink "Sum25" times (peekTimes n Sum2525)
383 , let val = Product25 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
384 !n = getSize val
385 in benchSink "Product25" (times `div` 26) (peekTimes n val)
386#ifndef USE_UNBOX
387 , let !n = getSize tInt
388 in benchSink "bintree-int" 1 (peekTimes n tInt)
389 , let !n = getSize lInt
390 in benchSink "list-int" 1 (peekTimes n lInt)
391#endif
392 ]
393 , bgroup "roundtrip"
394 [ benchSink "C1" times
395 (roundtrip CDT1C1)
396 , benchSink "C2" (times `div` 2)
397 (roundtrip (CDT1C2 5))
398 , benchSink "C3" (times `div` 3)
399 (roundtrip (CDT1C3 5 2))
400 , benchSink "Sum2" times
401 (roundtrip Sum21)
402 , benchSink "Sum25" times
403 (roundtrip Sum2525)
404 , benchSink "Product25" (times `div` 26)
405 (roundtrip (Product25 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))
406#ifndef USE_UNBOX
407 , benchSink "bintree-int" 1
408 (roundtrip tInt)
409 , benchSink "list-int" 1
410 (roundtrip lInt)
411#endif
412 ]
413 ]
415-------------------------------------------------------------------------------
416-- Driver
417-------------------------------------------------------------------------------
419main :: IO ()
420main = do
421#ifndef USE_UNBOX
422 -- Approximately 100000 constructors
423 -- Assuming Leaf nodes constitute two constructors (Leaf, Int) and internal
424 -- nodes 1 level = log_2 (100001/3) + 1 = 16
425 !tInt <- force <$> mkBinTree 16
427 -- Approximately 100000 constructors, assuming two constructors (Cons, Int)
428 -- per element.
429 let lInt = [1..50000 :: Int]
430 let !len = length lInt -- evaluate the list
431#endif
432#ifndef FUSION_CHECK
433 -- This can take too much memory/CPU, need to restrict the test
434 -- runQC
435#ifdef USE_UNBOX
436 runWithCLIOpts defaultStreamSize allBenchmarks
437#else
438 len `seq` runWithCLIOpts defaultStreamSize (allBenchmarks tInt lInt)
439#endif
440#else
441 -- Enable FUSION_CHECK macro at the beginning of the file
442 -- Enable one benchmark below, and run the benchmark
443 -- Check the .dump-simpl output
444 let value = 100000
445 -- peekTimes ((CDT1C2 (5 :: Int)) :: CustomDT1) value
446 -- peekTimes (Sum2525) value
447 -- peekTimes (Product25 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) value
448 -- !(tInt :: BinTree Int) <- force <$> mkBinTree 16
449 -- print $ sizeOfOnce tInt
450 -- peekTimes tInt 1
451 -- roundtrip ((CDT1C2 (5 :: Int)) :: CustomDT1) value
452 let !n = getSize lEnum
453 in peekTimes n lEnum 1
454 return ()
455#endif