Permalink
Browse files

slight improvement 5% for Data.Tree encoding

  • Loading branch information...
1 parent 7bde440 commit 6399fc4f1137d5f353ec0e1c1a7886523a261271 @meiersi meiersi committed Apr 27, 2012
Showing with 28 additions and 5 deletions.
  1. +17 −1 bench/Benchmark.hs
  2. +11 −4 src/Data/Serialize/Put.hs
View
@@ -20,6 +20,7 @@ import Data.Binary (Binary)
import qualified Data.Binary as Binary
import qualified Data.Sequence as Seq
+import Data.Tree
------------------------------------------------------------------------------
@@ -44,12 +45,27 @@ stringData n = take n $ cycle ["hello", "world"]
seqIntData :: Int -> Seq.Seq Int
seqIntData = Seq.fromList . intData
+-- | Build a balanced binary tree.
+{-# NOINLINE treeIntData #-}
+treeIntData :: Int -> Tree Int
+treeIntData n =
+ head $ go [0..n] -- assuming n >= 0
+ where
+ go [] = []
+ go [x] = [Node x []]
+ go xs =
+ [Node r $ concatMap go [ls, rs]]
+ where
+ (ls, r:rs) = splitAt (length xs `div` 2) xs
+
+
-- benchmarks
-------------
main :: IO ()
main = Criterion.Main.defaultMain $
- [ benchmarks "Seq Int memoized " id (seqIntData nRepl)
+ [ benchmarks "Tree Int memoized " id (treeIntData nRepl)
+ , benchmarks "Seq Int memoized " id (seqIntData nRepl)
, benchmarks "[Int] memoized " id (intData nRepl)
, benchmarks "[Int] generated " intData nRepl
, benchmarks "[String] memoized" id (stringData nRepl)
View
@@ -252,14 +252,18 @@ putWord64host = tell . B.putWord64host
-- Containers ------------------------------------------------------------------
+encodeListOf :: (a -> Builder) -> [a] -> Builder
+encodeListOf f = -- allow inlining with just a single argument
+ \xs -> execPut (putWord64be (fromIntegral $ length xs)) `mappend`
+ foldMap f xs
+{-# INLINE encodeListOf #-}
+
putTwoOf :: Putter a -> Putter b -> Putter (a,b)
putTwoOf pa pb (a,b) = pa a >> pb b
{-# INLINE putTwoOf #-}
putListOf :: Putter a -> Putter [a]
-putListOf pa = \xs -> do
- putWord64be (fromIntegral $ length xs)
- tell (foldMap (execPut . pa) xs)
+putListOf pa = tell . encodeListOf (execPut . pa)
{-# INLINE putListOf #-}
putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e)
@@ -275,7 +279,10 @@ putSeqOf pa = \s -> do
{-# INLINE putSeqOf #-}
putTreeOf :: Putter a -> Putter (T.Tree a)
-putTreeOf pa (T.Node r s) = pa r >> putListOf (putTreeOf pa) s
+putTreeOf pa =
+ tell . go
+ where
+ go (T.Node x cs) = execPut (pa x) `mappend` encodeListOf go cs
{-# INLINE putTreeOf #-}
putMapOf :: Ord k => Putter k -> Putter a -> Putter (Map.Map k a)

0 comments on commit 6399fc4

Please sign in to comment.