git.iko.soy/streamly
on a11fe00 help sign in
streamly/benchmark/Streamly/Benchmark/Data/Serialize.hs
605 lines 16 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(..), deepseq)
21import GHC.Generics (Generic)
22import System.Random (randomRIO)
23#ifndef USE_UNBOX
24import Test.QuickCheck (Arbitrary, arbitrary)
25#endif
27#ifdef USE_UNBOX
28import Data.Proxy (Proxy(..))
29import Streamly.Internal.Data.Unbox
30#else
31import Control.DeepSeq (force)
32import Test.QuickCheck (oneof, generate)
33import Streamly.Internal.Data.Unbox (newBytes, MutableByteArray)
34import Streamly.Internal.Data.Serialize hiding (encode)
35#endif
37#ifdef USE_TH
38#ifdef USE_UNBOX
39import Streamly.Internal.Data.Unbox.TH
40#else
41import Streamly.Internal.Data.Serialize.TH
42#endif
43#endif
45import Gauge
46import Streamly.Benchmark.Common
48#ifndef USE_UNBOX
49import Streamly.Benchmark.Data.Serialize.RecCompatible
50import Streamly.Benchmark.Data.Serialize.RecNonCompatible
51#endif
53#ifdef USE_UNBOX
54#define SERIALIZE_CLASS Unbox
55#define DERIVE_CLASS deriveUnbox
56#define SERIALIZE_OP pokeByteIndex
57#define DESERIALIZE_OP peekByteIndex
58#else
59#define SERIALIZE_CLASS Serialize
60#define DERIVE_CLASS deriveSerialize
61#define SERIALIZE_OP serialize
62#define DESERIALIZE_OP deserialize
63#endif
65-------------------------------------------------------------------------------
66-- Types
67-------------------------------------------------------------------------------
69data Unit = Unit
70 deriving (Generic, Show, Eq)
72#ifndef USE_TH
73instance SERIALIZE_CLASS Unit
74#else
75$(DERIVE_CLASS ''Unit)
76#endif
78instance NFData Unit where
79 {-# INLINE rnf #-}
80 rnf _ = ()
82data Sum2
83 = Sum21
84 | Sum22
85 deriving (Generic, Show, Eq)
87#ifndef USE_TH
88instance SERIALIZE_CLASS Sum2
89#else
90$(DERIVE_CLASS ''Sum2)
91#endif
93instance NFData Sum2 where
94 {-# INLINE rnf #-}
95 rnf _ = ()
97data Sum25
98 = Sum251
99 | Sum252
100 | Sum253
101 | Sum254
102 | Sum255
103 | Sum256
104 | Sum257
105 | Sum258
106 | Sum259
107 | Sum2510
108 | Sum2511
109 | Sum2512
110 | Sum2513
111 | Sum2514
112 | Sum2515
113 | Sum2516
114 | Sum2517
115 | Sum2518
116 | Sum2519
117 | Sum2520
118 | Sum2521
119 | Sum2522
120 | Sum2523
121 | Sum2524
122 | Sum2525
123 deriving (Generic, Show, Eq)
125#ifndef USE_TH
126instance SERIALIZE_CLASS Sum25
127#else
128$(DERIVE_CLASS ''Sum25)
129#endif
131instance NFData Sum25 where
132 {-# INLINE rnf #-}
133 rnf _ = ()
135data Product25
136 = Product25
137 Int
138 Int
139 Int
140 Int
141 Int
142 Int
143 Int
144 Int
145 Int
146 Int
147 Int
148 Int
149 Int
150 Int
151 Int
152 Int
153 Int
154 Int
155 Int
156 Int
157 Int
158 Int
159 Int
160 Int
161 Int
162 deriving (Generic, Show)
164#ifndef USE_TH
165instance SERIALIZE_CLASS Product25
166#else
167$(DERIVE_CLASS ''Product25)
168#endif
170instance NFData Product25 where
171 {-# INLINE rnf #-}
172 rnf
173 (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)
174 = a1
175 `seq` a2
176 `seq` a3
177 `seq` a4
178 `seq` a5
179 `seq` a6
180 `seq` a7
181 `seq` a8
182 `seq` a9
183 `seq` a10
184 `seq` a11
185 `seq` a12
186 `seq` a13
187 `seq` a14
188 `seq` a15
189 `seq` a16
190 `seq` a17
191 `seq` a18
192 `seq` a19
193 `seq` a20
194 `seq` a21
195 `seq` a22
196 `seq` a23
197 `seq` a24
198 `seq` a25
199 `seq` ()
201-- XXX derived Eq instance is not inlined
202instance Eq Product25 where
203 {-# INLINE (==) #-}
204 (==)
205 (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)
206 (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)
207 = a1 == b1
208 && a2 == b2
209 && a3 == b3
210 && a4 == b4
211 && a5 == b5
212 && a6 == b6
213 && a7 == b7
214 && a8 == b8
215 && a9 == b9
216 && a10 == b10
217 && a11 == b11
218 && a12 == b12
219 && a13 == b13
220 && a14 == b14
221 && a15 == b15
222 && a16 == b16
223 && a17 == b17
224 && a18 == b18
225 && a19 == b19
226 && a20 == b20
227 && a21 == b21
228 && a22 == b22
229 && a23 == b23
230 && a24 == b24
231 && a25 == b25
233-------------------------------------------------------------------------------
234-- Simple non-recursive ADT
235-------------------------------------------------------------------------------
237{-
238data CustomDT1
239 = CDT1C1
240 | CDT1C2 Int
241 | CDT1C3 Int Int
242 deriving (Generic, Show, Eq)
244#ifndef USE_TH
245instance SERIALIZE_CLASS CustomDT1
246#else
247$(DERIVE_CLASS ''CustomDT1)
248#endif
250instance NFData CustomDT1 where
251 {-# INLINE rnf #-}
252 rnf CDT1C1 = ()
253 rnf (CDT1C2 i) = i `seq` ()
254 rnf (CDT1C3 i1 i2) = i1 `seq` i2 `seq` ()
255-}
257-------------------------------------------------------------------------------
258-- Recursive ADT
259-------------------------------------------------------------------------------
261#ifndef USE_UNBOX
262data BinTree a
263 = Tree (BinTree a) (BinTree a)
264 | Leaf a
265 deriving (Show, Read, Eq, Generic)
267#ifndef USE_TH
268instance Serialize (BinTree a)
269#else
270$(deriveSerialize ''BinTree)
271#endif
273instance NFData a => NFData (BinTree a) where
274 {-# INLINE rnf #-}
275 rnf (Leaf a) = rnf a `seq` ()
276 rnf (Tree l r) = rnf l `seq` rnf r `seq` ()
278instance Arbitrary a => Arbitrary (BinTree a) where
279 arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]
281mkBinTree :: (Arbitrary a) => Int -> IO (BinTree a)
282mkBinTree = go (generate $ arbitrary)
284 where
286 go r 0 = Leaf <$> r
287 go r n = Tree <$> go r (n - 1) <*> go r (n - 1)
289#endif
291-------------------------------------------------------------------------------
292-- Size helpers
293-------------------------------------------------------------------------------
295{-# INLINE getSize #-}
296getSize :: forall a. SERIALIZE_CLASS a => a -> Int
297#ifdef USE_UNBOX
298getSize _ = sizeOf (Proxy :: Proxy a)
299#else
300getSize = size 0
301#endif
303-------------------------------------------------------------------------------
304-- Common helpers
305-------------------------------------------------------------------------------
307-- Parts of "f" that are dependent on val will not be optimized out.
308{-# INLINE loop #-}
309loop :: Int -> (a -> IO b) -> a -> IO ()
310loop count f val = go count val
311 where
313 go n x = do
314 if n > 0
315 then f x >> go (n-1) x
316 else return ()
318-- The first arg of "f" is the environment which is not threaded around in the
319-- loop.
320{-# INLINE loopWith #-}
321loopWith :: Int -> (e -> a -> IO b) -> e -> a -> IO ()
322loopWith count f e val = go count val
323 where
325 go n x = do
326 if n > 0
327 then f e x >> go (n-1) x
328 else return ()
330benchSink :: NFData b => String -> Int -> (Int -> IO b) -> Benchmark
331benchSink name times f = bench name (nfIO (randomRIO (times, times) >>= f))
333-------------------------------------------------------------------------------
334-- Serialization Helpers
335-------------------------------------------------------------------------------
337{-
338{-# INLINE pokeWithSize #-}
339pokeWithSize :: SERIALIZE_CLASS a => MutableByteArray -> a -> IO ()
340pokeWithSize arr val = do
341 let n = getSize val
342 n `seq` SERIALIZE_OP 0 arr val >> return ()
344{-# INLINE pokeTimesWithSize #-}
345pokeTimesWithSize :: SERIALIZE_CLASS a => a -> Int -> IO ()
346pokeTimesWithSize val times = do
347 let n = getSize val
348 arr <- newBytes n
349 loopWith times pokeWithSize arr val
350-}
352{-# INLINE poke #-}
353poke :: SERIALIZE_CLASS a => MutableByteArray -> a -> IO ()
354poke arr val = SERIALIZE_OP 0 arr val >> return ()
356{-# INLINE pokeTimes #-}
357pokeTimes :: SERIALIZE_CLASS a => a -> Int -> IO ()
358pokeTimes val times = do
359 let n = getSize val
360 arr <- newBytes n
361 loopWith times poke arr val
363{-# INLINE encode #-}
364encode :: SERIALIZE_CLASS a => a -> IO ()
365encode val = do
366 let n = getSize val
367 arr <- newBytes n
368 SERIALIZE_OP 0 arr val >> return ()
370{-# INLINE encodeTimes #-}
371encodeTimes :: SERIALIZE_CLASS a => a -> Int -> IO ()
372encodeTimes val times = loop times encode val
374{-# INLINE peek #-}
375peek :: forall a. (NFData a, SERIALIZE_CLASS a) =>
376 (a, Int) -> MutableByteArray -> IO ()
377#ifdef USE_UNBOX
378peek (_val, _) arr = do
379 (val1 :: a) <- DESERIALIZE_OP 0 arr
380#else
381peek (_val, n) arr = do
382 (_, val1 :: a) <- DESERIALIZE_OP 0 arr n
383#endif
384 -- If the datatype is not deeply strict or deepseq is not used then use
385 -- Equality.
386 -- Ensure that we are actually constructing the type and using it. This
387 -- is important, otherwise the structure is created and discarded, the
388 -- cost of creation of the structure is not accounted. Otherwise we may
389 -- just read the values and discard them. The comparison adds to the
390 -- cost though. We could use deepseq but then we need to write
391 -- instances of NFData and ensure that they are correct and perform
392 -- well. Equality check also ensures correctness.
393 {-
394 if (val1 /= val)
395 then error "peek: no match"
396 else return ()
397 -}
398 val1 `deepseq` return ()
400{-# INLINE peekTimes #-}
401peekTimes :: (NFData a, SERIALIZE_CLASS a) => Int -> a -> Int -> IO ()
402peekTimes n val times = do
403 arr <- newBytes n
404 _ <- SERIALIZE_OP 0 arr val
405 loopWith times peek (val, n) arr
407{-# INLINE trip #-}
408trip :: forall a. (NFData a, SERIALIZE_CLASS a) => a -> IO ()
409trip val = do
410 let n = getSize val
411 arr <- newBytes n
412 _ <- SERIALIZE_OP 0 arr val
413#ifdef USE_UNBOX
414 (val1 :: a) <- DESERIALIZE_OP 0 arr
415#else
416 (_, val1 :: a) <- DESERIALIZE_OP 0 arr n
417#endif
418 -- Do not remove this or use deepseq, see the comments in peek.
419 {-
420 if (val1 /= val)
421 then error "roundtrip: no match"
422 else return ()
423 -}
424 -- Note: deepseq is not needed if the datatype is strict
425 val1 `deepseq` return ()
427{-# INLINE roundtrip #-}
428roundtrip :: (NFData a, SERIALIZE_CLASS a) => a -> Int -> IO ()
429roundtrip val times = loop times trip val
431-------------------------------------------------------------------------------
432-- Benchmarks
433-------------------------------------------------------------------------------
435{-# INLINE benchConst #-}
436benchConst ::
437 String
438 -> (forall a. (NFData a, SERIALIZE_CLASS a) =>
439 Int -> a -> Int -> IO ())
440 -> Int
441 -> Benchmark
442benchConst gname f times =
443 bgroup gname
444 [ let !n = getSize Unit
445 in benchSink "Unit" times (f n Unit)
446 {-
447 , let !n = getSize CDT1C1
448 in benchSink "C1" times (f n CDT1C1)
449 , let val = CDT1C2 5
450 !n = getSize val
451 in benchSink "C2" (times `div` 2) (f n val)
452 , let val = CDT1C3 5 2
453 !n = getSize val
454 in benchSink "C3" (times `div` 3) (f n val)
455 -}
456 , let !n = getSize Sum21
457 in benchSink "Sum2" times (f n Sum21)
458 , let !n = getSize Sum2525
459 in benchSink "Sum25" times (f n Sum2525)
460 , 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
461 !n = getSize val
462 in benchSink "Product25" (times `div` 26) (f n val)
463 ]
465#ifndef USE_UNBOX
466{-# INLINE benchVar #-}
467benchVar ::
468 String
469 -> (forall a. (NFData a, SERIALIZE_CLASS a) =>
470 Int -> a -> Int -> IO ())
471 -> BinTree Int
472 -> [Int]
473 -> Int
474 -> Benchmark
475benchVar gname f tInt lInt times =
476 bgroup gname
477 [ let !n = getSize tInt
478 in benchSink "bintree-int" times (f n tInt)
479 , let !n = getSize lInt
480 in benchSink "list-int" times (f n lInt)
481 ]
483{-
484{-# INLINE benchGeneric #-}
485benchGeneric
486 :: (NFData b, Serialize b)
487 => String
488 -> String
489 -> (forall a. (NFData a, Serialize a) =>
490 Int -> a -> Int -> IO ())
491 -> b
492 -> Int
493 -> Benchmark
494benchGeneric gname valId f val times =
495 bgroup gname
496 [ let !n = getSize val
497 in benchSink valId times (f n val)
498 ]
499-}
501{-# INLINE benchLargeRec #-}
502benchLargeRec ::
503 String
504 -> (forall a. (NFData a, Serialize a) =>
505 Int -> a -> Int -> IO ())
506 -> RecNonCompatible
507 -> RecCompatible
508 -> Int
509 -> Benchmark
510benchLargeRec gname f recL recR times =
511 bgroup gname
512 [ let !n = getSize recL
513 in benchSink "RecNonCompatible" times (f n recL)
514 , let !n = getSize recR
515 in benchSink "RecCompatible" times (f n recR)
516 ]
517#endif
519-- Times is scaled by the number of constructors to normalize
520#ifdef USE_UNBOX
521allBenchmarks :: Int -> [Benchmark]
522allBenchmarks times =
523#else
524allBenchmarks ::
525 BinTree Int -> [Int] -> RecNonCompatible -> RecCompatible -> Int -> [Benchmark]
526allBenchmarks tInt lInt recL recR times =
527#endif
528 [ bgroup "sizeOf"
529 [
530#ifndef USE_UNBOX
531 bench "bintree-int" $ nf getSize tInt
532 , bench "list-int" $ nf getSize lInt
533#endif
534 ]
535 , benchConst "poke" (const pokeTimes) times
536 -- , benchConst "pokeWithSize" (const pokeTimesWithSize) times
537 , benchConst "encode" (const encodeTimes) times
538 , benchConst "peek" peekTimes times
539 , benchConst "roundtrip" (const roundtrip) times
540#ifndef USE_UNBOX
541 , benchVar "poke" (const pokeTimes) tInt lInt 1
542 -- , benchVar "pokeWithSize" (const pokeTimesWithSize) tInt lInt 1
543 , benchVar "encode" (const encodeTimes) tInt lInt 1
544 , benchVar "peek" peekTimes tInt lInt 1
545 , benchVar "roundtrip" (const roundtrip) tInt lInt 1
546 , benchLargeRec "poke" (const pokeTimes) recL recR times
547 , benchLargeRec "encode" (const encodeTimes) recL recR times
548 , benchLargeRec "peek" peekTimes recL recR times
549 , benchLargeRec "roundtrip" (const roundtrip) recL recR times
550#endif
551 ]
553-------------------------------------------------------------------------------
554-- Driver
555-------------------------------------------------------------------------------
557main :: IO ()
558main = do
559#ifndef USE_UNBOX
560 -- Approximately 100000 constructors
561 -- Assuming Leaf nodes constitute two constructors (Leaf, Int) and internal
562 -- nodes 1 level = log_2 (100001/3) + 1 = 16
563 !(tInt :: BinTree Int) <- force <$> mkBinTree 16
565 let !recL = valRecNonCompatible
566 let !recR = valRecCompatible
568 -- Approximately 100000 constructors, assuming two constructors (Cons, Int)
569 -- per element.
570 let lInt = [1..50000 :: Int]
571 let !len = length lInt -- evaluate the list
572#endif
573#ifndef FUSION_CHECK
574 -- This can take too much memory/CPU, need to restrict the test
575 -- runQC
576#ifdef USE_UNBOX
577 runWithCLIOpts defaultStreamSize allBenchmarks
578#else
579 len
580 `seq` runWithCLIOpts
581 defaultStreamSize
582 (allBenchmarks tInt lInt recL recR)
584#endif
585#else
586 -- Enable FUSION_CHECK macro at the beginning of the file
587 -- Enable one benchmark below, and run the benchmark
588 -- Check the .dump-simpl output
589 let value = 100000
590 -- print $ getSize (CDT1C3 4 2)
591 -- print $ getSize tInt
592 -- print $ getSize lInt
594 -- pokeTimes tInt 1
596 -- peekTimes ((CDT1C2 (5 :: Int)) :: CustomDT1) value
597 -- peekTimes (Sum2525) value
598 -- 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
599 -- peekTimes tInt 1
600 let !n = getSize lInt
601 peekTimes n lInt 1
603 -- roundtrip ((CDT1C2 (5 :: Int)) :: CustomDT1) value
604 return ()
605#endif