diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ + +0.5.0.0 +======= + +* Switch to using the builder provided by the `ByteString` package +* Change the encoding of Float and Double with the Serialize class to use the + `Data.Serialize.IEEE754` module +* Add support for encoding and decoding `ShortByteString` +* New and improved test suite thanks to Kei Hibino +* Fix two bugs involving the `lookAhead` combinator and partial chunks. diff --git a/cereal.cabal b/cereal.cabal --- a/cereal.cabal +++ b/cereal.cabal @@ -1,5 +1,5 @@ name: cereal -version: 0.4.1.1 +version: 0.5.0.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin , @@ -10,49 +10,51 @@ category: Data, Parsing stability: provisional build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.10 synopsis: A binary serialization library -extra-source-files: tests/Benchmark.hs, - tests/CBenchmark.c, - tests/CBenchmark.h, - tests/Makefile, - tests/MemBench.hs, - tests/Tests.hs +homepage: https://github.com/GaloisInc/cereal + description: A binary serialization library, similar to binary, that introduces an isolate primitive for parser isolation, and labeled blocks for better error messages. +extra-source-files: CHANGELOG.md + source-repository head type: git location: git://github.com/GaloisInc/cereal.git -flag split-base - default: True - library - build-depends: bytestring - if flag(split-base) - build-depends: base == 4.*, containers, array - else - build-depends: base < 3.0 + default-language: Haskell2010 - if impl(ghc >= 7.2.1) - cpp-options: -DGENERICS - build-depends: ghc-prim >= 0.2 + build-depends: bytestring >= 0.10.0.0, + base == 4.*, containers, array, + ghc-prim >= 0.2 hs-source-dirs: src exposed-modules: Data.Serialize, Data.Serialize.Put, Data.Serialize.Get, - Data.Serialize.Builder, Data.Serialize.IEEE754 - extensions: CPP, - FlexibleContexts, - FlexibleInstances, - Rank2Types, - MagicHash - ghc-options: -Wall -O2 -funbox-strict-fields - ghc-prof-options: -prof -auto-all + + +test-suite test-cereal + default-language: Haskell2010 + + type: exitcode-stdio-1.0 + + build-depends: base == 4.*, + bytestring, + QuickCheck, + test-framework, + test-framework-quickcheck2, + cereal + + main-is: Main.hs + other-modules: RoundTrip + GetTests + + hs-source-dirs: tests diff --git a/src/Data/Serialize.hs b/src/Data/Serialize.hs --- a/src/Data/Serialize.hs +++ b/src/Data/Serialize.hs @@ -10,6 +10,10 @@ , ScopedTypeVariables #-} #endif +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Serialize @@ -65,9 +69,16 @@ #ifdef GENERICS import GHC.Generics +#endif + +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((*>),(<*>),(<$>),pure) #endif +#if MIN_VERSION_base(4,8,0) +import Numeric.Natural +#endif + ------------------------------------------------------------------------ @@ -238,13 +249,13 @@ -- -- Fold and unfold an Integer to and from a list of its bytes -- -unroll :: Integer -> [Word8] +unroll :: (Integral a, Num a, Bits a) => a -> [Word8] unroll = unfoldr step where step 0 = Nothing step i = Just (fromIntegral i, i `shiftR` 8) -roll :: [Word8] -> Integer +roll :: (Integral a, Num a, Bits a) => [Word8] -> a roll = foldr unstep 0 where unstep b a = a `shiftL` 8 .|. fromIntegral b @@ -253,6 +264,31 @@ put r = put (R.numerator r) >> put (R.denominator r) get = liftM2 (R.%) get get +#if MIN_VERSION_base(4,8,0) +-- Fixed-size type for a subset of Natural +type NaturalWord = Word64 + +instance Serialize Natural where + {-# INLINE put #-} + put n | n <= hi = do + putWord8 0 + put (fromIntegral n :: NaturalWord) -- fast path + where + hi = fromIntegral (maxBound :: NaturalWord) :: Natural + + put n = do + putWord8 1 + put (unroll (abs n)) -- unroll the bytes + + {-# INLINE get #-} + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get NaturalWord) + _ -> do bytes <- get + return $! roll bytes +#endif + ------------------------------------------------------------------------ -- Safely wrap `chr` to avoid exceptions. @@ -458,12 +494,12 @@ -- Floating point instance Serialize Double where - put d = put (decodeFloat d) - get = liftM2 encodeFloat get get + put = putFloat64be + get = getFloat64be instance Serialize Float where - put f = put (decodeFloat f) - get = liftM2 encodeFloat get get + put = putFloat32be + get = getFloat32be ------------------------------------------------------------------------ -- Trees diff --git a/src/Data/Serialize/Builder.hs b/src/Data/Serialize/Builder.hs deleted file mode 100644 --- a/src/Data/Serialize/Builder.hs +++ /dev/null @@ -1,429 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} --- for unboxed shifts - ------------------------------------------------------------------------------ --- | --- Module : Data.Serialize.Builder --- Copyright : Lennart Kolmodin, Ross Paterson, Galois Inc. 2009 --- License : BSD3-style (see LICENSE) --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- --- Efficient construction of lazy bytestrings. --- ------------------------------------------------------------------------------ - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - -module Data.Serialize.Builder ( - - -- * The Builder type - Builder - , toByteString - , toLazyByteString - - -- * Constructing Builders - , empty - , singleton - , append - , fromByteString -- :: S.ByteString -> Builder - , fromLazyByteString -- :: L.ByteString -> Builder - - -- * Flushing the buffer state - , flush - - -- * Derived Builders - -- ** Big-endian writes - , putWord16be -- :: Word16 -> Builder - , putWord32be -- :: Word32 -> Builder - , putWord64be -- :: Word64 -> Builder - - -- ** Little-endian writes - , putWord16le -- :: Word16 -> Builder - , putWord32le -- :: Word32 -> Builder - , putWord64le -- :: Word64 -> Builder - - -- ** Host-endian, unaligned writes - , putWordhost -- :: Word -> Builder - , putWord16host -- :: Word16 -> Builder - , putWord32host -- :: Word32 -> Builder - , putWord64host -- :: Word64 -> Builder - - ) where - -import Data.Monoid -import Data.Word -import Foreign.ForeignPtr -import Foreign.Ptr (Ptr,plusPtr) -import Foreign.Storable -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Internal as S - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -import GHC.Base (Int(..), uncheckedShiftRL#) -import GHC.Word (Word32(..),Word16(..),Word64(..)) - -#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 -import GHC.Word (uncheckedShiftRL64#) -#endif -#else -import Data.Word -#endif - ------------------------------------------------------------------------- - --- | A 'Builder' is an efficient way to build lazy 'L.ByteString's. --- There are several functions for constructing 'Builder's, but only one --- to inspect them: to extract any data, you have to turn them into lazy --- 'L.ByteString's using 'toLazyByteString'. --- --- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte --- arrays piece by piece. As each buffer is filled, it is \'popped\' --- off, to become a new chunk of the resulting lazy 'L.ByteString'. --- All this is hidden from the user of the 'Builder'. - -newtype Builder = Builder { - -- Invariant (from Data.ByteString.Lazy): - -- The lists include no null ByteStrings. - runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] - } - -instance Monoid Builder where - mempty = empty - {-# INLINE mempty #-} - mappend = append - {-# INLINE mappend #-} - ------------------------------------------------------------------------- - --- | /O(1)./ The empty Builder, satisfying --- --- * @'toLazyByteString' 'empty' = 'L.empty'@ --- -empty :: Builder -empty = Builder id -{-# INLINE empty #-} - --- | /O(1)./ A Builder taking a single byte, satisfying --- --- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@ --- -singleton :: Word8 -> Builder -singleton = writeN 1 . flip poke -{-# INLINE singleton #-} - ------------------------------------------------------------------------- - --- | /O(1)./ The concatenation of two Builders, an associative operation --- with identity 'empty', satisfying --- --- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@ --- -append :: Builder -> Builder -> Builder -append (Builder f) (Builder g) = Builder (f . g) -{-# INLINE append #-} - --- | /O(1)./ A Builder taking a 'S.ByteString', satisfying --- --- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@ --- -fromByteString :: S.ByteString -> Builder -fromByteString bs - | S.null bs = empty - | otherwise = flush `append` mapBuilder (bs :) -{-# INLINE fromByteString #-} - --- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying --- --- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ --- -fromLazyByteString :: L.ByteString -> Builder -fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++) -{-# INLINE fromLazyByteString #-} - ------------------------------------------------------------------------- - --- Our internal buffer type -data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) - {-# UNPACK #-} !Int -- offset - {-# UNPACK #-} !Int -- used bytes - {-# UNPACK #-} !Int -- length left - ------------------------------------------------------------------------- - -toByteString :: Builder -> S.ByteString -toByteString m = S.concat $ unsafePerformIO $ do - buf <- newBuffer defaultSize - return (runBuilder (m `append` flush) (const []) buf) - --- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. --- The construction work takes place if and when the relevant part of --- the lazy 'L.ByteString' is demanded. --- -toLazyByteString :: Builder -> L.ByteString -toLazyByteString m = L.fromChunks $ unsafePerformIO $ do - buf <- newBuffer defaultSize - return (runBuilder (m `append` flush) (const []) buf) - --- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, --- yielding a new chunk in the result lazy 'L.ByteString'. -flush :: Builder -flush = Builder $ \ k buf@(Buffer p o u l) -> - if u == 0 - then k buf - else S.PS p o u : k (Buffer p (o+u) 0 l) - ------------------------------------------------------------------------- - --- --- copied from Data.ByteString.Lazy --- -defaultSize :: Int -defaultSize = 32 * k - overhead - where k = 1024 - overhead = 2 * sizeOf (undefined :: Int) - ------------------------------------------------------------------------- - --- | Sequence an IO operation on the buffer -unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder -unsafeLiftIO f = Builder $ \ k buf -> S.inlinePerformIO $ do - buf' <- f buf - return (k buf') -{-# INLINE unsafeLiftIO #-} - --- | Get the size of the buffer -withSize :: (Int -> Builder) -> Builder -withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> - runBuilder (f l) k buf - --- | Map the resulting list of bytestrings. -mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder -mapBuilder f = Builder (f .) - ------------------------------------------------------------------------- - --- | Ensure that there are at least @n@ many bytes available. -ensureFree :: Int -> Builder -ensureFree n = n `seq` withSize $ \ l -> - if n <= l then empty else - flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize))) -{-# INLINE ensureFree #-} - --- | Ensure that @n@ many bytes are available, and then use @f@ to write some --- bytes into the memory. -writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder -writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f) -{-# INLINE writeN #-} - -writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer -writeNBuffer n f (Buffer fp o u l) = do - withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) - return (Buffer fp o (u+n) (l-n)) -{-# INLINE writeNBuffer #-} - -newBuffer :: Int -> IO Buffer -newBuffer size = do - fp <- S.mallocByteString size - return $! Buffer fp 0 0 size -{-# INLINE newBuffer #-} - ------------------------------------------------------------------------- --- Aligned, host order writes of storable values - --- | Ensure that @n@ many bytes are available, and then use @f@ to write some --- storable values into the memory. -writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder -writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f) -{-# INLINE writeNbytes #-} - -writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer -writeNBufferBytes n f (Buffer fp o u l) = do - withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) - return (Buffer fp o (u+n) (l-n)) -{-# INLINE writeNBufferBytes #-} - ------------------------------------------------------------------------- - --- --- We rely on the fromIntegral to do the right masking for us. --- The inlining here is critical, and can be worth 4x performance --- - --- | Write a Word16 in big endian format -putWord16be :: Word16 -> Builder -putWord16be w = writeN 2 $ \p -> do - poke p (fromIntegral (shiftr_w16 w 8) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) -{-# INLINE putWord16be #-} - --- | Write a Word16 in little endian format -putWord16le :: Word16 -> Builder -putWord16le w = writeN 2 $ \p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) -{-# INLINE putWord16le #-} - --- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) - --- | Write a Word32 in big endian format -putWord32be :: Word32 -> Builder -putWord32be w = writeN 4 $ \p -> do - poke p (fromIntegral (shiftr_w32 w 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) -{-# INLINE putWord32be #-} - --- --- a data type to tag Put/Check. writes construct these which are then --- inlined and flattened. matching Checks will be more robust with rules. --- - --- | Write a Word32 in little endian format -putWord32le :: Word32 -> Builder -putWord32le w = writeN 4 $ \p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) -{-# INLINE putWord32le #-} - --- on a little endian machine: --- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32) - --- | Write a Word64 in big endian format -putWord64be :: Word64 -> Builder -#if WORD_SIZE_IN_BITS < 64 --- --- To avoid expensive 64 bit shifts on 32 bit machines, we cast to --- Word32, and write that --- -putWord64be w = - let a = fromIntegral (shiftr_w64 w 32) :: Word32 - b = fromIntegral w :: Word32 - in writeN 8 $ \p -> do - poke p (fromIntegral (shiftr_w32 a 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) -#else -putWord64be w = writeN 8 $ \p -> do - poke p (fromIntegral (shiftr_w64 w 56) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) -#endif -{-# INLINE putWord64be #-} - --- | Write a Word64 in little endian format -putWord64le :: Word64 -> Builder - -#if WORD_SIZE_IN_BITS < 64 -putWord64le w = - let b = fromIntegral (shiftr_w64 w 32) :: Word32 - a = fromIntegral w :: Word32 - in writeN 8 $ \p -> do - poke (p) (fromIntegral (a) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) -#else -putWord64le w = writeN 8 $ \p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) -#endif -{-# INLINE putWord64le #-} - --- on a little endian machine: --- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) - ------------------------------------------------------------------------- --- Unaligned, word size ops - --- | /O(1)./ A Builder taking a single native machine word. The word is --- written in host order, host endian form, for the machine you're on. --- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, --- 4 bytes. Values written this way are not portable to --- different endian or word sized machines, without conversion. --- -putWordhost :: Word -> Builder -putWordhost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w) -{-# INLINE putWordhost #-} - --- | Write a Word16 in native host order and host endianness. --- 2 bytes will be written, unaligned. -putWord16host :: Word16 -> Builder -putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16) -{-# INLINE putWord16host #-} - --- | Write a Word32 in native host order and host endianness. --- 4 bytes will be written, unaligned. -putWord32host :: Word32 -> Builder -putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32) -{-# INLINE putWord32host #-} - --- | Write a Word64 in native host order. --- On a 32 bit machine we write two host order Word32s, in big endian form. --- 8 bytes will be written, unaligned. -putWord64host :: Word64 -> Builder -putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w) -{-# INLINE putWord64host #-} - ------------------------------------------------------------------------- --- Unchecked shifts - -{-# INLINE shiftr_w16 #-} -shiftr_w16 :: Word16 -> Int -> Word16 -{-# INLINE shiftr_w32 #-} -shiftr_w32 :: Word32 -> Int -> Word32 -{-# INLINE shiftr_w64 #-} -shiftr_w64 :: Word64 -> Int -> Word64 - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) -shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) - -#if WORD_SIZE_IN_BITS < 64 -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) - -#if __GLASGOW_HASKELL__ <= 606 --- Exported by GHC.Word in GHC 6.8 and higher -foreign import ccall unsafe "stg_uncheckedShiftRL64" - uncheckedShiftRL64# :: Word64# -> Int# -> Word64# -#endif - -#else -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) -#endif - -#else -shiftr_w16 = shiftR -shiftr_w32 = shiftR -shiftr_w64 = shiftR -#endif diff --git a/src/Data/Serialize/Get.hs b/src/Data/Serialize/Get.hs --- a/src/Data/Serialize/Get.hs +++ b/src/Data/Serialize/Get.hs @@ -29,8 +29,11 @@ , runGetLazy , runGetState , runGetLazyState + + -- ** Incremental interface , Result(..) , runGetPartial + , runGetChunk -- * Parsing , ensure @@ -50,20 +53,31 @@ -- * Parsing particular types , getWord8 + , getInt8 -- ** ByteStrings , getByteString , getLazyByteString +#if MIN_VERSION_bytestring(0,10,4) + , getShortByteString +#endif + -- ** Big-endian reads , getWord16be , getWord32be , getWord64be + , getInt16be + , getInt32be + , getInt64be -- ** Little-endian reads , getWord16le , getWord32le , getWord64le + , getInt16le + , getInt32le + , getInt64le -- ** Host-endian, unaligned reads , getWordhost @@ -83,16 +97,19 @@ , getIntSetOf , getMaybeOf , getEitherOf + , getNested ) where -import Control.Applicative (Applicative(..),Alternative(..)) -import Control.Monad (unless,when,ap,MonadPlus(..),liftM2) +import qualified Control.Applicative as A +import qualified Control.Monad as M +import Control.Monad (unless) import Data.Array.IArray (IArray,listArray) import Data.Ix (Ix) import Data.List (intercalate) import Data.Maybe (isNothing,fromMaybe) import Foreign +import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B @@ -106,6 +123,11 @@ import qualified Data.Tree as T +#if MIN_VERSION_bytestring(0,10,4) +import qualified Data.ByteString.Short as BS +#endif + + #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word @@ -143,8 +165,17 @@ type Input = B.ByteString type Buffer = Maybe B.ByteString +emptyBuffer :: Buffer +emptyBuffer = Just B.empty + +extendBuffer :: Buffer -> B.ByteString -> Buffer +extendBuffer buf chunk = + do bs <- buf + return (bs `B.append` chunk) +{-# INLINE extendBuffer #-} + append :: Buffer -> Buffer -> Buffer -append l r = B.append `fmap` l <*> r +append l r = B.append `fmap` l A.<*> r {-# INLINE append #-} bufferBytes :: Buffer -> B.ByteString @@ -166,38 +197,57 @@ Incomplete mb -> fromMaybe 0 mb instance Functor Get where - fmap p m = - Get $ \s0 b0 m0 kf ks -> - let ks' s1 b1 m1 a = ks s1 b1 m1 (p a) - in unGet m s0 b0 m0 kf ks' + fmap p m = Get $ \ s0 b0 m0 kf ks -> + unGet m s0 b0 m0 kf $ \ s1 b1 m1 a -> ks s1 b1 m1 (p a) -instance Applicative Get where +instance A.Applicative Get where pure = return - (<*>) = ap + {-# INLINE pure #-} -instance Alternative Get where + f <*> x = Get $ \ s0 b0 m0 kf ks -> + unGet f s0 b0 m0 kf $ \ s1 b1 m1 g -> + unGet x s1 b1 m1 kf $ \ s2 b2 m2 y -> ks s2 b2 m2 (g y) + {-# INLINE (<*>) #-} + +instance A.Alternative Get where empty = failDesc "empty" - (<|>) = mplus + {-# INLINE empty #-} + (<|>) = M.mplus + {-# INLINE (<|>) #-} + -- Definition directly from Control.Monad.State.Strict instance Monad Get where return a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a + {-# INLINE return #-} - m >>= g = - Get $ \s0 b0 m0 kf ks -> - let ks' s1 b1 m1 a = unGet (g a) s1 b1 m1 kf ks - in unGet m s0 b0 m0 kf ks' + m >>= g = Get $ \ s0 b0 m0 kf ks -> + unGet m s0 b0 m0 kf $ \ s1 b1 m1 a -> unGet (g a) s1 b1 m1 kf ks + {-# INLINE (>>=) #-} + m >> k = Get $ \ s0 b0 m0 kf ks -> + unGet m s0 b0 m0 kf $ \ s1 b1 m1 _ -> unGet k s1 b1 m1 kf ks + {-# INLINE (>>) #-} + fail = failDesc + {-# INLINE fail #-} -instance MonadPlus Get where + +instance M.MonadPlus Get where mzero = failDesc "mzero" + {-# INLINE mzero #-} + mplus a b = Get $ \s0 b0 m0 kf ks -> - let kf' _ b1 m1 _ _ = unGet b (s0 `B.append` bufferBytes b1) - (b0 `append` b1) m1 kf ks - in unGet a s0 (Just B.empty) m0 kf' ks + let ks' s1 b1 = ks s1 (b0 `append` b1) + kf' _ b1 m1 = kf (s0 `B.append` bufferBytes b1) + (b0 `append` b1) m1 + try _ b1 m1 _ _ = unGet b (s0 `B.append` bufferBytes b1) + b1 m1 kf' ks' + in unGet a s0 emptyBuffer m0 try ks' + {-# INLINE mplus #-} + ------------------------------------------------------------------------ formatTrace :: [String] -> String @@ -234,10 +284,17 @@ Partial{} -> Left "Failed reading: Internal error: unexpected Partial." {-# INLINE runGet #-} +-- | Run the get monad on a single chunk, providing an optional length for the +-- remaining, unseen input, with Nothing indicating that it's not clear how much +-- input is left. For example, with a lazy ByteString, the optional length +-- represents the sum of the lengths of all remaining chunks. +runGetChunk :: Get a -> Maybe Int -> B.ByteString -> Result a +runGetChunk m mbLen str = unGet m str Nothing (Incomplete mbLen) failK finalK +{-# INLINE runGetChunk #-} + -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGetPartial :: Get a -> B.ByteString -> Result a -runGetPartial m str = - unGet m str Nothing (Incomplete Nothing) failK finalK +runGetPartial m = runGetChunk m Nothing {-# INLINE runGetPartial #-} -- | Run the Get monad applies a 'get'-based parser on the input @@ -267,9 +324,16 @@ -- Lazy Get -------------------------------------------------------------------- runGetLazy' :: Get a -> L.ByteString -> (Either String a,L.ByteString) -runGetLazy' m lstr = loop (Partial (runGetPartial m)) (L.toChunks lstr) +runGetLazy' m lstr = + case L.toChunks lstr of + [c] -> wrapStrict (runGetState' m c 0) + [] -> wrapStrict (runGetState' m B.empty 0) + c:cs -> loop (runGetChunk m (Just (len - B.length c)) c) cs where + len = fromIntegral (L.length lstr) + wrapStrict (e,s) = (e,L.fromChunks [s]) + loop result chunks = case result of Fail str rest -> (Left str, L.fromChunks (rest : chunks)) @@ -318,7 +382,7 @@ -- is required to consume all the bytes that it is isolated to. isolate :: Int -> Get a -> Get a isolate n m = do - when (n < 0) (fail "Attempted to isolate a negative number of bytes") + M.when (n < 0) (fail "Attempted to isolate a negative number of bytes") s <- ensure n let (s',rest) = B.splitAt n s put s' @@ -337,10 +401,13 @@ Incomplete mb -> Partial $ \s -> if B.null s then kf s0 b0 m0 ["demandInput"] "too few bytes" - else let update l = l - B.length s - s1 = s0 `B.append` s - b1 = b0 `append` Just s - in ks s1 b1 (Incomplete (update `fmap` mb)) () + else let s1 = s0 `B.append` s + b1 = extendBuffer b0 s + mb' = case mb of + Just l -> Just $! l - B.length s + Nothing -> Nothing + in b1 `seq` + mb' `seq` ks s1 b1 (Incomplete mb') () failDesc :: String -> Get a failDesc err = do @@ -363,8 +430,11 @@ -- Fails if @ga@ fails. lookAhead :: Get a -> Get a lookAhead ga = Get $ \ s0 b0 m0 kf ks -> - let ks' _s1 b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1) - in unGet ga s0 (Just B.empty) m0 kf ks' + -- the new continuation extends the old input with the new buffered bytes, and + -- appends the new buffer to the old one, if there was one. + let ks' _ b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1) + kf' _ b1 = kf s0 (b0 `append` b1) + in unGet ga s0 emptyBuffer m0 kf' ks' -- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. -- Fails if @gma@ fails. @@ -372,7 +442,7 @@ lookAheadM gma = do s <- get ma <- gma - when (isNothing ma) (put s) + M.when (isNothing ma) (put s) return ma -- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. @@ -425,7 +495,14 @@ getLazyByteString n = f `fmap` getByteString (fromIntegral n) where f bs = L.fromChunks [bs] +#if MIN_VERSION_bytestring(0,10,4) +getShortByteString :: Int -> Get BS.ShortByteString +getShortByteString n = do + bs <- getBytes n + return $! BS.toShort bs +#endif + ------------------------------------------------------------------------ -- Helpers @@ -453,73 +530,157 @@ getPtr n = do (fp,o,_) <- B.toForeignPtr `fmap` getBytes n let k p = peek (castPtr (p `plusPtr` o)) - return (B.inlinePerformIO (withForeignPtr fp k)) + return (unsafeDupablePerformIO (withForeignPtr fp k)) {-# INLINE getPtr #-} +----------------------------------------------------------------------- + +-- | Read a Int8 from the monad state +getInt8 :: Get Int8 +getInt8 = do + s <- getBytes 1 + return $! fromIntegral (B.unsafeHead s) + +-- | Read a Int16 in big endian format +getInt16be :: Get Int16 +getInt16be = do + s <- getBytes 2 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 1) ) + +-- | Read a Int16 in little endian format +getInt16le :: Get Int16 +getInt16le = do + s <- getBytes 2 + return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +-- | Read a Int32 in big endian format +getInt32be :: Get Int32 +getInt32be = do + s <- getBytes 4 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 24) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 16) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 3) ) + +-- | Read a Int32 in little endian format +getInt32le :: Get Int32 +getInt32le = do + s <- getBytes 4 + return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +-- | Read a Int64 in big endian format +getInt64be :: Get Int64 +getInt64be = do + s <- getBytes 8 + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 56) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 48) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 40) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 32) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftL` 24) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftL` 16) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 7) ) + +-- | Read a Int64 in little endian format +getInt64le :: Get Int64 +getInt64le = do + s <- getBytes 8 + return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftL` 56) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftL` 48) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftL` 40) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftL` 32) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) + +{-# INLINE getInt8 #-} +{-# INLINE getInt16be #-} +{-# INLINE getInt16le #-} +{-# INLINE getInt32be #-} +{-# INLINE getInt32le #-} +{-# INLINE getInt64be #-} +{-# INLINE getInt64le #-} + ------------------------------------------------------------------------ -- | Read a Word8 from the monad state getWord8 :: Get Word8 -getWord8 = getPtr (sizeOf (undefined :: Word8)) +getWord8 = do + s <- getBytes 1 + return (B.unsafeHead s) -- | Read a Word16 in big endian format getWord16be :: Get Word16 getWord16be = do s <- getBytes 2 - return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|. - (fromIntegral (s `B.index` 1)) + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `B.unsafeIndex` 1)) -- | Read a Word16 in little endian format getWord16le :: Get Word16 getWord16le = do s <- getBytes 2 - return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|. - (fromIntegral (s `B.index` 0) ) + return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) -- | Read a Word32 in big endian format getWord32be :: Get Word32 getWord32be = do s <- getBytes 4 - return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|. - (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|. - (fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|. - (fromIntegral (s `B.index` 3) ) + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|. + (fromIntegral (s `B.unsafeIndex` 3) ) -- | Read a Word32 in little endian format getWord32le :: Get Word32 getWord32le = do s <- getBytes 4 - return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|. - (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|. - (fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|. - (fromIntegral (s `B.index` 0) ) + return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) -- | Read a Word64 in big endian format getWord64be :: Get Word64 getWord64be = do s <- getBytes 8 - return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|. - (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|. - (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|. - (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|. - (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|. - (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|. - (fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|. - (fromIntegral (s `B.index` 7) ) + return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|. + (fromIntegral (s `B.unsafeIndex` 7) ) -- | Read a Word64 in little endian format getWord64le :: Get Word64 getWord64le = do s <- getBytes 8 - return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|. - (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|. - (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|. - (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|. - (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|. - (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|. - (fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|. - (fromIntegral (s `B.index` 0) ) + return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) +{-# INLINE getWord8 #-} +{-# INLINE getWord16be #-} +{-# INLINE getWord16le #-} +{-# INLINE getWord32be #-} +{-# INLINE getWord32le #-} +{-# INLINE getWord64be #-} +{-# INLINE getWord64le #-} + ------------------------------------------------------------------------ -- Host-endian reads @@ -575,7 +736,7 @@ -- Containers ------------------------------------------------------------------ getTwoOf :: Get a -> Get b -> Get (a,b) -getTwoOf ma mb = liftM2 (,) ma mb +getTwoOf ma mb = M.liftM2 (,) ma mb -- | Get a list in the following format: -- Word64 (big endian format) @@ -585,7 +746,7 @@ getListOf :: Get a -> Get [a] getListOf m = go [] =<< getWord64be where - go as 0 = return (reverse as) + go as 0 = return $! reverse as go as i = do x <- m x `seq` go (x:as) (i - 1) @@ -597,7 +758,7 @@ -- ... -- element n getIArrayOf :: (Ix i, IArray a e) => Get i -> Get e -> Get (a i e) -getIArrayOf ix e = liftM2 listArray (getTwoOf ix ix) (getListOf e) +getIArrayOf ix e = M.liftM2 listArray (getTwoOf ix ix) (getListOf e) -- | Get a sequence in the following format: -- Word64 (big endian format) @@ -614,7 +775,7 @@ -- | Read as a list of lists. getTreeOf :: Get a -> Get (T.Tree a) -getTreeOf m = liftM2 T.Node m (getListOf (getTreeOf m)) +getTreeOf m = M.liftM2 T.Node m (getListOf (getTreeOf m)) -- | Read as a list of pairs of key and element. getMapOf :: Ord k => Get k -> Get a -> Get (Map.Map k a) @@ -651,3 +812,10 @@ case tag of 0 -> Left `fmap` ma _ -> Right `fmap` mb + +-- | Read in a length and then read a nested structure +-- of that length. +getNested :: Get Int -> Get a -> Get a +getNested getLen getVal = do + n <- getLen + isolate n getVal diff --git a/src/Data/Serialize/IEEE754.hs b/src/Data/Serialize/IEEE754.hs --- a/src/Data/Serialize/IEEE754.hs +++ b/src/Data/Serialize/IEEE754.hs @@ -1,6 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + +#ifndef MIN_VERSION_array +#define MIN_VERSION_array(x,y,z) 1 +#endif + -- | IEEE-754 parsing, as described in this stack-overflow article: -- -- @@ -21,7 +29,6 @@ ) where -import Control.Applicative ( (<$>) ) import Control.Monad.ST ( runST, ST ) import Data.Array.ST ( newArray, readArray, MArray, STUArray ) @@ -29,7 +36,11 @@ import Data.Serialize.Get import Data.Serialize.Put -#if __GLASGOW_HASKELL__ >= 704 +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ( (<$>) ) +#endif + +#if MIN_VERSION_array(0,4,0) import Data.Array.Unsafe (castSTUArray) #else import Data.Array.ST (castSTUArray) diff --git a/src/Data/Serialize/Put.hs b/src/Data/Serialize/Put.hs --- a/src/Data/Serialize/Put.hs +++ b/src/Data/Serialize/Put.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE CPP #-} + +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 0 +#endif + +#ifndef MIN_VERSION_bytestring +#define MIN_VERSION_bytestring(x,y,z) 0 +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Serialize.Put @@ -33,6 +43,10 @@ , putByteString , putLazyByteString +#if MIN_VERSION_bytestring(0,10,4) + , putShortByteString +#endif + -- * Big-endian primitives , putWord16be , putWord32be @@ -61,16 +75,31 @@ , putIntSetOf , putMaybeOf , putEitherOf + , putNested ) where -import Data.Serialize.Builder (Builder, toByteString, toLazyByteString) -import qualified Data.Serialize.Builder as B -import Control.Applicative +#if MIN_VERSION_bytestring(0,10,2) +import Data.ByteString.Builder (Builder, toLazyByteString) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +#elif MIN_VERSION_bytestring(0,10,0) +import Data.ByteString.Lazy.Builder (Builder, toLazyByteString) +import qualified Data.ByteString.Lazy.Builder as B +import qualified Data.ByteString.Lazy.Builder.Extras as B +#else +#error "cereal requires bytestring >= 0.10.0.0" +#endif + +#if MIN_VERSION_bytestring(0,10,4) +import qualified Data.ByteString.Short as BS +#endif + +import qualified Control.Applicative as A import Data.Array.Unboxed -import Data.Monoid -import Data.Foldable (foldMap) +import qualified Data.Monoid as M +import qualified Data.Foldable as F import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -81,6 +110,11 @@ import qualified Data.Set as Set import qualified Data.Tree as T +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +import Data.Foldable (foldMap) +import Data.Monoid +#endif ------------------------------------------------------------------------ @@ -103,35 +137,35 @@ {-# INLINE fmap #-} -instance Applicative PutM where +instance A.Applicative PutM where pure = return {-# INLINE pure #-} m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k - in PairS (f x) (w `mappend` w') + in PairS (f x) (w `M.mappend` w') {-# INLINE (<*>) #-} instance Monad PutM where - return a = Put (PairS a mempty) + return a = Put (PairS a M.mempty) {-# INLINE return #-} m >>= k = Put $ let PairS a w = unPut m PairS b w' = unPut (k a) - in PairS b (w `mappend` w') + in PairS b (w `M.mappend` w') {-# INLINE (>>=) #-} m >> k = Put $ let PairS _ w = unPut m PairS b w' = unPut k - in PairS b (w `mappend` w') + in PairS b (w `M.mappend` w') {-# INLINE (>>) #-} tell :: Putter Builder -tell b = Put $ PairS () b +tell b = Put $! PairS () b {-# INLINE tell #-} putBuilder :: Putter Builder @@ -145,12 +179,12 @@ -- | Run the 'Put' monad with a serialiser runPut :: Put -> S.ByteString -runPut = toByteString . sndS . unPut +runPut = L.toStrict . runPutLazy {-# INLINE runPut #-} -- | Run the 'Put' monad with a serialiser and get its result runPutM :: PutM a -> (a, S.ByteString) -runPutM (Put (PairS f s)) = (f, toByteString s) +runPutM (Put (PairS f s)) = (f, L.toStrict (toLazyByteString s)) {-# INLINE runPutM #-} -- | Run the 'Put' monad with a serialiser @@ -173,49 +207,54 @@ -- | Efficiently write a byte into the output buffer putWord8 :: Putter Word8 -putWord8 = tell . B.singleton +putWord8 = tell . B.word8 {-# INLINE putWord8 #-} -- | An efficient primitive to write a strict ByteString into the output buffer. -- It flushes the current buffer, and writes the argument into a new chunk. putByteString :: Putter S.ByteString -putByteString = tell . B.fromByteString +putByteString = tell . B.byteString {-# INLINE putByteString #-} +#if MIN_VERSION_bytestring(0,10,4) +putShortByteString :: Putter BS.ShortByteString +putShortByteString = tell . B.shortByteString +#endif + -- | Write a lazy ByteString efficiently, simply appending the lazy -- ByteString chunks to the output buffer putLazyByteString :: Putter L.ByteString -putLazyByteString = tell . B.fromLazyByteString +putLazyByteString = tell . B.lazyByteString {-# INLINE putLazyByteString #-} -- | Write a Word16 in big endian format putWord16be :: Putter Word16 -putWord16be = tell . B.putWord16be +putWord16be = tell . B.word16BE {-# INLINE putWord16be #-} -- | Write a Word16 in little endian format putWord16le :: Putter Word16 -putWord16le = tell . B.putWord16le +putWord16le = tell . B.word16LE {-# INLINE putWord16le #-} -- | Write a Word32 in big endian format putWord32be :: Putter Word32 -putWord32be = tell . B.putWord32be +putWord32be = tell . B.word32BE {-# INLINE putWord32be #-} -- | Write a Word32 in little endian format putWord32le :: Putter Word32 -putWord32le = tell . B.putWord32le +putWord32le = tell . B.word32LE {-# INLINE putWord32le #-} -- | Write a Word64 in big endian format putWord64be :: Putter Word64 -putWord64be = tell . B.putWord64be +putWord64be = tell . B.word64BE {-# INLINE putWord64be #-} -- | Write a Word64 in little endian format putWord64le :: Putter Word64 -putWord64le = tell . B.putWord64le +putWord64le = tell . B.word64LE {-# INLINE putWord64le #-} ------------------------------------------------------------------------ @@ -227,26 +266,26 @@ -- different endian or word sized machines, without conversion. -- putWordhost :: Putter Word -putWordhost = tell . B.putWordhost +putWordhost = tell . B.wordHost {-# INLINE putWordhost #-} -- | /O(1)./ Write a Word16 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord16host :: Putter Word16 -putWord16host = tell . B.putWord16host +putWord16host = tell . B.word16Host {-# INLINE putWord16host #-} -- | /O(1)./ Write a Word32 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord32host :: Putter Word32 -putWord32host = tell . B.putWord32host +putWord32host = tell . B.word32Host {-# INLINE putWord32host #-} -- | /O(1)./ Write a Word64 in native host order -- On a 32 bit machine we write two host order Word32s, in big endian form. -- For portability issues see @putWordhost@. putWord64host :: Putter Word64 -putWord64host = tell . B.putWord64host +putWord64host = tell . B.word64Host {-# INLINE putWord64host #-} @@ -254,8 +293,8 @@ encodeListOf :: (a -> Builder) -> [a] -> Builder encodeListOf f = -- allow inlining with just a single argument - \xs -> execPut (putWord64be (fromIntegral $ length xs)) `mappend` - foldMap f xs + \xs -> execPut (putWord64be (fromIntegral $ length xs)) `M.mappend` + F.foldMap f xs {-# INLINE encodeListOf #-} putTwoOf :: Putter a -> Putter b -> Putter (a,b) @@ -263,7 +302,9 @@ {-# INLINE putTwoOf #-} putListOf :: Putter a -> Putter [a] -putListOf pa = tell . encodeListOf (execPut . pa) +putListOf pa = \l -> do + putWord64be (fromIntegral (length l)) + mapM_ pa l {-# INLINE putListOf #-} putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e) @@ -275,14 +316,14 @@ putSeqOf :: Putter a -> Putter (Seq.Seq a) putSeqOf pa = \s -> do putWord64be (fromIntegral $ Seq.length s) - tell (foldMap (execPut . pa) s) + F.mapM_ pa s {-# INLINE putSeqOf #-} putTreeOf :: Putter a -> Putter (T.Tree a) putTreeOf pa = tell . go where - go (T.Node x cs) = execPut (pa x) `mappend` encodeListOf go cs + go (T.Node x cs) = execPut (pa x) `M.mappend` encodeListOf go cs {-# INLINE putTreeOf #-} putMapOf :: Ord k => Putter k -> Putter a -> Putter (Map.Map k a) @@ -310,3 +351,11 @@ putEitherOf pa _ (Left a) = putWord8 0 >> pa a putEitherOf _ pb (Right b) = putWord8 1 >> pb b {-# INLINE putEitherOf #-} + +-- | Put a nested structure by first putting a length +-- field and then putting the encoded value. +putNested :: Putter Int -> Put -> Put +putNested putLen putVal = do + let bs = runPut putVal + putLen (S.length bs) + putByteString bs diff --git a/tests/Benchmark.hs b/tests/Benchmark.hs deleted file mode 100644 --- a/tests/Benchmark.hs +++ /dev/null @@ -1,1462 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main (main) where - -import qualified Data.ByteString as L -import Data.Serialize -import Data.Serialize.Put -import Data.Serialize.Get - -import Control.Exception -import Data.Word -import System.CPUTime -import Numeric -import Text.Printf -import System.Environment - -import MemBench - -data Endian - = Big - | Little - | Host - deriving (Eq,Ord,Show) - -main :: IO () -main = do - mb <- getArgs >>= readIO . head - memBench (mb*10) - putStrLn "" - putStrLn "Binary (de)serialisation benchmarks:" - - -- do bytewise - sequence_ - [ test wordSize chunkSize Host mb - | wordSize <- [1] - , chunkSize <- [16] --1,2,4,8,16] - ] - - -- now Word16 .. Word64 - sequence_ - [ test wordSize chunkSize end mb - | wordSize <- [2,4,8] - , chunkSize <- [16] - , end <- [Host] -- ,Big,Little] - ] - ------------------------------------------------------------------------- - -time :: IO a -> IO Double -time action = do - start <- getCPUTime - action - end <- getCPUTime - return $! (fromIntegral (end - start)) / (10^12) - ------------------------------------------------------------------------- - -test :: Int -> Int -> Endian -> Int -> IO () -test wordSize chunkSize end mb = do - let bytes :: Int - bytes = mb * 2^20 - iterations = bytes `div` wordSize - bs = runPut (doPut wordSize chunkSize end iterations) - sum = runGet (doGet wordSize chunkSize end iterations) bs - - case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return () - - printf "%dMB of Word%-2d in chunks of %2d (%6s endian): " - (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end) - - putSeconds <- time $ evaluate (L.length bs) - getSeconds <- time $ evaluate sum --- print (L.length bs, sum) - let putThroughput = fromIntegral mb / putSeconds - getThroughput = fromIntegral mb / getSeconds - - printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n" - putThroughput - getThroughput - (getThroughput/putThroughput) - ------------------------------------------------------------------------- - -doPut :: Int -> Int -> Endian -> Int -> Put -doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of - (1, 1,_) -> putWord8N1 - (1, 2,_) -> putWord8N2 - (1, 4,_) -> putWord8N4 - (1, 8,_) -> putWord8N8 - (1, 16, _) -> putWord8N16 - - (2, 1, Big) -> putWord16N1Big - (2, 2, Big) -> putWord16N2Big - (2, 4, Big) -> putWord16N4Big - (2, 8, Big) -> putWord16N8Big - (2, 16, Big) -> putWord16N16Big - (2, 1, Little) -> putWord16N1Little - (2, 2, Little) -> putWord16N2Little - (2, 4, Little) -> putWord16N4Little - (2, 8, Little) -> putWord16N8Little - (2, 16, Little) -> putWord16N16Little - (2, 1, Host) -> putWord16N1Host - (2, 2, Host) -> putWord16N2Host - (2, 4, Host) -> putWord16N4Host - (2, 8, Host) -> putWord16N8Host - (2, 16, Host) -> putWord16N16Host - - (4, 1, Big) -> putWord32N1Big - (4, 2, Big) -> putWord32N2Big - (4, 4, Big) -> putWord32N4Big - (4, 8, Big) -> putWord32N8Big - (4, 16, Big) -> putWord32N16Big - (4, 1, Little) -> putWord32N1Little - (4, 2, Little) -> putWord32N2Little - (4, 4, Little) -> putWord32N4Little - (4, 8, Little) -> putWord32N8Little - (4, 16, Little) -> putWord32N16Little - (4, 1, Host) -> putWord32N1Host - (4, 2, Host) -> putWord32N2Host - (4, 4, Host) -> putWord32N4Host - (4, 8, Host) -> putWord32N8Host - (4, 16, Host) -> putWord32N16Host - - (8, 1, Host) -> putWord64N1Host - (8, 2, Host) -> putWord64N2Host - (8, 4, Host) -> putWord64N4Host - (8, 8, Host) -> putWord64N8Host - (8, 16, Host) -> putWord64N16Host - (8, 1, Big) -> putWord64N1Big - (8, 2, Big) -> putWord64N2Big - (8, 4, Big) -> putWord64N4Big - (8, 8, Big) -> putWord64N8Big - (8, 16, Big) -> putWord64N16Big - (8, 1, Little) -> putWord64N1Little - (8, 2, Little) -> putWord64N2Little - (8, 4, Little) -> putWord64N4Little - (8, 8, Little) -> putWord64N8Little - (8, 16, Little) -> putWord64N16Little - ------------------------------------------------------------------------- - -doGet :: Int -> Int -> Endian -> Int -> Get Int -doGet wordSize chunkSize end = - case (wordSize, chunkSize, end) of - (1, 1,_) -> fmap fromIntegral . getWord8N1 - (1, 2,_) -> fmap fromIntegral . getWord8N2 - (1, 4,_) -> fmap fromIntegral . getWord8N4 - (1, 8,_) -> fmap fromIntegral . getWord8N8 - (1, 16,_) -> fmap fromIntegral . getWord8N16 - - (2, 1,Big) -> fmap fromIntegral . getWord16N1Big - (2, 2,Big) -> fmap fromIntegral . getWord16N2Big - (2, 4,Big) -> fmap fromIntegral . getWord16N4Big - (2, 8,Big) -> fmap fromIntegral . getWord16N8Big - (2, 16,Big) -> fmap fromIntegral . getWord16N16Big - (2, 1,Little) -> fmap fromIntegral . getWord16N1Little - (2, 2,Little) -> fmap fromIntegral . getWord16N2Little - (2, 4,Little) -> fmap fromIntegral . getWord16N4Little - (2, 8,Little) -> fmap fromIntegral . getWord16N8Little - (2, 16,Little) -> fmap fromIntegral . getWord16N16Little - (2, 1,Host) -> fmap fromIntegral . getWord16N1Host - (2, 2,Host) -> fmap fromIntegral . getWord16N2Host - (2, 4,Host) -> fmap fromIntegral . getWord16N4Host - (2, 8,Host) -> fmap fromIntegral . getWord16N8Host - (2, 16,Host) -> fmap fromIntegral . getWord16N16Host - - (4, 1,Big) -> fmap fromIntegral . getWord32N1Big - (4, 2,Big) -> fmap fromIntegral . getWord32N2Big - (4, 4,Big) -> fmap fromIntegral . getWord32N4Big - (4, 8,Big) -> fmap fromIntegral . getWord32N8Big - (4, 16,Big) -> fmap fromIntegral . getWord32N16Big - (4, 1,Little) -> fmap fromIntegral . getWord32N1Little - (4, 2,Little) -> fmap fromIntegral . getWord32N2Little - (4, 4,Little) -> fmap fromIntegral . getWord32N4Little - (4, 8,Little) -> fmap fromIntegral . getWord32N8Little - (4, 16,Little) -> fmap fromIntegral . getWord32N16Little - (4, 1,Host) -> fmap fromIntegral . getWord32N1Host - (4, 2,Host) -> fmap fromIntegral . getWord32N2Host - (4, 4,Host) -> fmap fromIntegral . getWord32N4Host - (4, 8,Host) -> fmap fromIntegral . getWord32N8Host - (4, 16,Host) -> fmap fromIntegral . getWord32N16Host - - (8, 1,Host) -> fmap fromIntegral . getWord64N1Host - (8, 2,Host) -> fmap fromIntegral . getWord64N2Host - (8, 4,Host) -> fmap fromIntegral . getWord64N4Host - (8, 8,Host) -> fmap fromIntegral . getWord64N8Host - (8, 16,Host) -> fmap fromIntegral . getWord64N16Host - (8, 1,Big) -> fmap fromIntegral . getWord64N1Big - (8, 2,Big) -> fmap fromIntegral . getWord64N2Big - (8, 4,Big) -> fmap fromIntegral . getWord64N4Big - (8, 8,Big) -> fmap fromIntegral . getWord64N8Big - (8, 16,Big) -> fmap fromIntegral . getWord64N16Big - (8, 1,Little) -> fmap fromIntegral . getWord64N1Little - (8, 2,Little) -> fmap fromIntegral . getWord64N2Little - (8, 4,Little) -> fmap fromIntegral . getWord64N4Little - (8, 8,Little) -> fmap fromIntegral . getWord64N8Little - (8, 16,Little) -> fmap fromIntegral . getWord64N16Little - ------------------------------------------------------------------------- - -putWord8N1 bytes = loop 0 0 - where loop :: Word8 -> Int -> Put - loop !s !n | n == bytes = return () - | otherwise = do putWord8 s - loop (s+1) (n+1) - -putWord8N2 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord8 (s+0) - putWord8 (s+1) - loop (s+2) (n-2) - -putWord8N4 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord8 (s+0) - putWord8 (s+1) - putWord8 (s+2) - putWord8 (s+3) - loop (s+4) (n-4) - -putWord8N8 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord8 (s+0) - putWord8 (s+1) - putWord8 (s+2) - putWord8 (s+3) - putWord8 (s+4) - putWord8 (s+5) - putWord8 (s+6) - putWord8 (s+7) - loop (s+8) (n-8) - -putWord8N16 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord8 (s+0) - putWord8 (s+1) - putWord8 (s+2) - putWord8 (s+3) - putWord8 (s+4) - putWord8 (s+5) - putWord8 (s+6) - putWord8 (s+7) - putWord8 (s+8) - putWord8 (s+9) - putWord8 (s+10) - putWord8 (s+11) - putWord8 (s+12) - putWord8 (s+13) - putWord8 (s+14) - putWord8 (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- --- Big endian, word16 writes - -putWord16N1Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16be (s+0) - loop (s+1) (n-1) - -putWord16N2Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16be (s+0) - putWord16be (s+1) - loop (s+2) (n-2) - -putWord16N4Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16be (s+0) - putWord16be (s+1) - putWord16be (s+2) - putWord16be (s+3) - loop (s+4) (n-4) - -putWord16N8Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16be (s+0) - putWord16be (s+1) - putWord16be (s+2) - putWord16be (s+3) - putWord16be (s+4) - putWord16be (s+5) - putWord16be (s+6) - putWord16be (s+7) - loop (s+8) (n-8) - -putWord16N16Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16be (s+0) - putWord16be (s+1) - putWord16be (s+2) - putWord16be (s+3) - putWord16be (s+4) - putWord16be (s+5) - putWord16be (s+6) - putWord16be (s+7) - putWord16be (s+8) - putWord16be (s+9) - putWord16be (s+10) - putWord16be (s+11) - putWord16be (s+12) - putWord16be (s+13) - putWord16be (s+14) - putWord16be (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- --- Little endian, word16 writes - -putWord16N1Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16le (s+0) - loop (s+1) (n-1) - -putWord16N2Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16le (s+0) - putWord16le (s+1) - loop (s+2) (n-2) - -putWord16N4Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16le (s+0) - putWord16le (s+1) - putWord16le (s+2) - putWord16le (s+3) - loop (s+4) (n-4) - -putWord16N8Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16le (s+0) - putWord16le (s+1) - putWord16le (s+2) - putWord16le (s+3) - putWord16le (s+4) - putWord16le (s+5) - putWord16le (s+6) - putWord16le (s+7) - loop (s+8) (n-8) - -putWord16N16Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16le (s+0) - putWord16le (s+1) - putWord16le (s+2) - putWord16le (s+3) - putWord16le (s+4) - putWord16le (s+5) - putWord16le (s+6) - putWord16le (s+7) - putWord16le (s+8) - putWord16le (s+9) - putWord16le (s+10) - putWord16le (s+11) - putWord16le (s+12) - putWord16le (s+13) - putWord16le (s+14) - putWord16le (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- --- Host endian, unaligned, word16 writes - -putWord16N1Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16host (s+0) - loop (s+1) (n-1) - -putWord16N2Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16host (s+0) - putWord16host (s+1) - loop (s+2) (n-2) - -putWord16N4Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16host (s+0) - putWord16host (s+1) - putWord16host (s+2) - putWord16host (s+3) - loop (s+4) (n-4) - -putWord16N8Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16host (s+0) - putWord16host (s+1) - putWord16host (s+2) - putWord16host (s+3) - putWord16host (s+4) - putWord16host (s+5) - putWord16host (s+6) - putWord16host (s+7) - loop (s+8) (n-8) - -putWord16N16Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord16host (s+0) - putWord16host (s+1) - putWord16host (s+2) - putWord16host (s+3) - putWord16host (s+4) - putWord16host (s+5) - putWord16host (s+6) - putWord16host (s+7) - putWord16host (s+8) - putWord16host (s+9) - putWord16host (s+10) - putWord16host (s+11) - putWord16host (s+12) - putWord16host (s+13) - putWord16host (s+14) - putWord16host (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- - -putWord32N1Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32be (s+0) - loop (s+1) (n-1) - -putWord32N2Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32be (s+0) - putWord32be (s+1) - loop (s+2) (n-2) - -putWord32N4Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32be (s+0) - putWord32be (s+1) - putWord32be (s+2) - putWord32be (s+3) - loop (s+4) (n-4) - -putWord32N8Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32be (s+0) - putWord32be (s+1) - putWord32be (s+2) - putWord32be (s+3) - putWord32be (s+4) - putWord32be (s+5) - putWord32be (s+6) - putWord32be (s+7) - loop (s+8) (n-8) - -putWord32N16Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32be (s+0) - putWord32be (s+1) - putWord32be (s+2) - putWord32be (s+3) - putWord32be (s+4) - putWord32be (s+5) - putWord32be (s+6) - putWord32be (s+7) - putWord32be (s+8) - putWord32be (s+9) - putWord32be (s+10) - putWord32be (s+11) - putWord32be (s+12) - putWord32be (s+13) - putWord32be (s+14) - putWord32be (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- - -putWord32N1Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32le (s+0) - loop (s+1) (n-1) - -putWord32N2Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32le (s+0) - putWord32le (s+1) - loop (s+2) (n-2) - -putWord32N4Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32le (s+0) - putWord32le (s+1) - putWord32le (s+2) - putWord32le (s+3) - loop (s+4) (n-4) - -putWord32N8Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32le (s+0) - putWord32le (s+1) - putWord32le (s+2) - putWord32le (s+3) - putWord32le (s+4) - putWord32le (s+5) - putWord32le (s+6) - putWord32le (s+7) - loop (s+8) (n-8) - -putWord32N16Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32le (s+0) - putWord32le (s+1) - putWord32le (s+2) - putWord32le (s+3) - putWord32le (s+4) - putWord32le (s+5) - putWord32le (s+6) - putWord32le (s+7) - putWord32le (s+8) - putWord32le (s+9) - putWord32le (s+10) - putWord32le (s+11) - putWord32le (s+12) - putWord32le (s+13) - putWord32le (s+14) - putWord32le (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- - -putWord32N1Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32host (s+0) - loop (s+1) (n-1) - -putWord32N2Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32host (s+0) - putWord32host (s+1) - loop (s+2) (n-2) - -putWord32N4Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32host (s+0) - putWord32host (s+1) - putWord32host (s+2) - putWord32host (s+3) - loop (s+4) (n-4) - -putWord32N8Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32host (s+0) - putWord32host (s+1) - putWord32host (s+2) - putWord32host (s+3) - putWord32host (s+4) - putWord32host (s+5) - putWord32host (s+6) - putWord32host (s+7) - loop (s+8) (n-8) - -putWord32N16Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord32host (s+0) - putWord32host (s+1) - putWord32host (s+2) - putWord32host (s+3) - putWord32host (s+4) - putWord32host (s+5) - putWord32host (s+6) - putWord32host (s+7) - putWord32host (s+8) - putWord32host (s+9) - putWord32host (s+10) - putWord32host (s+11) - putWord32host (s+12) - putWord32host (s+13) - putWord32host (s+14) - putWord32host (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- - -putWord64N1Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64be (s+0) - loop (s+1) (n-1) - -putWord64N2Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64be (s+0) - putWord64be (s+1) - loop (s+2) (n-2) - -putWord64N4Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64be (s+0) - putWord64be (s+1) - putWord64be (s+2) - putWord64be (s+3) - loop (s+4) (n-4) - -putWord64N8Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64be (s+0) - putWord64be (s+1) - putWord64be (s+2) - putWord64be (s+3) - putWord64be (s+4) - putWord64be (s+5) - putWord64be (s+6) - putWord64be (s+7) - loop (s+8) (n-8) - -putWord64N16Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64be (s+0) - putWord64be (s+1) - putWord64be (s+2) - putWord64be (s+3) - putWord64be (s+4) - putWord64be (s+5) - putWord64be (s+6) - putWord64be (s+7) - putWord64be (s+8) - putWord64be (s+9) - putWord64be (s+10) - putWord64be (s+11) - putWord64be (s+12) - putWord64be (s+13) - putWord64be (s+14) - putWord64be (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- - -putWord64N1Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64le (s+0) - loop (s+1) (n-1) - -putWord64N2Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64le (s+0) - putWord64le (s+1) - loop (s+2) (n-2) - -putWord64N4Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64le (s+0) - putWord64le (s+1) - putWord64le (s+2) - putWord64le (s+3) - loop (s+4) (n-4) - -putWord64N8Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64le (s+0) - putWord64le (s+1) - putWord64le (s+2) - putWord64le (s+3) - putWord64le (s+4) - putWord64le (s+5) - putWord64le (s+6) - putWord64le (s+7) - loop (s+8) (n-8) - -putWord64N16Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64le (s+0) - putWord64le (s+1) - putWord64le (s+2) - putWord64le (s+3) - putWord64le (s+4) - putWord64le (s+5) - putWord64le (s+6) - putWord64le (s+7) - putWord64le (s+8) - putWord64le (s+9) - putWord64le (s+10) - putWord64le (s+11) - putWord64le (s+12) - putWord64le (s+13) - putWord64le (s+14) - putWord64le (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- - -putWord64N1Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64host (s+0) - loop (s+1) (n-1) - -putWord64N2Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64host (s+0) - putWord64host (s+1) - loop (s+2) (n-2) - -putWord64N4Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64host (s+0) - putWord64host (s+1) - putWord64host (s+2) - putWord64host (s+3) - loop (s+4) (n-4) - -putWord64N8Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64host (s+0) - putWord64host (s+1) - putWord64host (s+2) - putWord64host (s+3) - putWord64host (s+4) - putWord64host (s+5) - putWord64host (s+6) - putWord64host (s+7) - loop (s+8) (n-8) - -putWord64N16Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord64host (s+0) - putWord64host (s+1) - putWord64host (s+2) - putWord64host (s+3) - putWord64host (s+4) - putWord64host (s+5) - putWord64host (s+6) - putWord64host (s+7) - putWord64host (s+8) - putWord64host (s+9) - putWord64host (s+10) - putWord64host (s+11) - putWord64host (s+12) - putWord64host (s+13) - putWord64host (s+14) - putWord64host (s+15) - loop (s+16) (n-16) - ------------------------------------------------------------------------- ------------------------------------------------------------------------- - -getWord8N1 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord8 - loop (s+s0) (n-1) - -getWord8N2 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord8 - s1 <- getWord8 - loop (s+s0+s1) (n-2) - -getWord8N4 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord8 - s1 <- getWord8 - s2 <- getWord8 - s3 <- getWord8 - loop (s+s0+s1+s2+s3) (n-4) - -getWord8N8 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord8 - s1 <- getWord8 - s2 <- getWord8 - s3 <- getWord8 - s4 <- getWord8 - s5 <- getWord8 - s6 <- getWord8 - s7 <- getWord8 - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - -getWord8N16 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord8 - s1 <- getWord8 - s2 <- getWord8 - s3 <- getWord8 - s4 <- getWord8 - s5 <- getWord8 - s6 <- getWord8 - s7 <- getWord8 - s8 <- getWord8 - s9 <- getWord8 - s10 <- getWord8 - s11 <- getWord8 - s12 <- getWord8 - s13 <- getWord8 - s14 <- getWord8 - s15 <- getWord8 - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord16N1Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16be - loop (s+s0) (n-1) - -getWord16N2Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16be - s1 <- getWord16be - loop (s+s0+s1) (n-2) - -getWord16N4Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16be - s1 <- getWord16be - s2 <- getWord16be - s3 <- getWord16be - loop (s+s0+s1+s2+s3) (n-4) - -getWord16N8Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16be - s1 <- getWord16be - s2 <- getWord16be - s3 <- getWord16be - s4 <- getWord16be - s5 <- getWord16be - s6 <- getWord16be - s7 <- getWord16be - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - -getWord16N16Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16be - s1 <- getWord16be - s2 <- getWord16be - s3 <- getWord16be - s4 <- getWord16be - s5 <- getWord16be - s6 <- getWord16be - s7 <- getWord16be - s8 <- getWord16be - s9 <- getWord16be - s10 <- getWord16be - s11 <- getWord16be - s12 <- getWord16be - s13 <- getWord16be - s14 <- getWord16be - s15 <- getWord16be - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord16N1Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16le - loop (s+s0) (n-1) - -getWord16N2Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16le - s1 <- getWord16le - loop (s+s0+s1) (n-2) - -getWord16N4Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16le - s1 <- getWord16le - s2 <- getWord16le - s3 <- getWord16le - loop (s+s0+s1+s2+s3) (n-4) - -getWord16N8Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16le - s1 <- getWord16le - s2 <- getWord16le - s3 <- getWord16le - s4 <- getWord16le - s5 <- getWord16le - s6 <- getWord16le - s7 <- getWord16le - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - -getWord16N16Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16le - s1 <- getWord16le - s2 <- getWord16le - s3 <- getWord16le - s4 <- getWord16le - s5 <- getWord16le - s6 <- getWord16le - s7 <- getWord16le - s8 <- getWord16le - s9 <- getWord16le - s10 <- getWord16le - s11 <- getWord16le - s12 <- getWord16le - s13 <- getWord16le - s14 <- getWord16le - s15 <- getWord16le - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord16N1Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16host - loop (s+s0) (n-1) - -getWord16N2Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16host - s1 <- getWord16host - loop (s+s0+s1) (n-2) - -getWord16N4Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16host - s1 <- getWord16host - s2 <- getWord16host - s3 <- getWord16host - loop (s+s0+s1+s2+s3) (n-4) - -getWord16N8Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16host - s1 <- getWord16host - s2 <- getWord16host - s3 <- getWord16host - s4 <- getWord16host - s5 <- getWord16host - s6 <- getWord16host - s7 <- getWord16host - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - -getWord16N16Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord16host - s1 <- getWord16host - s2 <- getWord16host - s3 <- getWord16host - s4 <- getWord16host - s5 <- getWord16host - s6 <- getWord16host - s7 <- getWord16host - s8 <- getWord16host - s9 <- getWord16host - s10 <- getWord16host - s11 <- getWord16host - s12 <- getWord16host - s13 <- getWord16host - s14 <- getWord16host - s15 <- getWord16host - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord32N1Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32be - loop (s+s0) (n-1) - -getWord32N2Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32be - s1 <- getWord32be - loop (s+s0+s1) (n-2) - -getWord32N4Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32be - s1 <- getWord32be - s2 <- getWord32be - s3 <- getWord32be - loop (s+s0+s1+s2+s3) (n-4) - -getWord32N8Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32be - s1 <- getWord32be - s2 <- getWord32be - s3 <- getWord32be - s4 <- getWord32be - s5 <- getWord32be - s6 <- getWord32be - s7 <- getWord32be - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - --- getWordhostN16 = loop 0 -getWord32N16Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32be - s1 <- getWord32be - s2 <- getWord32be - s3 <- getWord32be - s4 <- getWord32be - s5 <- getWord32be - s6 <- getWord32be - s7 <- getWord32be - s8 <- getWord32be - s9 <- getWord32be - s10 <- getWord32be - s11 <- getWord32be - s12 <- getWord32be - s13 <- getWord32be - s14 <- getWord32be - s15 <- getWord32be - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord32N1Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32le - loop (s+s0) (n-1) - -getWord32N2Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32le - s1 <- getWord32le - loop (s+s0+s1) (n-2) - -getWord32N4Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32le - s1 <- getWord32le - s2 <- getWord32le - s3 <- getWord32le - loop (s+s0+s1+s2+s3) (n-4) - -getWord32N8Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32le - s1 <- getWord32le - s2 <- getWord32le - s3 <- getWord32le - s4 <- getWord32le - s5 <- getWord32le - s6 <- getWord32le - s7 <- getWord32le - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - --- getWordhostN16 = loop 0 -getWord32N16Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32le - s1 <- getWord32le - s2 <- getWord32le - s3 <- getWord32le - s4 <- getWord32le - s5 <- getWord32le - s6 <- getWord32le - s7 <- getWord32le - s8 <- getWord32le - s9 <- getWord32le - s10 <- getWord32le - s11 <- getWord32le - s12 <- getWord32le - s13 <- getWord32le - s14 <- getWord32le - s15 <- getWord32le - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord32N1Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32host - loop (s+s0) (n-1) - -getWord32N2Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32host - s1 <- getWord32host - loop (s+s0+s1) (n-2) - -getWord32N4Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32host - s1 <- getWord32host - s2 <- getWord32host - s3 <- getWord32host - loop (s+s0+s1+s2+s3) (n-4) - -getWord32N8Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32host - s1 <- getWord32host - s2 <- getWord32host - s3 <- getWord32host - s4 <- getWord32host - s5 <- getWord32host - s6 <- getWord32host - s7 <- getWord32host - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - --- getWordhostN16 = loop 0 -getWord32N16Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord32host - s1 <- getWord32host - s2 <- getWord32host - s3 <- getWord32host - s4 <- getWord32host - s5 <- getWord32host - s6 <- getWord32host - s7 <- getWord32host - s8 <- getWord32host - s9 <- getWord32host - s10 <- getWord32host - s11 <- getWord32host - s12 <- getWord32host - s13 <- getWord32host - s14 <- getWord32host - s15 <- getWord32host - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord64N1Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64be - loop (s+s0) (n-1) - -getWord64N2Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64be - s1 <- getWord64be - loop (s+s0+s1) (n-2) - -getWord64N4Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64be - s1 <- getWord64be - s2 <- getWord64be - s3 <- getWord64be - loop (s+s0+s1+s2+s3) (n-4) - -getWord64N8Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64be - s1 <- getWord64be - s2 <- getWord64be - s3 <- getWord64be - s4 <- getWord64be - s5 <- getWord64be - s6 <- getWord64be - s7 <- getWord64be - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - -getWord64N16Big = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64be - s1 <- getWord64be - s2 <- getWord64be - s3 <- getWord64be - s4 <- getWord64be - s5 <- getWord64be - s6 <- getWord64be - s7 <- getWord64be - s8 <- getWord64be - s9 <- getWord64be - s10 <- getWord64be - s11 <- getWord64be - s12 <- getWord64be - s13 <- getWord64be - s14 <- getWord64be - s15 <- getWord64be - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord64N1Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64le - loop (s+s0) (n-1) - -getWord64N2Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64le - s1 <- getWord64le - loop (s+s0+s1) (n-2) - -getWord64N4Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64le - s1 <- getWord64le - s2 <- getWord64le - s3 <- getWord64le - loop (s+s0+s1+s2+s3) (n-4) - -getWord64N8Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64le - s1 <- getWord64le - s2 <- getWord64le - s3 <- getWord64le - s4 <- getWord64le - s5 <- getWord64le - s6 <- getWord64le - s7 <- getWord64le - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - -getWord64N16Little = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64le - s1 <- getWord64le - s2 <- getWord64le - s3 <- getWord64le - s4 <- getWord64le - s5 <- getWord64le - s6 <- getWord64le - s7 <- getWord64le - s8 <- getWord64le - s9 <- getWord64le - s10 <- getWord64le - s11 <- getWord64le - s12 <- getWord64le - s13 <- getWord64le - s14 <- getWord64le - s15 <- getWord64le - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) - ------------------------------------------------------------------------- - -getWord64N1Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64host - loop (s+s0) (n-1) - -getWord64N2Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64host - s1 <- getWord64host - loop (s+s0+s1) (n-2) - -getWord64N4Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64host - s1 <- getWord64host - s2 <- getWord64host - s3 <- getWord64host - loop (s+s0+s1+s2+s3) (n-4) - -getWord64N8Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64host - s1 <- getWord64host - s2 <- getWord64host - s3 <- getWord64host - s4 <- getWord64host - s5 <- getWord64host - s6 <- getWord64host - s7 <- getWord64host - loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) - -getWord64N16Host = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop s 0 = return s - loop s n = do - s0 <- getWord64host - s1 <- getWord64host - s2 <- getWord64host - s3 <- getWord64host - s4 <- getWord64host - s5 <- getWord64host - s6 <- getWord64host - s7 <- getWord64host - s8 <- getWord64host - s9 <- getWord64host - s10 <- getWord64host - s11 <- getWord64host - s12 <- getWord64host - s13 <- getWord64host - s14 <- getWord64host - s15 <- getWord64host - loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) diff --git a/tests/CBenchmark.c b/tests/CBenchmark.c deleted file mode 100644 --- a/tests/CBenchmark.c +++ /dev/null @@ -1,39 +0,0 @@ -#include "CBenchmark.h" - -void bytewrite(unsigned char *a, int bytes) { - unsigned char n = 0; - int i = 0; - int iterations = bytes; - while (i < iterations) { - a[i++] = n++; - } -} - -unsigned char byteread(unsigned char *a, int bytes) { - unsigned char n = 0; - int i = 0; - int iterations = bytes; - while (i < iterations) { - n += a[i++]; - } - return n; -} - -void wordwrite(unsigned long *a, int bytes) { - unsigned long n = 0; - int i = 0; - int iterations = bytes / sizeof(unsigned long) ; - while (i < iterations) { - a[i++] = n++; - } -} - -unsigned int wordread(unsigned long *a, int bytes) { - unsigned long n = 0; - int i = 0; - int iterations = bytes / sizeof(unsigned long); - while (i < iterations) { - n += a[i++]; - } - return n; -} diff --git a/tests/CBenchmark.h b/tests/CBenchmark.h deleted file mode 100644 --- a/tests/CBenchmark.h +++ /dev/null @@ -1,4 +0,0 @@ -void bytewrite(unsigned char *a, int bytes); -unsigned char byteread(unsigned char *a, int bytes); -void wordwrite(unsigned long *a, int bytes); -unsigned int wordread(unsigned long *a, int bytes); diff --git a/tests/GetTests.hs b/tests/GetTests.hs new file mode 100644 --- /dev/null +++ b/tests/GetTests.hs @@ -0,0 +1,278 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} + +module GetTests (tests) where + +import Control.Applicative +import Control.Monad +import Data.Word +import Data.Function +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB +import Data.Serialize.Get +import Test.Framework (Test(),testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck as QC + + +-- Data to express Get parser to generate +data GetD + = Get8 + | Eof + | Get16be + | Get32be + | Get64be + | Get16le + | Get32le + | Get64le + | GetD :*> GetD + | GetD :<|> GetD + | LookAhead GetD + | Skip Int + deriving Show + +-- Get parser generator +buildGet :: GetD -> Get () +buildGet = d where + d Get8 = getWord8 *> pure () + d Eof = guard =<< isEmpty + d Get16be = getWord16be *> pure () + d Get32be = getWord32be *> pure () + d Get64be = getWord64be *> pure () + d Get16le = getWord16le *> pure () + d Get32le = getWord32le *> pure () + d Get64le = getWord64le *> pure () + d (x :*> y) = d x *> d y + d (x :<|> y) = d x <|> d y + d (LookAhead x) = lookAhead $ d x + d (Skip i) = skip i + +-- Randomly generate parser +genGetD :: Gen GetD +genGetD = + oneof $ + [ pure g + | g <- [ Get8, Eof + , Get16be, Get32be, Get64be + , Get16le, Get32le, Get64le + ] + ] ++ + [ (:*>) <$> genGetD <*> genGetD + , (:<|>) <$> genGetD <*> genGetD + , LookAhead <$> genGetD + , Skip <$> choose (0, 10) + ] + +instance Arbitrary GetD where + arbitrary = genGetD + +instance Arbitrary (Get ()) where + arbitrary = buildGet <$> genGetD + +newtype R a = + R { unR :: Either String a } + deriving Show + + +-- Ignore equality of error message string +instance Eq a => Eq (R a) where + (==) = (==) `on` either (const Nothing) Just . unR + +data Chunks = Chunks [[Word8]] deriving (Eq, Show) + +mkChunks :: Word -> Chunks +mkChunks n = Chunks . take (fromIntegral n) $ cycle [ [x] | x <- [0 .. 255] ] + +instance Arbitrary Chunks where + arbitrary = mkChunks <$> choose (0, 512) + + +testLength :: Word +testLength = 255 + +-- Equality between strict and lazy parsing +eqStrictLazy :: GetD -> Property +eqStrictLazy getD = + conjoin + [ counterexample (show in0) $ R (runGet parser sb) == R (runGetLazy parser lb) + | n <- [0 .. testLength] + , let Chunks in0 = mkChunks n + lb = LB.fromChunks [ BS.pack c | c <- in0 ] + sb = BS.pack $ concat in0 + ] + where + parser = buildGet getD + +-- Remaining length equality between strict and lazy parsing +remainingStrictLazy :: GetD -> Property +remainingStrictLazy getD = + conjoin + [ counterexample (show in0) $ R (runGet parser sb) == R (runGetLazy parser lb) + | n <- [0 .. testLength] + , let Chunks in0 = mkChunks n + lb = LB.fromChunks [ BS.pack c | c <- in0 ] + sb = BS.pack $ concat in0 + ] + where + parser = buildGet getD *> remaining + +isEmpty2 :: Get Bool +isEmpty2 = do + lookAhead getWord8 *> pure False + <|> + pure True + +-- Compare with chunks +(==~) :: Eq a => Get a -> Get a -> Property +p1 ==~ p2 = + conjoin + [ counterexample (show in0) $ R (runGetLazy p1 s) == R (runGetLazy p2 s) + | n <- [0 .. testLength] + , let Chunks in0 = mkChunks n + s = LB.fromChunks [ BS.pack c | c <- in0 ] + ] + +(==!) :: Eq a => Get a -> Get a -> Property +p1 ==! p2 = + conjoin + [ counterexample (show s) $ R (runGet p1 s) == R (runGet p2 s) + | n <- [0 .. testLength] + , let Chunks in0 = mkChunks n + s = BS.pack $ concat in0 + ] + +infix 2 ==~, ==! + +-- Equality between two eof definition - lazy +eqEof :: GetD -> Property +eqEof getD = + x *> isEmpty ==~ x *> isEmpty2 + where + x = buildGet getD + +-- Equality between two eof definition - strict +eqEof' :: GetD -> Property +eqEof' getD = + x *> isEmpty ==! x *> isEmpty2 + where + x = buildGet getD + + +monadIdL :: GetD -> Property +monadIdL getD = + (return () >>= const x) ==~ x + where + x = buildGet getD + +monadIdL' :: GetD -> Property +monadIdL' getD = + (return () >>= const x) ==! x + where + x = buildGet getD + +monadIdR :: GetD -> Property +monadIdR getD = + (x >>= return) ==~ x + where + x = buildGet getD + +monadIdR' :: GetD -> Property +monadIdR' getD = + (x >>= return) ==! x + where + x = buildGet getD + +monadAssoc :: GetD -> GetD -> GetD -> Property +monadAssoc p1 p2 p3 = + (x >> (y >> z)) ==~ (x >> y >> z) + where + x = buildGet p1 + y = buildGet p2 + z = buildGet p3 + +monadAssoc' :: GetD -> GetD -> GetD -> Property +monadAssoc' p1 p2 p3 = + (x >> (y >> z)) ==! (x >> y >> z) + where + x = buildGet p1 + y = buildGet p2 + z = buildGet p3 + +alterIdL :: GetD -> Property +alterIdL getD = + empty <|> x ==~ x + where + x = buildGet getD + +alterIdL' :: GetD -> Property +alterIdL' getD = + empty <|> x ==! x + where + x = buildGet getD + +alterIdR :: GetD -> Property +alterIdR getD = + x <|> empty ==~ x + where + x = buildGet getD + +alterIdR' :: GetD -> Property +alterIdR' getD = + x <|> empty ==! x + where + x = buildGet getD + +alterAssoc :: GetD -> GetD -> GetD -> Property +alterAssoc p1 p2 p3 = + x <|> y <|> z ==~ x <|> (y <|> z) + where + x = buildGet p1 + y = buildGet p2 + z = buildGet p3 + +alterAssoc' :: GetD -> GetD -> GetD -> Property +alterAssoc' p1 p2 p3 = + x <|> y <|> z ==! x <|> (y <|> z) + where + x = buildGet p1 + y = buildGet p2 + z = buildGet p3 + +alterDistr :: GetD -> GetD -> GetD -> Property +alterDistr p1 p2 p3 = + x *> (y <|> z) ==~ x *> y <|> x *> z + where + x = buildGet p1 + y = buildGet p2 + z = buildGet p3 + +alterDistr' :: GetD -> GetD -> GetD -> Property +alterDistr' p1 p2 p3 = + x *> (y <|> z) ==! x *> y <|> x *> z + where + x = buildGet p1 + y = buildGet p2 + z = buildGet p3 + + +tests :: Test +tests = testGroup "GetTests" + [ testProperty "lazy - monad left id" monadIdL + , testProperty "strict - monad left id" monadIdL' + , testProperty "lazy - monad right id" monadIdR + , testProperty "strict - monad right id" monadIdR' + , testProperty "lazy - monad assoc" monadAssoc + , testProperty "strict - monad assoc" monadAssoc' + , testProperty "strict lazy - equality" eqStrictLazy + , testProperty "strict lazy - remaining equality"remainingStrictLazy + , testProperty "lazy - two eof" eqEof + , testProperty "strict - two eof" eqEof' + , testProperty "lazy - alternative left Id" alterIdL + , testProperty "strict - alternative left Id" alterIdL' + , testProperty "lazy - alternative right Id" alterIdR + , testProperty "strict - alternative right Id" alterIdR' + , testProperty "lazy - alternative assoc" alterAssoc + , testProperty "strict - alternative assoc" alterAssoc' + , testProperty "lazy - alternative distr" alterDistr + , testProperty "strict - alternative distr" alterDistr' + ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import qualified GetTests +import qualified RoundTrip + +import Test.Framework.Runners.Console + + +main :: IO () +main = defaultMain + [ GetTests.tests + , RoundTrip.tests + ] diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 --- a/tests/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -GHC = ghc -O2 -fforce-recomp -i../src - -all: bench qc - -bench:: Benchmark.hs MemBench.hs CBenchmark.o - $(GHC) -fliberate-case-threshold=1000 --make Benchmark.hs CBenchmark.o -o $@ - ./$@ 100 - -bench-prof: Benchmark.hs MemBench.hs CBenchmark.o - $(GHC) -prof -auto-all -rtsopts --make Benchmark.hs CBenchmark.o -o $@ - ./$@ 100 +RTS -p - -CBenchmark.o: CBenchmark.c - gcc -O3 -c $< -o $@ - -qc: Tests.hs - $(GHC) --make $< -o $@ - ./$@ - -clean: - $(RM) *.o *.hi bench qc - -.PHONY: clean bench bench-nb diff --git a/tests/MemBench.hs b/tests/MemBench.hs deleted file mode 100644 --- a/tests/MemBench.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} -module MemBench (memBench) where - -import Foreign -import Foreign.C - -import Control.Exception -import System.CPUTime -import Numeric - -memBench :: Int -> IO () -memBench mb = do - let bytes = mb * 2^20 - allocaBytes bytes $ \ptr -> do - let bench label test = do - seconds <- time $ test (castPtr ptr) (fromIntegral bytes) - let throughput = fromIntegral mb / seconds - putStrLn $ show mb ++ "MB of " ++ label - ++ " in " ++ showFFloat (Just 3) seconds "s, at: " - ++ showFFloat (Just 1) throughput "MB/s" - bench "setup " c_wordwrite - putStrLn "" - putStrLn "C memory throughput benchmarks:" - bench "bytes written" c_bytewrite - bench "bytes read " c_byteread - bench "words written" c_wordwrite - bench "words read " c_wordread - putStrLn "" - putStrLn "Haskell memory throughput benchmarks:" - bench "bytes written" hs_bytewrite - bench "bytes read " hs_byteread - bench "words written" hs_wordwrite - bench "words read " hs_wordread - -hs_bytewrite :: Ptr CUChar -> Int -> IO () -hs_bytewrite !ptr bytes = loop 0 0 - where iterations = bytes - loop :: Int -> CUChar -> IO () - loop !i !n | i == iterations = return () - | otherwise = do pokeByteOff ptr i n - loop (i+1) (n+1) - -hs_byteread :: Ptr CUChar -> Int -> IO CUChar -hs_byteread !ptr bytes = loop 0 0 - where iterations = bytes - loop :: Int -> CUChar -> IO CUChar - loop !i !n | i == iterations = return n - | otherwise = do x <- peekByteOff ptr i - loop (i+1) (n+x) - -hs_wordwrite :: Ptr CULong -> Int -> IO () -hs_wordwrite !ptr bytes = loop 0 0 - where iterations = bytes `div` sizeOf (undefined :: CULong) - loop :: Int -> CULong -> IO () - loop !i !n | i == iterations = return () - | otherwise = do pokeByteOff ptr i n - loop (i+1) (n+1) - -hs_wordread :: Ptr CULong -> Int -> IO CULong -hs_wordread !ptr bytes = loop 0 0 - where iterations = bytes `div` sizeOf (undefined :: CULong) - loop :: Int -> CULong -> IO CULong - loop !i !n | i == iterations = return n - | otherwise = do x <- peekByteOff ptr i - loop (i+1) (n+x) - - -foreign import ccall unsafe "CBenchmark.h byteread" - c_byteread :: Ptr CUChar -> CInt -> IO () - -foreign import ccall unsafe "CBenchmark.h bytewrite" - c_bytewrite :: Ptr CUChar -> CInt -> IO () - -foreign import ccall unsafe "CBenchmark.h wordread" - c_wordread :: Ptr CUInt -> CInt -> IO () - -foreign import ccall unsafe "CBenchmark.h wordwrite" - c_wordwrite :: Ptr CUInt -> CInt -> IO () - -time :: IO a -> IO Double -time action = do - start <- getCPUTime - action - end <- getCPUTime - return $! (fromIntegral (end - start)) / (10^12) diff --git a/tests/RoundTrip.hs b/tests/RoundTrip.hs new file mode 100644 --- /dev/null +++ b/tests/RoundTrip.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : +-- Copyright : (c) Galois, Inc, 2009 +-- License : AllRightsReserved +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- +module RoundTrip where + +import Data.Serialize +import Data.Serialize.Get +import Data.Serialize.Put +import Data.Serialize.IEEE754 +import Data.Word (Word8,Word16,Word32,Word64) +import System.Exit (ExitCode(..), exitSuccess, exitWith) +import Test.QuickCheck as QC + +import Test.Framework (Test(),testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + + +roundTrip :: Eq a => Putter a -> Get a -> a -> Bool +roundTrip p g a = res == Right a + where res = runGet g (runPut (p a)) + +-- | Did a call to 'quickCheckResult' succeed? +isSuccess :: QC.Result -> Bool +isSuccess (Success _ _ _) = True +isSuccess _ = False + +tests :: Test +tests = testGroup "Round Trip" + [ testProperty "Word8 Round Trip" $ roundTrip putWord8 getWord8 + , testProperty "Word16be Round Trip" $ roundTrip putWord16be getWord16be + , testProperty "Word16le Round Trip" $ roundTrip putWord16le getWord16le + , testProperty "Word32be Round Trip" $ roundTrip putWord32be getWord32be + , testProperty "Word32le Round Trip" $ roundTrip putWord32le getWord32le + , testProperty "Word64be Round Trip" $ roundTrip putWord64be getWord64be + , testProperty "Word64le Round Trip" $ roundTrip putWord64le getWord64le + , testProperty "Word16host Round Trip" $ roundTrip putWord16host getWord16host + , testProperty "Word32host Round Trip" $ roundTrip putWord32host getWord32host + , testProperty "Word64host Round Trip" $ roundTrip putWord64host getWord64host + , testProperty "Float32le Round Trip" $ roundTrip putFloat32le getFloat32le + , testProperty "Float32be Round Trip" $ roundTrip putFloat32be getFloat32be + , testProperty "Float64le Round Trip" $ roundTrip putFloat64le getFloat64le + , testProperty "Float64be Round Trip" $ roundTrip putFloat64be getFloat64be + + -- Containers + , testProperty "(Word8,Word8) Round Trip" + $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8) + , testProperty "[Word8] Round Trip" + $ roundTrip (putListOf putWord8) (getListOf getWord8) + , testProperty "Maybe Word8 Round Trip" + $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8) + , testProperty "Either Word8 Word16be Round Trip " + $ roundTrip (putEitherOf putWord8 putWord16be) + (getEitherOf getWord8 getWord16be) + ] diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 --- a/tests/Tests.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} - --------------------------------------------------------------------------------- --- | --- Module : --- Copyright : (c) Galois, Inc, 2009 --- License : AllRightsReserved --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -import Data.Serialize -import Data.Serialize.Get -import Data.Serialize.Put -import Data.Serialize.IEEE754 -import Data.Word (Word8,Word16,Word32,Word64) -import Test.QuickCheck as QC - - -roundTrip :: Eq a => Putter a -> Get a -> a -> Bool -roundTrip p g a = res == Right a - where res = runGet g (runPut (p a)) - -main :: IO () -main = mapM_ quickCheck - [ QC.label "Word8 Round Trip" $ roundTrip putWord8 getWord8 - , QC.label "Word16be Round Trip" $ roundTrip putWord16be getWord16be - , QC.label "Word16le Round Trip" $ roundTrip putWord16le getWord16le - , QC.label "Word32be Round Trip" $ roundTrip putWord32be getWord32be - , QC.label "Word32le Round Trip" $ roundTrip putWord32le getWord32le - , QC.label "Word64be Round Trip" $ roundTrip putWord64be getWord64be - , QC.label "Word64le Round Trip" $ roundTrip putWord64le getWord64le - , QC.label "Word16host Round Trip" $ roundTrip putWord16host getWord16host - , QC.label "Word32host Round Trip" $ roundTrip putWord32host getWord32host - , QC.label "Word64host Round Trip" $ roundTrip putWord64host getWord64host - , QC.label "Float32le Round Trip" $ roundTrip putFloat32le getFloat32le - , QC.label "Float32be Round Trip" $ roundTrip putFloat32be getFloat32be - , QC.label "Float64le Round Trip" $ roundTrip putFloat64le getFloat64le - , QC.label "Float64be Round Trip" $ roundTrip putFloat64be getFloat64be - - -- Containers - , QC.label "(Word8,Word8) Round Trip" - $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8) - , QC.label "[Word8] Round Trip" - $ roundTrip (putListOf putWord8) (getListOf getWord8) - , QC.label "Maybe Word8 Round Trip" - $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8) - , QC.label "Either Word8 Word16be Round Trip " - $ roundTrip (putEitherOf putWord8 putWord16be) - (getEitherOf getWord8 getWord16be) - ]