From 5eb27596696915af552743f2dc0feba5c6548c61 Mon Sep 17 00:00:00 2001 From: Nicolas Di Prima Date: Fri, 12 Jan 2018 17:40:11 +0000 Subject: [PATCH 1/4] improve Block concat function --- basement/Basement/Block/Base.hs | 41 +++++++++++++++------------------ 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/basement/Basement/Block/Base.hs b/basement/Basement/Block/Base.hs index 02b23c61..818e1b50 100644 --- a/basement/Basement/Block/Base.hs +++ b/basement/Basement/Block/Base.hs @@ -231,29 +231,26 @@ append a b !la = lengthBytes a !lb = lengthBytes b -concat :: [Block ty] -> Block ty -concat [] = empty -concat l = - case filterAndSum 0 [] l of - (_,[]) -> empty - (_,[x]) -> x - (totalLen,chunks) -> runST $ do - r <- unsafeNew Unpinned totalLen - doCopy r 0 chunks - unsafeFreeze r +concat :: forall ty . [Block ty] -> Block ty +concat original = runST $ do + r <- unsafeNew Unpinned total + goCopy r zero original + unsafeFreeze r where - -- TODO would go faster not to reverse but pack from the end instead - filterAndSum !totalLen acc [] = (totalLen, Data.List.reverse acc) - filterAndSum !totalLen acc (x:xs) - | len == 0 = filterAndSum totalLen acc xs - | otherwise = filterAndSum (len+totalLen) (x:acc) xs - where len = lengthBytes x - - doCopy _ _ [] = return () - doCopy r i (x:xs) = do - unsafeCopyBytesRO r i x 0 lx - doCopy r (i `offsetPlusE` lx) xs - where !lx = lengthBytes x + !total = size 0 original + -- size + size !sz [] = sz + size !sz (x:xs) = size (lengthBytes x + sz) xs + + zero = Offset 0 + + goCopy r = loop + where + loop _ [] = pure () + loop !i (x:xs) = do + unsafeCopyBytesRO r i x zero lx + loop (i `offsetPlusE` lx) xs + where !lx = lengthBytes x -- | Freeze a mutable block into a block. -- From 7ff5d82cfdefe74d1781b6ff204e709ccaf29832 Mon Sep 17 00:00:00 2001 From: Nicolas Di Prima Date: Fri, 12 Jan 2018 17:40:51 +0000 Subject: [PATCH 2/4] improve UArray concat function --- basement/Basement/UArray/Base.hs | 41 +++++++++++++++----------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/basement/Basement/UArray/Base.hs b/basement/Basement/UArray/Base.hs index 48d9e36b..10dc4e06 100644 --- a/basement/Basement/UArray/Base.hs +++ b/basement/Basement/UArray/Base.hs @@ -605,29 +605,26 @@ append a b !la = length a !lb = length b -concat :: PrimType ty => [UArray ty] -> UArray ty -concat [] = empty -concat l = - case filterAndSum (CountOf 0) [] l of - (_,[]) -> empty - (_,[x]) -> x - (totalLen,chunks) -> runST $ do - r <- new totalLen - doCopy r (Offset 0) chunks - unsafeFreeze r +concat :: forall ty . PrimType ty => [UArray ty] -> UArray ty +concat original = runST $ do + r <- new total + goCopy r 0 original + unsafeFreeze r where - -- TODO would go faster not to reverse but pack from the end instead - filterAndSum !totalLen acc [] = (totalLen, List.reverse acc) - filterAndSum !totalLen acc (x:xs) - | len == CountOf 0 = filterAndSum totalLen acc xs - | otherwise = filterAndSum (len+totalLen) (x:acc) xs - where len = length x - - doCopy _ _ [] = return () - doCopy r i (x:xs) = do - unsafeCopyAtRO r i x (Offset 0) lx - doCopy r (i `offsetPlusE` lx) xs - where lx = length x + !total = size 0 original + -- size + size !sz [] = sz + size !sz (x:xs) = size (length x + sz) xs + + zero = Offset 0 + + goCopy r = loop + where + loop _ [] = pure () + loop !i (x:xs) = do + unsafeCopyAtRO r i x zero lx + loop (i `offsetPlusE` lx) xs + where !lx = length x -- | Create a Block from a UArray. -- From 1f91c6704e5b1cecf5ce98ecc7444db4fd33e923 Mon Sep 17 00:00:00 2001 From: Nicolas Di Prima Date: Fri, 12 Jan 2018 17:41:12 +0000 Subject: [PATCH 3/4] improve Builder concat function --- basement/Basement/Block/Builder.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/basement/Basement/Block/Builder.hs b/basement/Basement/Block/Builder.hs index 5677511b..e1ddec66 100644 --- a/basement/Basement/Block/Builder.hs +++ b/basement/Basement/Block/Builder.hs @@ -60,6 +60,8 @@ instance Monoid Builder where {-# INLINE mempty #-} mappend = append {-# INLINABLE mappend #-} + mconcat = concat + {-# INLINABLE mconcat #-} -- | create an empty builder -- @@ -79,6 +81,15 @@ append (Builder size1 (Action action1)) (Builder size2 (Action action2)) = size = size1 + size2 {-# INLINABLE append #-} +-- | concatenate the list of builder +concat :: [Builder] -> Builder +concat = loop 0 (Action $ \_ !off -> pure off) + where + loop !sz acc [] = Builder sz acc + loop !sz (Action acc) (Builder !s (Action action):xs) = + loop (sz + s) (Action $ \arr off -> acc arr off >>= action arr) xs +{-# INLINABLE concat #-} + -- | run the given builder and return the generated block run :: PrimMonad prim => Builder -> prim (Block Word8) run (Builder sz action) = do From be17219d54602ebc0a4e0af4849eff0eedc4607d Mon Sep 17 00:00:00 2001 From: Nicolas Di Prima Date: Fri, 12 Jan 2018 17:41:47 +0000 Subject: [PATCH 4/4] add concat benchmark --- benchs/Fake/ByteString.hs | 3 +++ benchs/Fake/Vector.hs | 2 ++ benchs/Main.hs | 37 +++++++++++++++++++++++++++++++++++++ 3 files changed, 42 insertions(+) diff --git a/benchs/Fake/ByteString.hs b/benchs/Fake/ByteString.hs index cee50fe4..ba5afac2 100644 --- a/benchs/Fake/ByteString.hs +++ b/benchs/Fake/ByteString.hs @@ -17,6 +17,7 @@ module Fake.ByteString , readInt , readInteger , unpack + , concat ) where import Prelude (undefined, Maybe(..)) @@ -41,6 +42,8 @@ foldr _ _ _ = undefined and _ _ = undefined all _ _ = undefined any _ _ = undefined +concat :: [ByteString] -> ByteString +concat _ = undefined unpack :: ByteString -> [Word8] unpack = undefined diff --git a/benchs/Fake/Vector.hs b/benchs/Fake/Vector.hs index cc7850be..311dcd66 100644 --- a/benchs/Fake/Vector.hs +++ b/benchs/Fake/Vector.hs @@ -15,6 +15,7 @@ module Fake.Vector , and , all , any + , concat ) where import Prelude (undefined) @@ -40,3 +41,4 @@ foldr _ _ _ = undefined and _ _ = undefined all _ _ = undefined any _ _ = undefined +concat = undefined diff --git a/benchs/Main.hs b/benchs/Main.hs index 92b79a8b..9b58e6ce 100644 --- a/benchs/Main.hs +++ b/benchs/Main.hs @@ -13,6 +13,7 @@ import Foundation.String.Read import Foundation.String import BenchUtil.Common import BenchUtil.RefData +import qualified Basement.Block.Builder as Builder import Sys @@ -179,6 +180,8 @@ benchsByteArray = bgroup "ByteArray" , benchFoldr , benchReverse , benchFilter + , benchMonoidConcat + , benchBuilderBlock , benchAll , benchSort , benchSort32 @@ -204,11 +207,36 @@ benchsByteArray = bgroup "ByteArray" t = ByteString.pack dat v = Vector.fromList dat + diffListByteArray :: ([UArray Word8] -> a) + -> ([Block Word8] -> b) + -> ([ByteString.ByteString] -> c) + -> ([Vector.Vector Word8] -> d) + -> [[Word8]] + -> [Benchmark] + diffListByteArray uarrayBench blockBench bsBench vectorBench dat = + [ bench "[UArray_W8]" $ whnf uarrayBench s + , bench "[Block_W8]" $ whnf blockBench s' +#ifdef BENCH_ALL + , bench "[ByteString]" $ whnf bsBench t + , bench "[Vector_W8]" $ whnf vectorBench v +#endif + ] + where + s = fromList <$> dat + s' = fromList <$> dat + t = ByteString.pack <$> dat + v = Vector.fromList <$> dat + allDat = [ ("bs20", rdBytes20) , ("bs200", rdBytes200) , ("bs2000", rdBytes2000) ] + allListDat = + [ ("listBs20", Prelude.replicate 20 rdBytes20) + , ("listBs200", Prelude.replicate 200 rdBytes200) + , ("listBs2000", Prelude.replicate 2000 rdBytes2000) + ] allDatSuffix s = fmap (first (\x -> x <> "-" <> s)) allDat benchLength = bgroup "Length" $ @@ -270,6 +298,15 @@ benchsByteArray = bgroup "ByteArray" (ByteString.filter (> 100)) (Vector.filter (> 100)) dat) allDat + benchMonoidConcat = bgroup "Monoid/mconcat" $ + fmap (\(n, dat) -> bgroup n $ diffListByteArray mconcat mconcat ByteString.concat Vector.concat dat) allListDat + benchBuilderBlock = bgroup "Monoid/builder" $ + [ bench "[block Word8]" $ whnf builderConcat (Prelude.replicate 2000 (fromList rdBytes2000)) + ] + where + builderConcat :: [Block Word8] -> Block Word8 + builderConcat l = runST $ Builder.run $ mconcat (fmap Builder.emit l) + benchSort = bgroup "Sort" $ fmap (\(n, dat) -> bgroup n $ [ bench "UArray_W8" $ whnf uarrayBench (fromList dat)