@@ -270,7 +270,6 @@ runQC = quickCheckWith stdArgs {maxSuccess = 100} prop
270270-- Helpers
271271-------------------------------------------------------------------------------
272272
273−
274273-- Parts of "f" that are dependent on val will not be optimized out.
275274{-# INLINE loop #-}
276275loop :: Int -> (a -> IO b) -> a -> IO ()
@@ -282,16 +281,41 @@ loop count f val = go count val
282281 then f x >> go (n-1) x
283282 else return ()
284283
285−{-# INLINE poke #-}
286−poke :: SERIALIZE_CLASS a => a -> IO ()
287−poke val = do
284+-- The first arg of "f" is the environment which is not threaded around in the
285+-- loop.
286+{-# INLINE loopWith #-}
287+loopWith :: Int -> (env -> a -> IO b) -> env -> a -> IO ()
288+loopWith count f e val = go count val
289+ where
290+
291+ go n x = do
292+ if n > 0
293+ then f e x >> go (n-1) x
294+ else return ()
295+
296+{-# INLINE pokeWithSize #-}
297+pokeWithSize :: SERIALIZE_CLASS a => MutableByteArray -> a -> IO ()
298+pokeWithSize arr val = do
299+ let n = getSize val
300+ n `seq` SERIALIZE_OP 0 arr val >> return ()
301+
302+{-# INLINE pokeTimesWithSize #-}
303+pokeTimesWithSize :: SERIALIZE_CLASS a => a -> Int -> IO ()
304+pokeTimesWithSize val times = do
288305 let n = getSize val
289306 arr <- newBytes n
290− SERIALIZE_OP 0 arr val >> return ()
307+ loopWith times pokeWithSize arr val
308+
309+{-# INLINE poke #-}
310+poke :: SERIALIZE_CLASS a => MutableByteArray -> a -> IO ()
311+poke arr val = SERIALIZE_OP 0 arr val >> return ()
291312
292313{-# INLINE pokeTimes #-}
293314pokeTimes :: SERIALIZE_CLASS a => a -> Int -> IO ()
294−pokeTimes val times = loop times poke val
315+pokeTimes val times = do
316+ let n = getSize val
317+ arr <- newBytes n
318+ loopWith times poke arr val
295319
296320{-# INLINE peek #-}
297321peek :: forall a. (Eq a, SERIALIZE_CLASS a) => a -> MutableByteArray -> IO ()
@@ -299,23 +323,26 @@ peek val arr = do
299323#ifdef USE_UNBOX
300324 val1
301325#else
302− (_, val1)
326+ (_, val1 :: a)
303327#endif
304328 <- DESERIALIZE_OP 0 arr
305329 -- Ensure that we are actually constructing the type and using it.
306330 -- Otherwise we may just read the values and discard them.
307331 -- The comparison adds to the cost though.
308332 --
333+ {-
309334 if (val1 /= val)
310335 then error "peek: no match"
311336 else return ()
337+ -}
338+ return ()
312339
313340{-# INLINE peekTimes #-}
314341peekTimes :: (Eq a, SERIALIZE_CLASS a) => Int -> a -> Int -> IO ()
315342peekTimes n val times = do
316343 arr <- newBytes n
317344 _ <- SERIALIZE_OP 0 arr val
318− loop times (peek val) arr
345+ loopWith times peek val arr
319346
320347{-# INLINE trip #-}
321348trip :: forall a. (Eq a, SERIALIZE_CLASS a) => a -> IO ()
@@ -331,9 +358,12 @@ trip val = do
331358 <- DESERIALIZE_OP 0 arr
332359 assert (val == val1) (pure ())
333360 -- So that the compiler does not optimize it out
361+ {-
334362 if (val1 /= val)
335363 then error "roundtrip: no match"
336364 else return ()
365+ -}
366+ return ()
337367
338368{-# INLINE roundtrip #-}
339369roundtrip :: (Eq a, SERIALIZE_CLASS a) => a -> Int -> IO ()
@@ -346,6 +376,31 @@ benchSink name times f = bench name (nfIO (randomRIO (times, times) >>= f))
346376-- Benchmarks
347377-------------------------------------------------------------------------------
348378
379+{-# INLINE benchPoke #-}
380+benchPoke :: String -> (forall a. SERIALIZE_CLASS a =>
381+ a -> Int -> IO ()) -> BinTree Int -> [Int] -> Int -> Benchmark
382+benchPoke gname f tInt lInt times =
383+ bgroup gname
384+ [ benchSink "C1" times
385+ (f CDT1C1)
386+ , benchSink "C2" (times `div` 2)
387+ (f (CDT1C2 5))
388+ , benchSink "C3" (times `div` 3)
389+ (f (CDT1C3 5 2))
390+ , benchSink "Sum2" times
391+ (f Sum21)
392+ , benchSink "Sum25" times
393+ (f Sum2525)
394+ , benchSink "Product25" (times `div` 26)
395+ (f (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))
396+#ifndef USE_UNBOX
397+ , benchSink "bintree-int" 1
398+ (f tInt)
399+ , benchSink "list-int" 1
400+ (f lInt)
401+#endif
402+ ]
403+
349404-- Times is scaled by the number of constructors to normalize
350405#ifdef USE_UNBOX
351406allBenchmarks :: Int -> [Benchmark]
@@ -361,26 +416,8 @@ allBenchmarks tInt lInt times =
361416 , bench "list-int" $ nf sizeOfOnce lInt
362417#endif
363418 ]
364− , bgroup "poke"
365− [ benchSink "C1" times
366− (pokeTimes CDT1C1)
367− , benchSink "C2" (times `div` 2)
368− (pokeTimes (CDT1C2 5))
369− , benchSink "C3" (times `div` 3)
370− (pokeTimes (CDT1C3 5 2))
371− , benchSink "Sum2" times
372− (pokeTimes Sum21)
373− , benchSink "Sum25" times
374− (pokeTimes Sum2525)
375− , benchSink "Product25" (times `div` 26)
376− (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))
377−#ifndef USE_UNBOX
378− , benchSink "bintree-int" 1
379− (pokeTimes tInt)
380− , benchSink "list-int" 1
381− (pokeTimes lInt)
382−#endif
383− ]
419+ , benchPoke "poke" pokeTimes tInt lInt times
420+ , benchPoke "pokeWithSize" pokeTimesWithSize tInt lInt times
384421 , bgroup "peek"
385422 [ let !n = getSize Unit
386423 in benchSink "Unit" times (peekTimes n Unit)
@@ -459,14 +496,16 @@ main = do
459496 -- Check the .dump-simpl output
460497 let value = 100000
461498 -- print $ getSize (CDT1C3 4 2)
499+ -- print $ sizeOfOnce tInt
500+ -- print $ sizeOfOnce lInt
501+
502+ -- pokeTimes tInt 1
503+
462504 -- peekTimes ((CDT1C2 (5 :: Int)) :: CustomDT1) value
463505 -- peekTimes (Sum2525) value
464506 -- 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
465− -- !(tInt :: BinTree Int) <- force <$> mkBinTree 16
466− -- print $ sizeOfOnce tInt
467− -- print $ sizeOfOnce lInt
468− pokeTimes tInt 1
469507 -- peekTimes tInt 1
508+
470509 -- roundtrip ((CDT1C2 (5 :: Int)) :: CustomDT1) value
471510 return ()
472511#endif