From f716a6f5746d09b79a0efdc2256fecf72cf53cca Mon Sep 17 00:00:00 2001 From: Dorus Leliveld Date: Sat, 10 Dec 2016 19:28:00 -0600 Subject: [PATCH 1/6] Benching suite to illustrate performance gains --- Graphics/Sudbury/WirePackages.hs | 4 +- bench/Main.hs | 103 +++++++++++++++++++++++++++++++ sudbury.cabal | 16 +++++ 3 files changed, 122 insertions(+), 1 deletion(-) create mode 100644 bench/Main.hs diff --git a/Graphics/Sudbury/WirePackages.hs b/Graphics/Sudbury/WirePackages.hs index 4e2ab8d..f812c6d 100644 --- a/Graphics/Sudbury/WirePackages.hs +++ b/Graphics/Sudbury/WirePackages.hs @@ -8,10 +8,12 @@ Stability : experimental Portability : POSIX -} {-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} module Graphics.Sudbury.WirePackages where import Data.Word import Data.Monoid ((<>)) +import GHC.Generics import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Extra as BBE @@ -24,7 +26,7 @@ data WirePackage = WirePackage , wirePackageSize :: Word16 , wirePackageOpcode :: Word16 , wirePackagePayload :: B.ByteString - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | Construct a wayland wire wirePackage wirePack :: WirePackage -> BB.Builder diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 index 0000000..d14aaf6 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,103 @@ +module Main where + +import Criterion.Main +import Graphics.Sudbury.WirePackages +import Test.QuickCheck +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Builder as BB +import Data.Store +import Data.Store.Core +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Attoparsec.ByteString +import Control.DeepSeq +import Data.Word +import Debug.Trace + +-- Duplicate from tests/Arbitrary.hs. Should think of a better +-- solution in due time +instance Arbitrary B.ByteString where + arbitrary = do + someBytes <- arbitrary + return . toStrict . toLazyByteString . mconcat $ map BB.word8 someBytes + +instance Arbitrary WirePackage where + arbitrary = do + sender <- arbitrary + opcode <- arbitrary + payloadSize <- elements ([20..200] :: [Int]) + payload <- B.pack <$> vectorOf payloadSize (arbitrary :: Gen Word8) + let size = fromIntegral $ 8 + payloadSize + return WirePackage + { wirePackageSender = sender + , wirePackageSize = size + , wirePackageOpcode = opcode + , wirePackagePayload = payload + } + +randomWirePackage :: IO [WirePackage] +randomWirePackage = generate $ vectorOf 10000 (arbitrary :: Gen WirePackage) + +randomByteString :: IO [B.ByteString] +randomByteString = fmap (map encodeBS) randomWirePackage + +decodeAtto :: B.ByteString -> Either String WirePackage +decodeAtto = parseOnly parseWirePackage + +encodeBS :: WirePackage -> B.ByteString +encodeBS = toStrict . toLazyByteString . wirePack + +decodedWorking = do + a <- randomWirePackage + print $ map (decodeEx . encodeBS) a == a + +encodedWorking = do + a <- randomByteString + print $ map (encode . fromRight . decodeAtto) a == a + +fromRight (Right a) = a + +instance NFData WirePackage + +toInt :: Integral a => a -> Int +toInt = fromInteger . toInteger +{-# INLINE toInt #-} + +instance Store WirePackage where + size = VarSize $ toInt . wirePackageSize + poke (WirePackage sen size op pl) = do + poke sen + poke op + poke size + let (sourceFp, sourceOffset, sourceLength) = B.toForeignPtr pl + pokeFromForeignPtr sourceFp sourceOffset sourceLength + peek = do + sen <- peek + op <- peek + size <- peek + let payloadSize = toInt size - 8 + pl <- peekToPlainForeignPtr "Data.ByteString.ByteString" payloadSize + return $ WirePackage sen size op (B.PS pl 0 payloadSize) + {-# INLINE size #-} + {-# INLINE peek #-} + {-# INLINE poke #-} + +main = do + rb <- randomByteString + rw <- randomWirePackage + rb `deepseq` return () + rw `deepseq` return () + let decodeEx' = decodeEx :: B.ByteString -> WirePackage + defaultMain + [ bgroup "parse_random" + [ bench "id" $ nf (map id) rb + , bench "storeable" $ nf (map decodeEx') rb + , bench "attoParsec1" $ nf (map decodeAtto) rb + ] + , bgroup "encod_random" + [ bench "id" $ nf (map id) rw + , bench "storeable" $ nf (map encode) rw + , bench "BS.Builder" $ nf (map encodeBS) rw + ] + ] diff --git a/sudbury.cabal b/sudbury.cabal index ebf60b8..6e28b42 100644 --- a/sudbury.cabal +++ b/sudbury.cabal @@ -108,6 +108,22 @@ foreign-library wayland-client default-language: Haskell2010 ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-unused-do-bind +benchmark serial-bench-bench + hs-source-dirs: bench + type: exitcode-stdio-1.0 + main-is: Main.hs + ghc-options: -rtsopts -O2 + build-depends: base + , sudbury + , criterion + , QuickCheck + , deepseq + , bytestring + , attoparsec + , store + , store-core + default-language: Haskell2010 + test-suite tests hs-source-dirs: tests main-is: Main.hs From f26ffb710f9d23875dec069c45b1e510eaa189de Mon Sep 17 00:00:00 2001 From: Dorus Leliveld Date: Sat, 10 Dec 2016 19:38:57 -0600 Subject: [PATCH 2/6] Parsing using the Storable (Data.Store) Implemented the Storable typeclass from Data.Store. Was implemented in such a way that all the machinery from Data.Store can be used to efficiently encode and decode the Wayland ByteString format. --- Graphics/Sudbury/CABI/Client.hs | 5 ++- Graphics/Sudbury/WireMessages.hs | 1 - Graphics/Sudbury/WirePackages.hs | 70 +++++++++++++++----------------- sudbury.cabal | 7 +++- tests/Wire.hs | 9 +--- 5 files changed, 43 insertions(+), 49 deletions(-) diff --git a/Graphics/Sudbury/CABI/Client.hs b/Graphics/Sudbury/CABI/Client.hs index e54882b..b16bcd4 100644 --- a/Graphics/Sudbury/CABI/Client.hs +++ b/Graphics/Sudbury/CABI/Client.hs @@ -26,6 +26,7 @@ import Foreign.Storable import System.Posix.Types (Fd(..)) import Network.Socket (fdSocket) import Data.Attoparsec.ByteString +import qualified Data.Store as S import System.IO.Unsafe import Graphics.Sudbury.Argument @@ -944,11 +945,11 @@ display_read_events proxyP = withStablePtr proxyP $ \proxy -> do fd_queue <- newTQueueIO atomically $ mapM_ (writeTQueue fd_queue) fds - let pkgsParse = parseOnly pkgStream bytes + let pkgsParse = (S.decode bytes :: Either S.PeekException [WirePackage]) pkgs <- case pkgsParse of Left err -> - error ("Package parse failed: " ++ err) + error ("Package parse failed: " ++ show err) Right x -> return x mapM_ (queue_package dd fd_queue) pkgs diff --git a/Graphics/Sudbury/WireMessages.hs b/Graphics/Sudbury/WireMessages.hs index 3e61e0f..6d5b8fe 100644 --- a/Graphics/Sudbury/WireMessages.hs +++ b/Graphics/Sudbury/WireMessages.hs @@ -6,7 +6,6 @@ License : MIT Maintainer : auke@tulcod.com Stability : experimental -} -{-# LANGUAGE Safe #-} module Graphics.Sudbury.WireMessages where import Data.Fixed diff --git a/Graphics/Sudbury/WirePackages.hs b/Graphics/Sudbury/WirePackages.hs index 4e2ab8d..750487e 100644 --- a/Graphics/Sudbury/WirePackages.hs +++ b/Graphics/Sudbury/WirePackages.hs @@ -7,17 +7,15 @@ Maintainer : auke@tulcod.com Stability : experimental Portability : POSIX -} -{-# LANGUAGE Safe #-} module Graphics.Sudbury.WirePackages where import Data.Word -import Data.Monoid ((<>)) +import Data.Store +import Data.Store.Core import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Builder.Extra as BBE -import qualified Data.Attoparsec.ByteString as A -import Graphics.Sudbury.Internal data WirePackage = WirePackage { wirePackageSender :: Word32 @@ -26,37 +24,33 @@ data WirePackage = WirePackage , wirePackagePayload :: B.ByteString } deriving (Eq, Show) --- | Construct a wayland wire wirePackage -wirePack :: WirePackage -> BB.Builder -wirePack msg = wirePackBuilder - (wirePackageSender msg) - (wirePackageSize msg) - (wirePackageOpcode msg) - (BB.byteString $ wirePackagePayload msg) - --- | Construct a wayland wire wirePackage with payload given as a 'Builder'. -wirePackBuilder :: Word32 -> Word16 -> Word16 -> BB.Builder -> BB.Builder -wirePackBuilder sender size opcode payload = - BBE.word32Host sender - <> - -- FIXME make byte order portable here - BBE.word16Host opcode - <> - BBE.word16Host size - <> - payload +-- Storable that writes in the Wayland binary format. +-- Allows us to use the optimized machinery for Data.Store +-- to gain faster performing decoding/encoding. +instance Store WirePackage where + size = VarSize $ fromIntegral . wirePackageSize + poke p = do + poke $ wirePackageSender p + poke $ wirePackageOpcode p + poke $ wirePackageSize p + let (sourceFp, sourceOffset, sourceLength) = B.toForeignPtr $ wirePackagePayload p + pokeFromForeignPtr sourceFp sourceOffset sourceLength + peek = do + sen <- peek + op <- peek + sz <- peek + let payloadSize = fromIntegral sz - 8 + plraw <- peekToPlainForeignPtr "Data.ByteString.ByteString" payloadSize + let pl = B.PS plraw 0 payloadSize + return $ WirePackage + { wirePackageSender=sen + , wirePackageSize=sz + , wirePackageOpcode=op + , wirePackagePayload=pl + } + {-# INLINE size #-} + {-# INLINE peek #-} + {-# INLINE poke #-} -parseWirePackage :: A.Parser WirePackage -parseWirePackage = do - sender <- anyWord32he - opcode <- anyWord16he - size <- anyWord16he - payload <- A.take (fromIntegral size - 8) - return WirePackage { wirePackageSender = sender - , wirePackageSize = size - , wirePackageOpcode = opcode - , wirePackagePayload = payload - } - -pkgStream :: A.Parser [WirePackage] -pkgStream = A.many' parseWirePackage +wirePack :: WirePackage -> BB.Builder +wirePack = BB.byteString . encode diff --git a/sudbury.cabal b/sudbury.cabal index ebf60b8..fa5cc4b 100644 --- a/sudbury.cabal +++ b/sudbury.cabal @@ -46,6 +46,8 @@ library , bytestring >=0.9 && <1 , attoparsec >=0.13 && <1 , attoparsec-binary >=0.2 && <1 + , store + , store-core , cpu >=0.1 && <1 , singletons >=2 && <3 , template-haskell >=2.11 && <3 @@ -85,6 +87,8 @@ foreign-library wayland-client , bytestring >=0.9 && <1 , attoparsec >=0.13 && <1 , attoparsec-binary >=0.2 && <1 + , store + , store-core , cpu >=0.1 && <1 , singletons >=2 && <3 , template-haskell >=2.11 && <3 @@ -122,6 +126,7 @@ test-suite tests , test-framework , test-framework-quickcheck2 , attoparsec - , bytestring + , bytestring + , store ghc-options: -Wall default-language: Haskell2010 diff --git a/tests/Wire.hs b/tests/Wire.hs index 776162c..5dce22e 100644 --- a/tests/Wire.hs +++ b/tests/Wire.hs @@ -1,13 +1,9 @@ module Wire where -import qualified Data.Attoparsec.ByteString as AB -import qualified Data.ByteString as B -import Data.ByteString.Builder (toLazyByteString) -import Data.ByteString.Lazy (toStrict) - import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck +import qualified Data.Store as S import Graphics.Sudbury.WirePackages @@ -20,5 +16,4 @@ tests = testGroup "Wire protocol transformations" -- | Test if packing and then parsing a 'WirePackage' yields the original package. prop_package_id :: WirePackage -> Property -prop_package_id pkg = Just True === AB.compareResults (AB.Done B.empty pkg) - (AB.parse parseWirePackage . toStrict . toLazyByteString . wirePack $ pkg) +prop_package_id = (===) <*> (S.decodeEx . S.encode) From 96a1a3c730b886a6b09594d36ccbfa3c86085249 Mon Sep 17 00:00:00 2001 From: Dorus Leliveld Date: Sat, 17 Dec 2016 17:53:38 -0600 Subject: [PATCH 3/6] Fixed list decoding and encoding The list instances used previously were incorrect as the dont account for padding and do not have the correct format (prepend the size of the list). Added a test case (with a multiple packages bytestring arbitrary instance) to check for this in the future. --- Graphics/Sudbury/CABI/Client.hs | 4 +-- Graphics/Sudbury/WirePackages.hs | 59 ++++++++++++++++++++++++++++---- tests/Arbitrary.hs | 28 +++++++++++++++ tests/Wire.hs | 16 ++++++++- 4 files changed, 97 insertions(+), 10 deletions(-) diff --git a/Graphics/Sudbury/CABI/Client.hs b/Graphics/Sudbury/CABI/Client.hs index b16bcd4..8e846aa 100644 --- a/Graphics/Sudbury/CABI/Client.hs +++ b/Graphics/Sudbury/CABI/Client.hs @@ -945,13 +945,13 @@ display_read_events proxyP = withStablePtr proxyP $ \proxy -> do fd_queue <- newTQueueIO atomically $ mapM_ (writeTQueue fd_queue) fds - let pkgsParse = (S.decode bytes :: Either S.PeekException [WirePackage]) + let pkgsParse = (S.decode bytes :: Either S.PeekException WirePackageStream) pkgs <- case pkgsParse of Left err -> error ("Package parse failed: " ++ show err) Right x -> return x - mapM_ (queue_package dd fd_queue) pkgs + mapM_ (queue_package dd fd_queue) (unWirePackageStream pkgs) atomically $ putTMVar (displayInFd dd) fd return 0 diff --git a/Graphics/Sudbury/WirePackages.hs b/Graphics/Sudbury/WirePackages.hs index 750487e..c06b0c6 100644 --- a/Graphics/Sudbury/WirePackages.hs +++ b/Graphics/Sudbury/WirePackages.hs @@ -11,10 +11,15 @@ module Graphics.Sudbury.WirePackages where import Data.Word import Data.Store +import Data.Foldable import Data.Store.Core +import Data.Store.Internal import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Builder as BB +import Control.Monad +import Foreign.Ptr (minusPtr, plusPtr) + data WirePackage = WirePackage @@ -24,9 +29,8 @@ data WirePackage = WirePackage , wirePackagePayload :: B.ByteString } deriving (Eq, Show) --- Storable that writes in the Wayland binary format. --- Allows us to use the optimized machinery for Data.Store --- to gain faster performing decoding/encoding. +-- | Storable that writes in the Wayland binary format. +-- Allows us to use the optimized machinery from Data.Store instance Store WirePackage where size = VarSize $ fromIntegral . wirePackageSize poke p = do @@ -43,14 +47,55 @@ instance Store WirePackage where plraw <- peekToPlainForeignPtr "Data.ByteString.ByteString" payloadSize let pl = B.PS plraw 0 payloadSize return $ WirePackage - { wirePackageSender=sen - , wirePackageSize=sz - , wirePackageOpcode=op - , wirePackagePayload=pl + { wirePackageSender = sen + , wirePackageSize = sz + , wirePackageOpcode = op + , wirePackagePayload = pl } {-# INLINE size #-} {-# INLINE peek #-} {-# INLINE poke #-} +-- | Newtype wrapper around a list of WirePackages is +-- necessary to write the correct amount of pad bytes +-- and to account for non-prepending of list length +newtype WirePackageStream = WirePackageStream + { unWirePackageStream :: [WirePackage] + } deriving (Eq, Show) + +-- | Storable instance for a number of Wayland wirepackages +-- that accounts for padding and deserializing. +instance Store WirePackageStream where + size = VarSize $ foldl' sumAlignedSize 0 . unWirePackageStream + where + VarSize f = size :: Size WirePackage + sumAlignedSize :: Int -> WirePackage -> Int + sumAlignedSize acc x = let pkgSize = f x in pkgSize + acc + (pkgSize `mod` 4) + + poke (WirePackageStream xs) = traverse_ pokeAlign xs + where + {-# INLINE pokeAlign #-} + pokeAlign wp = let align = fromIntegral $ wirePackageSize wp `mod` 4 + emptyByte = 0 :: Word8 -- Maybe skipPoke would be better + in poke wp >> replicateM align (poke emptyByte) + + peek = WirePackageStream <$> go + where + remaining :: Peek Int + remaining = Peek $ \ps ptr -> return (ptr, peekStateEndPtr ps `minusPtr` ptr) + {-# INLINE go #-} + go :: Peek [WirePackage] + go = + do bytesLeft <- remaining + if bytesLeft < 8 then Peek $ \_ ptr -> return (ptr, []) + else do wp <- peek :: Peek WirePackage + let align = fromIntegral $ wirePackageSize wp `mod` 4 + skip align + (wp :) <$> go + {-# INLINE size #-} + {-# INLINE peek #-} + {-# INLINE poke #-} + + wirePack :: WirePackage -> BB.Builder wirePack = BB.byteString . encode diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs index df154ca..17a61f8 100644 --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -6,13 +6,17 @@ and not force any dependency on QuickCheck. This module should only be used in the test code of this project. -} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Arbitrary where import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB +import Control.Monad import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Lazy (toStrict) import Test.QuickCheck +import qualified Data.Store as S +import Data.Word import Graphics.Sudbury.WirePackages @@ -33,3 +37,27 @@ instance Arbitrary WirePackage where , wirePackageOpcode = opcode , wirePackagePayload = payload } + +instance Arbitrary WirePackageStream where + arbitrary = WirePackageStream <$> arbitrary + +-- | Newtype wrapper for the binary format of Wayland. Allows +-- us to construct arbitrary messages from n WirePackages with +-- the required padded bytes. +newtype WirePackageBinary = WirePackageBinary + { unWpBin :: B.ByteString + } deriving (Show, Eq) + + +instance Arbitrary WirePackageBinary where + arbitrary = sized $ \ n -> + do k <- choose (2, n) + WirePackageBinary . B.concat <$> replicateM k genAlignedWp + where + genAlignedWp :: Gen B.ByteString + genAlignedWp = + do wp <- arbitrary :: Gen WirePackage + let padBytes = fromIntegral $ wirePackageSize wp `mod` 4 + pad = B.pack $ replicate padBytes (0 :: Word8) + return $ S.encode wp `B.append` pad + diff --git a/tests/Wire.hs b/tests/Wire.hs index 5dce22e..b2d4163 100644 --- a/tests/Wire.hs +++ b/tests/Wire.hs @@ -4,16 +4,30 @@ import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck import qualified Data.Store as S +import qualified Data.ByteString as B import Graphics.Sudbury.WirePackages -import Arbitrary () +import Arbitrary tests :: Test tests = testGroup "Wire protocol transformations" [ testProperty "wire packages identity" prop_package_id + , testProperty "wire stream encoding identity" prop_package_stream_id + , testProperty "wire stream decoding identity" prop_package_binary_id ] -- | Test if packing and then parsing a 'WirePackage' yields the original package. prop_package_id :: WirePackage -> Property prop_package_id = (===) <*> (S.decodeEx . S.encode) + +prop_package_stream_id :: WirePackageStream -> Property +prop_package_stream_id = (===) <*> (WirePackageStream . S.decodeEx . S.encode . unWirePackageStream) + +prop_package_binary_id :: WirePackageBinary -> Property +prop_package_binary_id = (===) <*> (WirePackageBinary . S.encode . decode' . unWpBin) + where + decode' :: B.ByteString -> WirePackageStream + decode' = S.decodeEx + + From b959806b5bc1f68ec8802634a925f7df6ea289e7 Mon Sep 17 00:00:00 2001 From: Dorus Leliveld Date: Sun, 15 Jan 2017 12:04:09 -0600 Subject: [PATCH 4/6] Checking the suitability of a decodeMany function --- Graphics/Sudbury/WirePackages.hs | 69 ++++++++++++++++++++------------ tests/Arbitrary.hs | 13 +++--- tests/Wire.hs | 13 ++++-- 3 files changed, 59 insertions(+), 36 deletions(-) diff --git a/Graphics/Sudbury/WirePackages.hs b/Graphics/Sudbury/WirePackages.hs index c06b0c6..ba18257 100644 --- a/Graphics/Sudbury/WirePackages.hs +++ b/Graphics/Sudbury/WirePackages.hs @@ -10,6 +10,7 @@ Portability : POSIX module Graphics.Sudbury.WirePackages where import Data.Word +import Data.Monoid import Data.Store import Data.Foldable import Data.Store.Core @@ -17,8 +18,14 @@ import Data.Store.Internal import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Builder as BB +import System.IO.Unsafe (unsafePerformIO) + import Control.Monad -import Foreign.Ptr (minusPtr, plusPtr) +import Foreign.Ptr (minusPtr, plusPtr, Ptr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr) + +import Control.Exception (Exception(..), throwIO, try) + @@ -32,13 +39,19 @@ data WirePackage = WirePackage -- | Storable that writes in the Wayland binary format. -- Allows us to use the optimized machinery from Data.Store instance Store WirePackage where - size = VarSize $ fromIntegral . wirePackageSize + size = VarSize $ \x -> let sz = fromIntegral (wirePackageSize x) in sz + (sz `mod` 4) poke p = do poke $ wirePackageSender p poke $ wirePackageOpcode p poke $ wirePackageSize p let (sourceFp, sourceOffset, sourceLength) = B.toForeignPtr $ wirePackagePayload p pokeFromForeignPtr sourceFp sourceOffset sourceLength + pokeAlign p + where + {-# INLINE pokeAlign #-} + pokeAlign wp = let align = fromIntegral $ wirePackageSize wp `mod` 4 + emptyByte = 0 :: Word8 -- Maybe skipPoke would be better + in replicateM_ align (poke emptyByte) peek = do sen <- peek op <- peek @@ -46,6 +59,7 @@ instance Store WirePackage where let payloadSize = fromIntegral sz - 8 plraw <- peekToPlainForeignPtr "Data.ByteString.ByteString" payloadSize let pl = B.PS plraw 0 payloadSize + skip $ fromIntegral sz `mod` 4 return $ WirePackage { wirePackageSender = sen , wirePackageSize = sz @@ -66,36 +80,41 @@ newtype WirePackageStream = WirePackageStream -- | Storable instance for a number of Wayland wirepackages -- that accounts for padding and deserializing. instance Store WirePackageStream where - size = VarSize $ foldl' sumAlignedSize 0 . unWirePackageStream + size = VarSize $ getSum . foldMap (Sum . f) . unWirePackageStream where VarSize f = size :: Size WirePackage - sumAlignedSize :: Int -> WirePackage -> Int - sumAlignedSize acc x = let pkgSize = f x in pkgSize + acc + (pkgSize `mod` 4) + + poke = traverse_ poke . unWirePackageStream - poke (WirePackageStream xs) = traverse_ pokeAlign xs - where - {-# INLINE pokeAlign #-} - pokeAlign wp = let align = fromIntegral $ wirePackageSize wp `mod` 4 - emptyByte = 0 :: Word8 -- Maybe skipPoke would be better - in poke wp >> replicateM align (poke emptyByte) - - peek = WirePackageStream <$> go - where - remaining :: Peek Int - remaining = Peek $ \ps ptr -> return (ptr, peekStateEndPtr ps `minusPtr` ptr) - {-# INLINE go #-} - go :: Peek [WirePackage] - go = - do bytesLeft <- remaining - if bytesLeft < 8 then Peek $ \_ ptr -> return (ptr, []) - else do wp <- peek :: Peek WirePackage - let align = fromIntegral $ wirePackageSize wp `mod` 4 - skip align - (wp :) <$> go + peek = undefined {-# INLINE size #-} {-# INLINE peek #-} {-# INLINE poke #-} +decodeMany :: Store a => B.ByteString -> Either PeekException [a] +decodeMany = unsafePerformIO . try . decodeIOMany + +decodeIOMany :: Store a => B.ByteString -> IO [a] +decodeIOMany = decodeIOWithMany peek + +decodeIOWithMany :: Peek a -> B.ByteString -> IO [a] +decodeIOWithMany mypeek (B.PS x s len) = + withForeignPtr x $ \ptr0 -> + let ptr = ptr0 `plusPtr` s + in decodeIOWithFromPtrMany mypeek ptr len +{-# INLINE decodeIOWithMany #-} + +decodeIOWithFromPtrMany :: Peek a -> Ptr Word8 -> Int -> IO [a] +decodeIOWithFromPtrMany mypeek ptr len = do + if len < 8 + then return [] + else do + (offset, x) <- decodeIOPortionWithFromPtr mypeek ptr len + (x : ) <$> decodeIOWithFromPtrMany mypeek (ptr `plusPtr` offset) (len - offset) + --throwIO $ PeekException (len - offset) "Didn't consume all input." +{-# INLINE decodeIOWithFromPtrMany #-} wirePack :: WirePackage -> BB.Builder wirePack = BB.byteString . encode + + diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs index 17a61f8..5757cbe 100644 --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -46,18 +46,17 @@ instance Arbitrary WirePackageStream where -- the required padded bytes. newtype WirePackageBinary = WirePackageBinary { unWpBin :: B.ByteString - } deriving (Show, Eq) + } deriving (Eq) + +instance Show WirePackageBinary where + show = show . B.unpack . unWpBin instance Arbitrary WirePackageBinary where arbitrary = sized $ \ n -> - do k <- choose (2, n) + do k <- choose (0, n) WirePackageBinary . B.concat <$> replicateM k genAlignedWp where genAlignedWp :: Gen B.ByteString - genAlignedWp = - do wp <- arbitrary :: Gen WirePackage - let padBytes = fromIntegral $ wirePackageSize wp `mod` 4 - pad = B.pack $ replicate padBytes (0 :: Word8) - return $ S.encode wp `B.append` pad + genAlignedWp = S.encode <$> (arbitrary :: Gen WirePackage) diff --git a/tests/Wire.hs b/tests/Wire.hs index b2d4163..a87d7d4 100644 --- a/tests/Wire.hs +++ b/tests/Wire.hs @@ -17,17 +17,22 @@ tests = testGroup "Wire protocol transformations" , testProperty "wire stream decoding identity" prop_package_binary_id ] + +unsafeRight :: (Show a) => Either a b -> b +unsafeRight (Right a) = a +unsafeRight (Left a) = error $ show a -- | Test if packing and then parsing a 'WirePackage' yields the original package. prop_package_id :: WirePackage -> Property prop_package_id = (===) <*> (S.decodeEx . S.encode) prop_package_stream_id :: WirePackageStream -> Property -prop_package_stream_id = (===) <*> (WirePackageStream . S.decodeEx . S.encode . unWirePackageStream) +prop_package_stream_id = (===) <*> (decode' . S.encode ) + where + decode' :: B.ByteString -> WirePackageStream + decode' = WirePackageStream . unsafeRight . decodeMany prop_package_binary_id :: WirePackageBinary -> Property prop_package_binary_id = (===) <*> (WirePackageBinary . S.encode . decode' . unWpBin) where decode' :: B.ByteString -> WirePackageStream - decode' = S.decodeEx - - + decode' = WirePackageStream . unsafeRight . decodeMany From a9fb2be701fe94b1ca405945b0abe8647594ec9e Mon Sep 17 00:00:00 2001 From: Dorus Leliveld Date: Sun, 15 Jan 2017 20:52:01 -0600 Subject: [PATCH 5/6] Fixed --- Graphics/Sudbury/WirePackages.hs | 25 ++++++++++++++++++++----- bench/Main.hs | 31 +++++++++++++++++++++---------- 2 files changed, 41 insertions(+), 15 deletions(-) diff --git a/Graphics/Sudbury/WirePackages.hs b/Graphics/Sudbury/WirePackages.hs index 9ace829..d3d9635 100644 --- a/Graphics/Sudbury/WirePackages.hs +++ b/Graphics/Sudbury/WirePackages.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-| Module : Graphics.Sudbury.WirePackages Description : Reads ByteStrings into packages containing individual messages @@ -7,7 +8,6 @@ Maintainer : auke@tulcod.com Stability : experimental Portability : POSIX -} -{-# LANGUAGE BangPatterns #-} module Graphics.Sudbury.WirePackages where import Data.Word @@ -21,6 +21,7 @@ import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Builder as BB import System.IO.Unsafe (unsafePerformIO) + import Control.Monad import Foreign.Ptr (minusPtr, plusPtr, Ptr) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr) @@ -29,12 +30,16 @@ import Control.Exception (Exception(..), throwIO, try) + data WirePackage = WirePackage { wirePackageSender :: Word32 , wirePackageSize :: Word16 , wirePackageOpcode :: Word16 , wirePackagePayload :: B.ByteString - } deriving (Eq, Show) + } deriving (Eq) + +instance Show WirePackage where + show (WirePackage se sz op pl) = "Sender: " ++ show se ++ "\nSize: " ++ show sz ++ "\nOp: " ++ show op -- | Storable that writes in the Wayland binary format. -- Allows us to use the optimized machinery from Data.Store @@ -105,15 +110,25 @@ decodeIOWithMany mypeek (B.PS x s len) = {-# INLINE decodeIOWithMany #-} decodeIOWithFromPtrMany :: Peek a -> Ptr Word8 -> Int -> IO [a] -decodeIOWithFromPtrMany mypeek ptr len = do - if len < 8 +decodeIOWithFromPtrMany !mypeek !ptr !len = do + if len == 0 then return [] else do (offset, x) <- decodeIOPortionWithFromPtr mypeek ptr len - (x : ) <$> decodeIOWithFromPtrMany mypeek (ptr `plusPtr` offset) (len - offset) + liftM2' (:) (return x) $ decodeIOWithFromPtrMany mypeek (ptr `plusPtr` offset) (len - offset) --throwIO $ PeekException (len - offset) "Didn't consume all input." {-# INLINE decodeIOWithFromPtrMany #-} +-- | A version of 'liftM2' that is strict in the result of its first +-- action. +liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c +liftM2' f a b = do + !x <- a + y <- b + return (f x y) +{-# INLINE liftM2' #-} + + wirePack :: WirePackage -> BB.Builder wirePack = BB.byteString . encode diff --git a/bench/Main.hs b/bench/Main.hs index 7d6a5b8..18d8ce0 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -41,7 +41,7 @@ instance Q.Arbitrary B.ByteString where return . toStrict . toLazyByteString . mconcat $ map BB.word8 someBytes instance Q.Arbitrary WirePackage where - arbitrary = do + arbitrary = Q.sized $ \ n -> do sender <- Q.arbitrary opcode <- Q.arbitrary payload <- Q.arbitrary @@ -54,7 +54,10 @@ instance Q.Arbitrary WirePackage where } instance Q.Arbitrary WirePackageStream where - arbitrary = WirePackageStream <$> Q.arbitrary + arbitrary = Q.sized $ \ n -> + do k <- Q.choose (1000, 1000) + WirePackageStream <$> replicateM k Q.arbitrary + -- | Newtype wrapper for the binary format of Wayland. Allows -- us to construct arbitrary messages from n WirePackages with @@ -69,7 +72,7 @@ instance Show WirePackageBinary where instance Q.Arbitrary WirePackageBinary where arbitrary = Q.sized $ \ n -> - do k <- Q.choose (0, n) + do k <- Q.choose (1000, 1000) WirePackageBinary . B.concat <$> replicateM k genAlignedWp where genAlignedWp :: Q.Gen B.ByteString @@ -83,6 +86,8 @@ parseWirePackage = do opcode <- anyWord16he size <- anyWord16he payload <- A.take (fromIntegral size - 8) + let offset = fromIntegral size `mod` 4 + A.take offset return WirePackage { wirePackageSender = sender , wirePackageSize = size , wirePackageOpcode = opcode @@ -93,8 +98,8 @@ pkgStream' :: A.Parser [WirePackage] pkgStream' = A.many' parseWirePackage -randomWirePackage :: IO [WirePackage] -randomWirePackage = Q.generate $ Q.vectorOf 100 (Q.arbitrary :: Q.Gen WirePackage) +randomWirePackage :: IO [WirePackageStream] +randomWirePackage = Q.generate $ Q.vectorOf 100 (Q.arbitrary :: Q.Gen WirePackageStream) randomByteString :: IO [B.ByteString] randomByteString = Q.generate $ fmap unWpBin <$> Q.vectorOf 100 (Q.arbitrary :: Q.Gen WirePackageBinary) @@ -104,12 +109,18 @@ decodeAttos = unsafeRight . A.parseOnly (A.many' parseWirePackage) unsafeRight (Right a) = a -encodeBS :: WirePackage -> B.ByteString -encodeBS = toStrict . toLazyByteString . wirePack +encodeBS :: WirePackageStream -> B.ByteString +encodeBS = toStrict . toLazyByteString . foldMap wirePack . unWirePackageStream + -decodedWorking = do - a <- randomWirePackage - print $ map (decodeEx . encodeBS) a == a +ensureDecodersEqual = do + rb <- randomByteString + let decode' :: B.ByteString -> [WirePackage] + decode' = fromRight . decodeMany + wp1 = map decode' rb + wp2 = map decodeAttos rb + res = zipWith (\x y -> if x == y then (True, x, y) else (False, x, y)) wp1 wp2 + return $ filter (\(x, _, _) -> x == False) res From d562d49c1a6ebe799e8395526a78ee9847155e0b Mon Sep 17 00:00:00 2001 From: Dorus Leliveld Date: Sun, 15 Jan 2017 21:05:30 -0600 Subject: [PATCH 6/6] Actually use decodeMany --- Graphics/Sudbury/CABI/Client.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Graphics/Sudbury/CABI/Client.hs b/Graphics/Sudbury/CABI/Client.hs index 8e846aa..c6bad69 100644 --- a/Graphics/Sudbury/CABI/Client.hs +++ b/Graphics/Sudbury/CABI/Client.hs @@ -945,13 +945,13 @@ display_read_events proxyP = withStablePtr proxyP $ \proxy -> do fd_queue <- newTQueueIO atomically $ mapM_ (writeTQueue fd_queue) fds - let pkgsParse = (S.decode bytes :: Either S.PeekException WirePackageStream) + let pkgsParse = (decodeMany bytes :: Either S.PeekException [WirePackage]) pkgs <- case pkgsParse of Left err -> error ("Package parse failed: " ++ show err) Right x -> return x - mapM_ (queue_package dd fd_queue) (unWirePackageStream pkgs) + mapM_ (queue_package dd fd_queue) pkgs atomically $ putTMVar (displayInFd dd) fd return 0