diff --git a/README b/README --- a/README +++ b/README @@ -12,9 +12,9 @@ Building: - runhaskell Setup.hs configure - runhaskell Setup.hs build - runhaskell Setup.hs install + runhaskell Setup.lhs configure + runhaskell Setup.lhs build + runhaskell Setup.lhs install First: import Data.Binary @@ -22,6 +22,40 @@ and then write an instance of Binary for the type you wish to serialise. More information in the haddock documentation. +Deriving: + +It is possible to mechanically derive new instances of Binary for your +types, if they support the Data and Typeable classes. A script is +provided in tools/derive. Here's an example of its use. + + $ cd binary + $ cd tools/derive + + $ ghci -fglasgow-exts BinaryDerive.hs + + *BinaryDerive> :l Example.hs + + *Main> deriveM (undefined :: Drinks) + + instance Binary Main.Drinks where + put (Beer a) = putWord8 0 >> put a + put Coffee = putWord8 1 + put Tea = putWord8 2 + put EnergyDrink = putWord8 3 + put Water = putWord8 4 + put Wine = putWord8 5 + put Whisky = putWord8 6 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Beer a) + 1 -> return Coffee + 2 -> return Tea + 3 -> return EnergyDrink + 4 -> return Water + 5 -> return Wine + 6 -> return Whisky + Contributors: Lennart Kolmodin @@ -32,3 +66,9 @@ Björn Bringert Ross Paterson Einar Karttunen + John Meacham + Ulf Norell + Tomasz Zielonka + Stefan Karrmann + Bryan O'Sullivan + Florian Weimer diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,11 +1,14 @@ name: binary -version: 0.2 +version: 0.3 license: BSD3 license-file: LICENSE author: Lennart Kolmodin maintainer: Lennart Kolmodin -description: Efficient, pure binary serialisation using lazy ByteStrings -synopsis: Binary serialization using lazy ByteStrings +homepage: http://www.cse.unsw.edu.au/~dons/binary.html +description: Efficient, pure binary serialisation using lazy ByteStrings. + Haskell values may be encoded to and form binary formats, + written to disk as binary, or set over the network. +synopsis: Binary serialization for Haskell values using lazy ByteStrings category: Data, Parsing build-depends: base -- ghc 6.4 also needs package fps @@ -13,7 +16,7 @@ Data.Binary.Put, Data.Binary.Get, Data.Binary.Builder -extensions: ForeignFunctionInterface,CPP,FlexibleInstances +extensions: CPP,FlexibleInstances hs-source-dirs: src ghc-options: -O2 -Wall -Werror -fliberate-case-threshold=1000 extra-source-files: README diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs --- a/src/Data/Binary.hs +++ b/src/Data/Binary.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Binary @@ -76,6 +77,7 @@ import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet +import qualified Data.Ratio as R import qualified Data.Tree as T @@ -144,6 +146,46 @@ -- Note how we write an initial tag byte to indicate each variant of the -- data type. -- +-- We can simplify the writing of 'get' instances using monadic +-- combinators: +-- +-- > get = do tag <- getWord8 +-- > case tag of +-- > 0 -> liftM IntE get +-- > 1 -> liftM3 OpE get get get +-- +-- The generation of Binary instances has been automated by a script +-- using Scrap Your Boilerplate generics. Use the script here: +-- . +-- +-- To derive the instance for a type, load this script into GHCi, and +-- bring your type into scope. Your type can then have its Binary +-- instances derived as follows: +-- +-- > $ ghci -fglasgow-exts BinaryDerive.hs +-- > *BinaryDerive> :l Example.hs +-- > *Main> deriveM (undefined :: Drinks) +-- > +-- > instance Binary Main.Drinks where +-- > put (Beer a) = putWord8 0 >> put a +-- > put Coffee = putWord8 1 +-- > put Tea = putWord8 2 +-- > put EnergyDrink = putWord8 3 +-- > put Water = putWord8 4 +-- > put Wine = putWord8 5 +-- > put Whisky = putWord8 6 +-- > get = do +-- > tag_ <- getWord8 +-- > case tag_ of +-- > 0 -> get >>= \a -> return (Beer a) +-- > 1 -> return Coffee +-- > 2 -> return Tea +-- > 3 -> return EnergyDrink +-- > 4 -> return Water +-- > 5 -> return Wine +-- > 6 -> return Whisky +-- > +-- -- To serialise this to a bytestring, we use 'encode', which packs the -- data structure into a binary format, in a lazy bytestring -- @@ -421,6 +463,10 @@ -} +instance (Binary a,Integral a) => Binary (R.Ratio a) where + put r = put (R.numerator r) >> put (R.denominator r) + get = liftM2 (R.%) get get + ------------------------------------------------------------------------ -- Char is serialised as UTF-8 @@ -597,6 +643,17 @@ get = fmap Seq.fromList get #endif + +------------------------------------------------------------------------ +-- Floating point + +instance Binary Double where + put d = put (decodeFloat d) + get = liftM2 encodeFloat get get + +instance Binary Float where + put f = put (decodeFloat f) + get = liftM2 encodeFloat get get ------------------------------------------------------------------------ -- Trees diff --git a/src/Data/Binary/Builder.hs b/src/Data/Binary/Builder.hs --- a/src/Data/Binary/Builder.hs +++ b/src/Data/Binary/Builder.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fglasgow-exts #-} -- for unboxed shifts @@ -46,6 +47,12 @@ , putWord32le -- :: Word32 -> Builder , putWord64le -- :: Word64 -> Builder + -- ** Host-endian, unaligned writes + , putWordhost -- :: Word -> Builder + , putWord16host -- :: Word16 -> Builder + , putWord32host -- :: Word32 -> Builder + , putWord64host -- :: Word64 -> Builder + ) where import Foreign @@ -124,7 +131,6 @@ -- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ -- fromLazyByteString :: L.ByteString -> Builder -fromLazyByteString (S.LPS []) = empty fromLazyByteString (S.LPS bss) = flush `append` mapBuilder (bss ++) ------------------------------------------------------------------------ @@ -209,7 +215,22 @@ return $! Buffer fp 0 0 size ------------------------------------------------------------------------ +-- 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 [1] 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 @@ -320,6 +341,38 @@ -- 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 diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fglasgow-exts #-} -- for unboxed shifts @@ -25,6 +26,7 @@ -- * The Get type Get , runGet + , runGetState -- * Parsing , skip @@ -33,6 +35,9 @@ , lookAheadM , lookAheadE , uncheckedLookAhead + + -- * Utility + , bytesRead , getBytes , remaining , isEmpty @@ -43,20 +48,27 @@ -- ** ByteStrings , getByteString , getLazyByteString + , getRemainingLazyByteString -- ** Big-endian reads , getWord16be - , getWord16le , getWord32be + , getWord64be -- ** Little-endian reads + , getWord16le , getWord32le - , getWord64be , getWord64le + -- ** Host-endian, unaligned reads + , getWordhost + , getWord16host + , getWord32host + , getWord64host + ) where -import Control.Monad (liftM,when) +import Control.Monad (when) import Data.Maybe (isNothing) import qualified Data.ByteString as B @@ -65,6 +77,10 @@ import Foreign +-- used by splitAtST +import Control.Monad.ST +import Data.STRef + #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word @@ -72,11 +88,12 @@ #endif -- | The parse state -data S = S {-# UNPACK #-} !L.ByteString -- the rest of the input - {-# UNPACK #-} !Int64 -- bytes read +data S = S {-# UNPACK #-} !B.ByteString -- current chunk + L.ByteString -- the rest of the input + {-# UNPACK #-} !Int64 -- bytes read -- | The Get monad is just a State monad carrying around the input ByteString -newtype Get a = Get { unGet :: S -> (a, S ) } +newtype Get a = Get { unGet :: S -> (a, S) } instance Functor Get where fmap f m = Get (\s -> let (a, s') = unGet m s @@ -98,30 +115,54 @@ ------------------------------------------------------------------------ +initState :: L.ByteString -> S +initState (B.LPS xs) = + case xs of + [] -> S B.empty L.empty 0 + (x:xs') -> S x (B.LPS xs') 0 +{-# INLINE initState #-} + +mkState :: L.ByteString -> Int64 -> S +mkState (B.LPS xs) = + case xs of + [] -> S B.empty L.empty + (x:xs') -> S x (B.LPS xs') +{-# INLINE mkState #-} + -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGet :: Get a -> L.ByteString -> a -runGet m str = case unGet m (S str 0) of (a, _) -> a +runGet m str = case unGet m (initState str) of (a, _) -> a +-- | Run the Get monad applies a 'get'-based parser on the input +-- ByteString. Additional to the result of get it returns the number of +-- consumed bytes and the rest of the input. +runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64) +runGetState m str off = + case unGet m (mkState str off) of + (a, S s ss newOff) -> (a, s `join` ss, newOff) + ------------------------------------------------------------------------ failDesc :: String -> Get a failDesc err = do - S _ bytes <- get + S _ _ bytes <- get Get (error (err ++ ". Failed reading at byte position " ++ show bytes)) -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. skip :: Int -> Get () -skip n = readN n (const ()) +skip n = readN (fromIntegral n) (const ()) --- | Skip ahead @n@ bytes. -uncheckedSkip :: Int -> Get () +-- | Skip ahead @n@ bytes. No error if there isn't enough bytes. +uncheckedSkip :: Int64 -> Get () uncheckedSkip n = do - S s bytes <- get - let rest = L.drop (fromIntegral n) s - put $! S rest (bytes + (fromIntegral n)) - return () + S s ss bytes <- get + if fromIntegral (B.length s) >= n + then put (S (B.drop (fromIntegral n) s) ss (bytes + n)) + else do + let rest = L.drop (n - fromIntegral (B.length s)) ss + put $! mkState rest (bytes + n) --- | Run @ga@, but return withou consuming its input. +-- | Run @ga@, but return without consuming its input. -- Fails if @ga@ fails. lookAhead :: Get a -> Get a lookAhead ga = do @@ -130,7 +171,7 @@ put s return a --- | Like 'lookAhead', but consume the input if @g@ returns 'Just _'. +-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. -- Fails if @gma@ fails. lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM gma = do @@ -140,7 +181,7 @@ put s return ma --- | Like 'lookAhead', but consume the input if @g@ returns 'Right _'. +-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. -- Fails if @gea@ fails. lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE gea = do @@ -152,149 +193,234 @@ return ea -- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. -uncheckedLookAhead :: Int -> Get L.ByteString +uncheckedLookAhead :: Int64 -> Get L.ByteString uncheckedLookAhead n = do - S s _ <- get - return $ L.take (fromIntegral n) s + S s ss _ <- get + if n <= fromIntegral (B.length s) + then return (L.fromChunks [B.take (fromIntegral n) s]) + else return $ L.take n (s `join` ss) +------------------------------------------------------------------------ +-- Utility + +-- | Get the total number of bytes read to this point. +bytesRead :: Get Int64 +bytesRead = do + S _ _ b <- get + return b + -- | Get the number of remaining unparsed bytes. -- Useful for checking whether all input has been consumed. -- Note that this forces the rest of the input. remaining :: Get Int64 remaining = do - S s _ <- get - return (L.length s) + S s ss _ <- get + return (fromIntegral (B.length s) + L.length ss) -- | Test whether all input has been consumed, -- i.e. there are no remaining unparsed bytes. isEmpty :: Get Bool isEmpty = do - S s _ <- get - return (L.null s) + S s ss _ <- get + return (B.null s && L.null ss) ------------------------------------------------------------------------ --- Helpers +-- Utility with ByteStrings --- Fail if the ByteString does not have the right size. -takeExactly :: Int -> L.ByteString -> Get L.ByteString -takeExactly n bs - | l == n = return bs - | otherwise = fail $ concat [ "Data.Binary.Get.takeExactly: Wanted " - , show n, " bytes, found ", show l, "." ] - where l = fromIntegral (L.length bs) -{-# INLINE takeExactly #-} +-- | An efficient 'get' method for strict ByteStrings. Fails if fewer +-- than @n@ bytes are left in the input. +getByteString :: Int -> Get B.ByteString +getByteString n = readN n id +{-# INLINE getByteString #-} --- | Pull up to @n@ bytes from the input. -getBytes :: Int -> Get L.ByteString +-- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than +-- @n@ bytes are left in the input. +getLazyByteString :: Int64 -> Get L.ByteString +getLazyByteString n = do + S s ss bytes <- get + let big = s `join` ss + case splitAtST n big of + (consume, rest) -> do put $ mkState rest (bytes + n) + return consume +{-# INLINE getLazyByteString #-} + +-- | Get the remaining bytes as a lazy ByteString +getRemainingLazyByteString :: Get L.ByteString +getRemainingLazyByteString = do + S s ss _ <- get + return (s `join` ss) + +------------------------------------------------------------------------ +-- Helpers + +-- | Pull @n@ bytes from the input, as a strict ByteString. +getBytes :: Int -> Get B.ByteString getBytes n = do - S s bytes <- get - let (consuming, rest) = L.splitAt (fromIntegral n) s - put $! S rest (bytes + (fromIntegral n)) - return consuming + S s ss bytes <- get + if n <= B.length s + then do let (consume,rest) = B.splitAt n s + put $! S rest ss (bytes + fromIntegral n) + return $! consume + else + case L.splitAt (fromIntegral n) (s `join` ss) of + (consuming, rest) -> + do let now = B.concat . L.toChunks $ consuming + put $! mkState rest (bytes + fromIntegral n) + -- forces the next chunk before this one is returned + when (B.length now < n) $ + fail "too few bytes" + return now {-# INLINE getBytes #-} -- ^ important +join :: B.ByteString -> L.ByteString -> L.ByteString +join bb (B.LPS lb) + | B.null bb = B.LPS lb + | otherwise = B.LPS (bb:lb) + -- don't use L.append, it's strict in it's second argument :/ +{-# INLINE join #-} + +-- | Split a ByteString. If the first result is consumed before the -- +-- second, this runs in constant heap space. +-- +-- You must force the returned tuple for that to work, e.g. +-- +-- > case splitAtST n xs of +-- > (ys,zs) -> consume ys ... consume zs +-- +splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString) +splitAtST i p | i <= 0 = (L.empty, p) +splitAtST i (B.LPS ps) = runST ( + do r <- newSTRef undefined + xs <- first r i ps + ys <- unsafeInterleaveST (readSTRef r) + return (B.LPS xs, B.LPS ys)) + where first r 0 xs = writeSTRef r xs >> return [] + first r _ [] = writeSTRef r [] >> return [] + first r n (x:xs) + | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs) + return [B.take (fromIntegral n) x] + | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs))) + fmap (x:) $ unsafeInterleaveST (first r (n - l) xs) + where l = fromIntegral (B.length x) +{-# INLINE splitAtST #-} + -- Pull n bytes from the input, and apply a parser to those bytes, --- yielding a value -readN :: Int -> (L.ByteString -> a) -> Get a -readN n f = liftM f (getBytes n >>= takeExactly n) +-- yielding a value. If less than @n@ bytes are available, fail with an +-- error. This wraps @getBytes@. +readN :: Int -> (B.ByteString -> a) -> Get a +readN n f = fmap f $ getBytes n {-# INLINE readN #-} -- ^ important ------------------------------------------------------------------------ +-- Primtives --- | An efficient 'get' method for strict ByteStrings -getByteString :: Int -> Get B.ByteString -getByteString n = readN (fromIntegral n) (B.concat . L.toChunks) -{-# INLINE getByteString #-} +-- helper, get a raw Ptr onto a strict ByteString copied out of the +-- underlying lazy byteString. So many indirections from the raw parser +-- state that my head hurts... --- | An efficient 'get' method for lazy ByteStrings. Fails if fewer than --- @n@ bytes are left in the input. -getLazyByteString :: Int -> Get L.ByteString -getLazyByteString n = readN n id -{-# INLINE getLazyByteString #-} +getPtr :: Storable a => Int -> Get a +getPtr n = do + (fp,o,_) <- readN n B.toForeignPtr + return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) +{-# INLINE getPtr #-} ------------------------------------------------------------------------ --- Primtives -- | Read a Word8 from the monad state getWord8 :: Get Word8 -getWord8 = readN 1 L.head +getWord8 = getPtr (sizeOf (undefined :: Word8)) {-# INLINE getWord8 #-} -- | Read a Word16 in big endian format getWord16be :: Get Word16 getWord16be = do - s <- readN 2 (L.take 2) - return $! (fromIntegral (s `L.index` 0) `shiftl_w16` 8) .|. - (fromIntegral (s `L.index` 1)) + s <- readN 2 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `B.index` 1)) {-# INLINE getWord16be #-} -- | Read a Word16 in little endian format getWord16le :: Get Word16 getWord16le = do - w1 <- liftM fromIntegral getWord8 - w2 <- liftM fromIntegral getWord8 - return $! w2 `shiftl_w16` 8 .|. w1 + s <- readN 2 id + return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `B.index` 0) ) {-# INLINE getWord16le #-} -- | Read a Word32 in big endian format getWord32be :: Get Word32 getWord32be = do - s <- readN 4 (L.take 4) - return $! (fromIntegral (s `L.index` 0) `shiftl_w32` 24) .|. - (fromIntegral (s `L.index` 1) `shiftl_w32` 16) .|. - (fromIntegral (s `L.index` 2) `shiftl_w32` 8) .|. - (fromIntegral (s `L.index` 3) ) + s <- readN 4 id + 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) ) {-# INLINE getWord32be #-} -- | Read a Word32 in little endian format getWord32le :: Get Word32 getWord32le = do - w1 <- liftM fromIntegral getWord8 - w2 <- liftM fromIntegral getWord8 - w3 <- liftM fromIntegral getWord8 - w4 <- liftM fromIntegral getWord8 - return $! (w4 `shiftl_w32` 24) .|. - (w3 `shiftl_w32` 16) .|. - (w2 `shiftl_w32` 8) .|. - (w1) + s <- readN 4 id + 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) ) {-# INLINE getWord32le #-} -- | Read a Word64 in big endian format getWord64be :: Get Word64 getWord64be = do - s <- readN 8 (L.take 8) - return $! (fromIntegral (s `L.index` 0) `shiftl_w64` 56) .|. - (fromIntegral (s `L.index` 1) `shiftl_w64` 48) .|. - (fromIntegral (s `L.index` 2) `shiftl_w64` 40) .|. - (fromIntegral (s `L.index` 3) `shiftl_w64` 32) .|. - (fromIntegral (s `L.index` 4) `shiftl_w64` 24) .|. - (fromIntegral (s `L.index` 5) `shiftl_w64` 16) .|. - (fromIntegral (s `L.index` 6) `shiftl_w64` 8) .|. - (fromIntegral (s `L.index` 7) ) + s <- readN 8 id + 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) ) {-# INLINE getWord64be #-} -- | Read a Word64 in little endian format getWord64le :: Get Word64 getWord64le = do - w1 <- liftM fromIntegral getWord8 - w2 <- liftM fromIntegral getWord8 - w3 <- liftM fromIntegral getWord8 - w4 <- liftM fromIntegral getWord8 - w5 <- liftM fromIntegral getWord8 - w6 <- liftM fromIntegral getWord8 - w7 <- liftM fromIntegral getWord8 - w8 <- liftM fromIntegral getWord8 - return $! (w8 `shiftl_w64` 56) .|. - (w7 `shiftl_w64` 48) .|. - (w6 `shiftl_w64` 40) .|. - (w5 `shiftl_w64` 32) .|. - (w4 `shiftl_w64` 24) .|. - (w3 `shiftl_w64` 16) .|. - (w2 `shiftl_w64` 8) .|. - (w1) + s <- readN 8 id + 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) ) {-# INLINE getWord64le #-} + +------------------------------------------------------------------------ +-- Host-endian reads + +-- | /O(1)./ Read a single native machine word. The word is read 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. +getWordhost :: Get Word +getWordhost = getPtr (sizeOf (undefined :: Word)) +{-# INLINE getWordhost #-} + +-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. +getWord16host :: Get Word16 +getWord16host = getPtr (sizeOf (undefined :: Word16)) +{-# INLINE getWord16host #-} + +-- | /O(1)./ Read a Word32 in native host order and host endianness. +getWord32host :: Get Word32 +getWord32host = getPtr (sizeOf (undefined :: Word32)) +{-# INLINE getWord32host #-} + +-- | /O(1)./ Read a Word64 in native host order and host endianess. +getWord64host :: Get Word64 +getWord64host = getPtr (sizeOf (undefined :: Word64)) +{-# INLINE getWord64host #-} ------------------------------------------------------------------------ -- Unchecked shifts diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs --- a/src/Data/Binary/Put.hs +++ b/src/Data/Binary/Put.hs @@ -16,6 +16,7 @@ -- * The Put type Put + , PutM(..) , runPut -- * Flushing the implicit parse state @@ -36,6 +37,12 @@ , putWord32le , putWord64le + -- * Host-endian, unaligned writes + , putWordhost -- :: Word -> Put + , putWord16host -- :: Word16 -> Put + , putWord32host -- :: Word32 -> Put + , putWord64host -- :: Word64 -> Put + ) where import Data.Binary.Builder (Builder, toLazyByteString) @@ -47,9 +54,10 @@ ------------------------------------------------------------------------ --- | The Put types. A Writer monad over the efficient Builder monoid. --- Put merely lifts Builder into a monad +-- | The PutM type. A Writer monad over the efficient Builder monoid. newtype PutM a = Put { unPut :: (a, Builder) } + +-- | Put merely lifts Builder into a Write monad, applied to (). type Put = PutM () instance Functor PutM where @@ -124,3 +132,34 @@ putWord64le :: Word64 -> Put putWord64le = tell . B.putWord64le {-# INLINE putWord64le #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ Write 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 -> Put +putWordhost = tell . B.putWordhost +{-# INLINE putWordhost #-} + +-- | /O(1)./ Write a Word16 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord16host :: Word16 -> Put +putWord16host = tell . B.putWord16host +{-# INLINE putWord16host #-} + +-- | /O(1)./ Write a Word32 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord32host :: Word32 -> Put +putWord32host = tell . B.putWord32host +{-# 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 :: Word64 -> Put +putWord64host = tell . B.putWord64host +{-# INLINE putWord64host #-} diff --git a/tests/Benchmark.hs b/tests/Benchmark.hs --- a/tests/Benchmark.hs +++ b/tests/Benchmark.hs @@ -1,590 +1,1462 @@ -module Main (main) where - -import qualified Data.ByteString.Lazy as L -import Data.Binary -import Data.Binary.Put -import Data.Binary.Get - -import Control.Exception -import System.CPUTime -import Numeric - -import MemBench - -mb :: Int -mb = 10 - -main :: IO () -main = do - memBench (mb*10) - putStrLn "" - putStrLn "Binary (de)serialisation benchmarks:" - sequence_ - [ test wordSize chunkSize mb - | wordSize <- [1,2,4,8] - , chunkSize <- [1,2,4,8,16] ] - -time :: IO a -> IO Double -time action = do - start <- getCPUTime - action - end <- getCPUTime - return $! (fromIntegral (end - start)) / (10^12) - -test :: Int -> Int -> Int -> IO () -test wordSize chunkSize mb = do - let bytes :: Int - bytes = mb * 2^20 - iterations = bytes `div` wordSize - bs = runPut (doPut wordSize chunkSize iterations) - sum = runGet (doGet wordSize chunkSize iterations) bs - putStr $ show mb ++ "MB of Word" ++ show (8 * wordSize) - ++ " in chunks of " ++ show chunkSize ++ ": " - putSeconds <- time $ evaluate (L.length bs) - getSeconds <- time $ evaluate sum --- print (L.length bs, sum) - let putThroughput = fromIntegral mb / putSeconds - getThroughput = fromIntegral mb / getSeconds - putStrLn $ showFFloat (Just 1) putThroughput "MB/s write, " - ++ showFFloat (Just 1) getThroughput "MB/s read" - -doPut :: Int -> Int -> Int -> Put -doPut wordSize chunkSize = - case (wordSize, chunkSize) of - (1, 1) -> putWord8N1 - (1, 2) -> putWord8N2 - (1, 4) -> putWord8N4 - (1, 8) -> putWord8N8 - (1, 16) -> putWord8N16 - (2, 1) -> putWord16N1 - (2, 2) -> putWord16N2 - (2, 4) -> putWord16N4 - (2, 8) -> putWord16N8 - (2, 16) -> putWord16N16 - (4, 1) -> putWord32N1 - (4, 2) -> putWord32N2 - (4, 4) -> putWord32N4 - (4, 8) -> putWord32N8 - (4, 16) -> putWord32N16 - (8, 1) -> putWord64N1 - (8, 2) -> putWord64N2 - (8, 4) -> putWord64N4 - (8, 8) -> putWord64N8 - (8, 16) -> putWord64N16 - -putWord8N1 = loop 0 - where loop s n | s `seq` n `seq` False = undefined - loop _ 0 = return () - loop s n = do - putWord8 (s+0) - 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) - - -putWord16N1 = 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) - -putWord16N2 = 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) - -putWord16N4 = 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) - -putWord16N8 = 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) - -putWord16N16 = 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) - - -putWord32N1 = 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) - -putWord32N2 = 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) - -putWord32N4 = 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) - -putWord32N8 = 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) - -putWord32N16 = 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) - -putWord64N1 = 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) - -putWord64N2 = 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) - -putWord64N4 = 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) - -putWord64N8 = 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) - -putWord64N16 = 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) - - -doGet :: Int -> Int -> Int -> Get Int -doGet wordSize chunkSize = - case (wordSize, chunkSize) 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) -> fmap fromIntegral . getWord16N1 - (2, 2) -> fmap fromIntegral . getWord16N2 - (2, 4) -> fmap fromIntegral . getWord16N4 - (2, 8) -> fmap fromIntegral . getWord16N8 - (2, 16) -> fmap fromIntegral . getWord16N16 - (4, 1) -> fmap fromIntegral . getWord32N1 - (4, 2) -> fmap fromIntegral . getWord32N2 - (4, 4) -> fmap fromIntegral . getWord32N4 - (4, 8) -> fmap fromIntegral . getWord32N8 - (4, 16) -> fmap fromIntegral . getWord32N16 - (8, 1) -> fmap fromIntegral . getWord64N1 - (8, 2) -> fmap fromIntegral . getWord64N2 - (8, 4) -> fmap fromIntegral . getWord64N4 - (8, 8) -> fmap fromIntegral . getWord64N8 - (8, 16) -> fmap fromIntegral . getWord64N16 - -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) - - -getWord16N1 = 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) - -getWord16N2 = 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) - -getWord16N4 = 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) - -getWord16N8 = 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) - -getWord16N16 = 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) - - -getWord32N1 = 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) - -getWord32N2 = 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) - -getWord32N4 = 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) - -getWord32N8 = 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) - -getWord32N16 = 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) - -getWord64N1 = 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) - -getWord64N2 = 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) - -getWord64N4 = 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) - -getWord64N8 = 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) - -getWord64N16 = 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 +{-# OPTIONS -fbang-patterns #-} +module Main (main) where + +import qualified Data.ByteString.Lazy as L +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +import Control.Exception +import System.CPUTime +import Numeric +import Text.Printf + +import MemBench + +data Endian + = Big + | Little + | Host + deriving (Eq,Ord,Show) + +mb :: Int +mb = 10 + +main :: IO () +main = do + memBench (mb*10) + putStrLn "" + putStrLn "Binary (de)serialisation benchmarks:" + + -- do bytewise + sequence_ + [ test wordSize chunkSize Host mb + | wordSize <- [1] + , chunkSize <- [1,2,4,8,16] + ] + + -- now Word16 .. Word64 + sequence_ + [ test wordSize chunkSize end mb + | wordSize <- [2,4,8] + , chunkSize <- [1,2,4,8,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 --- a/tests/CBenchmark.c +++ b/tests/CBenchmark.c @@ -19,19 +19,19 @@ return n; } -void wordwrite(unsigned int *a, int bytes) { - unsigned int n = 0; +void wordwrite(unsigned long *a, int bytes) { + unsigned long n = 0; int i = 0; - int iterations = bytes / sizeof(unsigned int) ; + int iterations = bytes / sizeof(unsigned long) ; while (i < iterations) { a[i++] = n++; } } -unsigned int wordread(unsigned int *a, int bytes) { - unsigned int n = 0; +unsigned int wordread(unsigned long *a, int bytes) { + unsigned long n = 0; int i = 0; - int iterations = bytes / sizeof(unsigned int); + int iterations = bytes / sizeof(unsigned long); while (i < iterations) { n += a[i++]; } diff --git a/tests/CBenchmark.h b/tests/CBenchmark.h --- a/tests/CBenchmark.h +++ b/tests/CBenchmark.h @@ -1,4 +1,4 @@ void bytewrite(unsigned char *a, int bytes); unsigned char byteread(unsigned char *a, int bytes); -void wordwrite(unsigned int *a, int bytes); -unsigned int wordread(unsigned int *a, int bytes); +void wordwrite(unsigned long *a, int bytes); +unsigned int wordread(unsigned long *a, int bytes); diff --git a/tests/HeapUse.hs b/tests/HeapUse.hs new file mode 100644 --- /dev/null +++ b/tests/HeapUse.hs @@ -0,0 +1,17 @@ +-- Checks heap behavior of getBytes + +import Data.Binary.Get (runGet, getBytes) + +import Control.Monad (liftM) +import qualified Data.ByteString.Lazy as L + +main = do + let x = (L.take 110000042 $ L.iterate (+1) 0) + mapM_ (print . L.length) (chunks 20000000 x) + +chunks n = runGet (unfoldM f) + where f = do x <- getBytes 20000000 + return $ if L.null x then Nothing else Just x + +unfoldM :: Monad m => m (Maybe a) -> m [a] +unfoldM f = f >>= maybe (return []) (\x -> liftM (x:) (unfoldM f)) diff --git a/tests/Makefile b/tests/Makefile --- a/tests/Makefile +++ b/tests/Makefile @@ -21,6 +21,13 @@ hugs: runhugs -98 QC.hs + +HeapUse: HeapUse.hs + ghc --make -O $^ -fasm -o $@ + +heap: HeapUse + ./HeapUse +RTS -M10M -t/dev/stderr -RTS + clean: rm -f *.o *.hi qc bench bench-nb *~ diff --git a/tests/MemBench.hs b/tests/MemBench.hs --- a/tests/MemBench.hs +++ b/tests/MemBench.hs @@ -33,7 +33,7 @@ bench "words read " hs_wordread hs_bytewrite :: Ptr CUChar -> Int -> IO () -hs_bytewrite ptr bytes = loop 0 0 +hs_bytewrite !ptr bytes = loop 0 0 where iterations = bytes loop :: Int -> CUChar -> IO () loop !i !n | i == iterations = return () @@ -41,25 +41,25 @@ loop (i+1) (n+1) hs_byteread :: Ptr CUChar -> Int -> IO CUChar -hs_byteread ptr bytes = loop 0 0 +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 CUInt -> Int -> IO () -hs_wordwrite ptr bytes = loop 0 0 - where iterations = bytes `div` sizeOf (undefined :: CUInt) - loop :: Int -> CUInt -> IO () +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 CUInt -> Int -> IO CUInt -hs_wordread ptr bytes = loop 0 0 - where iterations = bytes `div` sizeOf (undefined :: CUInt) - loop :: Int -> CUInt -> IO CUInt +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) diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -42,13 +42,18 @@ prop_Word16be = roundTripWith putWord16be getWord16be prop_Word16le = roundTripWith putWord16le getWord16le +prop_Word16host = roundTripWith putWord16host getWord16host prop_Word32be = roundTripWith putWord32be getWord32be prop_Word32le = roundTripWith putWord32le getWord32le +prop_Word32host = roundTripWith putWord32host getWord32host prop_Word64be = roundTripWith putWord64be getWord64be prop_Word64le = roundTripWith putWord64le getWord64le +prop_Word64host = roundTripWith putWord64host getWord64host +prop_Wordhost = roundTripWith putWordhost getWordhost + invariant_lbs :: L.ByteString -> Bool invariant_lbs (B.LPS []) = True invariant_lbs (B.LPS xs) = all (not . B.null) xs @@ -112,10 +117,14 @@ -- Primitives , ("Word16be", p prop_Word16be) , ("Word16le", p prop_Word16le) + , ("Word16host", p prop_Word16host) , ("Word32be", p prop_Word32be) , ("Word32le", p prop_Word32le) + , ("Word32host", p prop_Word32host) , ("Word64be", p prop_Word64be) , ("Word64le", p prop_Word64le) + , ("Word64host", p prop_Word64host) + , ("Wordhost", p prop_Wordhost) -- higher level ones using the Binary class ,("()", p (test :: T () )) @@ -135,6 +144,9 @@ ,("Word", p (test :: T Word )) ,("Int", p (test :: T Int )) ,("Integer", p (test :: T Integer )) + + ,("Float", p (test :: T Float )) + ,("Double", p (test :: T Double )) ,("Char", p (test :: T Char )) diff --git a/tools/derive/BinaryDerive.hs b/tools/derive/BinaryDerive.hs --- a/tools/derive/BinaryDerive.hs +++ b/tools/derive/BinaryDerive.hs @@ -1,10 +1,14 @@ +{-# OPTIONS -fglasgow-exts #-} module BinaryDerive where import Data.Generics import Data.List -derive :: (Typeable a, Show a, Data a) => a -> String +deriveM :: (Typeable a, Data a) => a -> IO () +deriveM (a :: a) = mapM_ putStrLn . lines $ derive (undefined :: a) + +derive :: (Typeable a, Data a) => a -> String derive x = "instance " ++ context ++ "Binary " ++ inst ++ " where\n" ++ concat putDefs ++ getDefs @@ -39,7 +43,11 @@ (if length constrs > 1 then " get = do\n tag_ <- getWord8\n case tag_ of\n" else " get =") - ++ concatMap ((++"\n")) (map getDef constrs) + ++ concatMap ((++"\n")) (map getDef constrs) ++ + (if length constrs > 1 + then " _ -> fail \"no parse\"" + else "" + ) getDef (n, (name, ps)) = let wrap = if ps /= 0 then ("("++) . (++")") else id in