From 93a49d010388f03b8aaff879f8d48cd30c86fc20 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 14 Jan 2015 18:14:50 -0500 Subject: [PATCH] Move to bytestring Builder --- benchmarks/Builder.hs | 6 - binary.cabal | 12 +- src/Data/Binary/Builder.hs | 234 ++++++++++- src/Data/Binary/Builder/Base.hs | 621 ---------------------------- src/Data/Binary/Builder/Internal.hs | 28 -- 5 files changed, 232 insertions(+), 669 deletions(-) delete mode 100644 src/Data/Binary/Builder/Base.hs delete mode 100644 src/Data/Binary/Builder/Internal.hs diff --git a/benchmarks/Builder.hs b/benchmarks/Builder.hs index 3c48e7bf..88626848 100644 --- a/benchmarks/Builder.hs +++ b/benchmarks/Builder.hs @@ -21,12 +21,6 @@ import Data.Word (Word8) import Data.Binary.Builder -#if !MIN_VERSION_bytestring(0,10,0) -instance NFData S.ByteString -instance NFData L.ByteString where - rnf = rnf . L.toChunks -#endif - main :: IO () main = do evaluate $ rnf diff --git a/binary.cabal b/binary.cabal index b11a525a..8d94aa73 100644 --- a/binary.cabal +++ b/binary.cabal @@ -31,17 +31,15 @@ source-repository head location: git://github.com/kolmodin/binary.git library - build-depends: base >= 3.0 && < 5, bytestring >= 0.9, containers, array + build-depends: base >= 3.0 && < 5, bytestring >= 0.10.2, containers, array hs-source-dirs: src exposed-modules: Data.Binary, Data.Binary.Put, Data.Binary.Get, Data.Binary.Get.Internal, - Data.Binary.Builder, - Data.Binary.Builder.Internal + Data.Binary.Builder - other-modules: Data.Binary.Builder.Base, - Data.Binary.Class, + other-modules: Data.Binary.Class, Data.Binary.Internal if impl(ghc >= 7.2.1) @@ -70,7 +68,7 @@ test-suite qc Arbitrary build-depends: base >= 3.0 && < 5, - bytestring >= 0.9, + bytestring >= 0.10.2, random>=1.0.1.0, test-framework, test-framework-quickcheck2 >= 0.3, @@ -86,7 +84,7 @@ test-suite read-write-file main-is: File.hs build-depends: base >= 3.0 && < 5, - bytestring >= 0.9, + bytestring >= 0.10.2, Cabal, directory, filepath, diff --git a/src/Data/Binary/Builder.hs b/src/Data/Binary/Builder.hs index 59e80db4..773a432c 100644 --- a/src/Data/Binary/Builder.hs +++ b/src/Data/Binary/Builder.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MagicHash #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif + ----------------------------------------------------------------------------- -- | --- Module : Data.Binary.Builder +-- Module : Data.Binary.Builder.Base -- Copyright : Lennart Kolmodin, Ross Paterson -- License : BSD3-style (see LICENSE) -- @@ -12,12 +13,16 @@ -- Stability : experimental -- Portability : portable to Hugs and GHC -- --- Efficient construction of lazy bytestrings. +-- A module exporting types and functions that are shared by +-- 'Data.Binary.Builder' and 'Data.Binary.Builder.Internal'. -- ----------------------------------------------------------------------------- -module Data.Binary.Builder ( +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif +module Data.Binary.Builder ( -- * The Builder type Builder , toLazyByteString @@ -31,7 +36,6 @@ module Data.Binary.Builder ( #if MIN_VERSION_bytestring(0,10,4) , fromShortByteString -- :: T.ByteString -> Builder #endif - -- * Flushing the buffer state , flush @@ -65,6 +69,222 @@ module Data.Binary.Builder ( -- ** Unicode , putCharUtf8 - ) where + -- * Low-level construction of Builders + --, writeN + --, writeAtMost + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as T +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Prim as Prim +import Data.ByteString.Builder ( Builder, toLazyByteString ) +import Data.ByteString.Builder.Extra ( flush ) +import Data.Monoid +import Data.Word +import Foreign +import Prelude -- Silence AMP warning. + +------------------------------------------------------------------------ + +-- | /O(1)./ The empty Builder, satisfying +-- +-- * @'toLazyByteString' 'empty' = 'L.empty'@ +-- +empty :: Builder +empty = mempty +{-# INLINE empty #-} + +-- | /O(1)./ A Builder taking a single byte, satisfying +-- +-- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@ +-- +singleton :: Word8 -> Builder +singleton = B.word8 +{-# 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 = mappend +{-# INLINE append #-} + +-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@ +-- +fromByteString :: S.ByteString -> Builder +fromByteString = B.byteString +{-# INLINE fromByteString #-} + +-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ +-- +fromLazyByteString :: L.ByteString -> Builder +fromLazyByteString = B.lazyByteString +{-# INLINE fromLazyByteString #-} + +#if MIN_VERSION_bytestring(0,10,4) +-- | /O(n)./ A builder taking 'T.ShortByteString' and copy it to a Builder, +-- satisfying +-- +-- * @'toLazyByteString' ('fromShortByteString' bs) = 'L.fromChunks' ['T.fromShort' bs] +fromShortByteString :: T.ShortByteString -> Builder +fromShortByteString = B.shortByteString +{-# INLINE fromShortByteString #-} +#endif + +------------------------------------------------------------------------ + +-- +-- 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 = B.word16BE +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Builder +putWord16le = B.word16LE +{-# INLINE putWord16le #-} + +-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Builder +putWord32be = B.word32BE +{-# 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 = B.word32LE +{-# INLINE putWord32le #-} + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Builder +putWord64be = B.word64BE +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Builder +putWord64le = B.word64LE +{-# INLINE putWord64le #-} + +-- on a little endian machine: +-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) + + +-- | Write a Int16 in big endian format +putInt16be :: Int16 -> Builder +putInt16be = putWord16be . fromIntegral +{-# INLINE putInt16be #-} + +-- | Write a Int16 in little endian format +putInt16le :: Int16 -> Builder +putInt16le = putWord16le . fromIntegral +{-# INLINE putInt16le #-} + +-- | Write a Int32 in big endian format +putInt32be :: Int32 -> Builder +putInt32be = putWord32be . fromIntegral +{-# INLINE putInt32be #-} + +-- | Write a Int32 in little endian format +putInt32le :: Int32 -> Builder +putInt32le = putWord32le . fromIntegral +{-# INLINE putInt32le #-} + +-- | Write a Int64 in big endian format +putInt64be :: Int64 -> Builder +putInt64be = putWord64be . fromIntegral + +-- | Write a Int64 in little endian format +putInt64le :: Int64 -> Builder +putInt64le = putWord64le . fromIntegral + + + +------------------------------------------------------------------------ +-- 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 = Prim.primFixed Prim.wordHost +{-# INLINE putWordhost #-} + +-- | Write a Word16 in native host order and host endianness. +-- 2 bytes will be written, unaligned. +putWord16host :: Word16 -> Builder +putWord16host = Prim.primFixed Prim.word16Host +{-# INLINE putWord16host #-} + +-- | Write a Word32 in native host order and host endianness. +-- 4 bytes will be written, unaligned. +putWord32host :: Word32 -> Builder +putWord32host = Prim.primFixed Prim.word32Host +{-# 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 = Prim.primFixed Prim.word64Host +{-# INLINE putWord64host #-} + +-- | /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 Int 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. +-- +putInthost :: Int -> Builder +putInthost = Prim.primFixed Prim.intHost +{-# INLINE putInthost #-} + +-- | Write a Int16 in native host order and host endianness. +-- 2 bytes will be written, unaligned. +putInt16host :: Int16 -> Builder +putInt16host = Prim.primFixed Prim.int16Host +{-# INLINE putInt16host #-} + +-- | Write a Int32 in native host order and host endianness. +-- 4 bytes will be written, unaligned. +putInt32host :: Int32 -> Builder +putInt32host = Prim.primFixed Prim.int32Host +{-# INLINE putInt32host #-} + +-- | Write a Int64 in native host order. +-- On a 32 bit machine we write two host order Int32s, in big endian form. +-- 8 bytes will be written, unaligned. +putInt64host :: Int64 -> Builder +putInt64host = Prim.primFixed Prim.int64Host +{-# INLINE putInt64host #-} + + +------------------------------------------------------------------------ +-- Unicode -import Data.Binary.Builder.Base +-- | Write a character using UTF-8 encoding. +putCharUtf8 :: Char -> Builder +putCharUtf8 = Prim.primBounded Prim.charUtf8 +{-# INLINE putCharUtf8 #-} diff --git a/src/Data/Binary/Builder/Base.hs b/src/Data/Binary/Builder/Base.hs deleted file mode 100644 index 3e71cc93..00000000 --- a/src/Data/Binary/Builder/Base.hs +++ /dev/null @@ -1,621 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Binary.Builder.Base --- Copyright : Lennart Kolmodin, Ross Paterson --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : experimental --- Portability : portable to Hugs and GHC --- --- A module exporting types and functions that are shared by --- 'Data.Binary.Builder' and 'Data.Binary.Builder.Internal'. --- ------------------------------------------------------------------------------ - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - -module Data.Binary.Builder.Base ( - -- * The Builder type - Builder - , toLazyByteString - - -- * Constructing Builders - , empty - , singleton - , append - , fromByteString -- :: S.ByteString -> Builder - , fromLazyByteString -- :: L.ByteString -> Builder -#if MIN_VERSION_bytestring(0,10,4) - , fromShortByteString -- :: T.ByteString -> Builder -#endif - -- * Flushing the buffer state - , flush - - -- * Derived Builders - -- ** Big-endian writes - , putWord16be -- :: Word16 -> Builder - , putWord32be -- :: Word32 -> Builder - , putWord64be -- :: Word64 -> Builder - , putInt16be -- :: Int16 -> Builder - , putInt32be -- :: Int32 -> Builder - , putInt64be -- :: Int64 -> Builder - - -- ** Little-endian writes - , putWord16le -- :: Word16 -> Builder - , putWord32le -- :: Word32 -> Builder - , putWord64le -- :: Word64 -> Builder - , putInt16le -- :: Int16 -> Builder - , putInt32le -- :: Int32 -> Builder - , putInt64le -- :: Int64 -> Builder - - -- ** Host-endian, unaligned writes - , putWordhost -- :: Word -> Builder - , putWord16host -- :: Word16 -> Builder - , putWord32host -- :: Word32 -> Builder - , putWord64host -- :: Word64 -> Builder - , putInthost -- :: Int -> Builder - , putInt16host -- :: Int16 -> Builder - , putInt32host -- :: Int32 -> Builder - , putInt64host -- :: Int64 -> Builder - - -- ** Unicode - , putCharUtf8 - - -- * Low-level construction of Builders - , writeN - , writeAtMost - ) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -#if MIN_VERSION_bytestring(0,10,4) -import qualified Data.ByteString.Short as T -import qualified Data.ByteString.Short.Internal as T -#endif -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup -#else -import Data.Monoid -#endif -import Data.Word -import Foreign - -import System.IO.Unsafe as IO ( unsafePerformIO ) - -import Data.Binary.Internal ( accursedUnutterablePerformIO ) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -import GHC.Base (ord,Int(..),uncheckedShiftRL#) -import GHC.Word (Word32(..),Word16(..),Word64(..)) -# if WORD_SIZE_IN_BITS < 64 -import GHC.Word (uncheckedShiftRL64#) -# endif -#endif -import Prelude -- Silence AMP warning. - ------------------------------------------------------------------------- - --- | 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 { - runBuilder :: (Buffer -> IO L.ByteString) - -> Buffer - -> IO L.ByteString - } - -#if MIN_VERSION_base(4,9,0) -instance Semigroup Builder where - (<>) = append - {-# INLINE (<>) #-} -#endif - -instance Monoid Builder where - mempty = empty - {-# INLINE mempty #-} -#if MIN_VERSION_base(4,9,0) - mappend = (<>) -#else - mappend = append -#endif - {-# INLINE mappend #-} - mconcat = foldr mappend mempty - {-# INLINE mconcat #-} - ------------------------------------------------------------------------- - --- | /O(1)./ The empty Builder, satisfying --- --- * @'toLazyByteString' 'empty' = 'L.empty'@ --- -empty :: Builder -empty = Builder (\ k b -> k b) -{-# 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 [0] 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 (L.Chunk 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 (bss `L.append`) -{-# INLINE fromLazyByteString #-} - -#if MIN_VERSION_bytestring(0,10,4) --- | /O(n)./ A builder taking 'T.ShortByteString' and copy it to a Builder, --- satisfying --- --- * @'toLazyByteString' ('fromShortByteString' bs) = 'L.fromChunks' ['T.fromShort' bs] -fromShortByteString :: T.ShortByteString -> Builder -fromShortByteString sbs = writeN (T.length sbs) $ \ptr -> - T.copyToPtr sbs 0 ptr (T.length sbs) -{-# INLINE fromShortByteString #-} -#endif - ------------------------------------------------------------------------- - --- Our internal buffer type -data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) - {-# UNPACK #-} !Int -- offset - {-# UNPACK #-} !Int -- used bytes - {-# UNPACK #-} !Int -- length left - ------------------------------------------------------------------------- - --- | /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 = IO.unsafePerformIO $ do - buf <- newBuffer defaultSize - runBuilder (m `append` flush) (const (return L.Empty)) buf -{-# INLINE toLazyByteString #-} - --- | /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 -- Invariant (from Data.ByteString.Lazy) - then k buf - else let !b = Buffer p (o+u) 0 l - !bs = S.PS p o u - -- It should be safe to use accursedUnutterablePerformIO here. - -- The place in the buffer where we write is determined by the 'b' - -- value, and writes should be deterministic. The thunk should not - -- be floated out and shared since the buffer references the - -- incoming foreign ptr. - in return $! L.Chunk bs (accursedUnutterablePerformIO (k b)) -{-# INLINE [0] flush #-} - ------------------------------------------------------------------------- - --- --- 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 -withBuffer :: (Buffer -> IO Buffer) -> Builder -withBuffer f = Builder $ \ k buf -> f buf >>= k -{-# INLINE withBuffer #-} - --- | 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 :: (L.ByteString -> L.ByteString) -> Builder -mapBuilder f = Builder (fmap 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` withBuffer (const (newBuffer (max n defaultSize))) -{-# INLINE [0] ensureFree #-} - --- | Ensure that @n@ bytes are available, and then use @f@ to write at --- most @n@ bytes into memory. @f@ must return the actual number of --- bytes written. -writeAtMost :: Int -> (Ptr Word8 -> IO Int) -> Builder -writeAtMost n f = ensureFree n `append` withBuffer (writeBuffer f) -{-# INLINE [0] writeAtMost #-} - --- | Ensure that @n@ bytes are available, and then use @f@ to write --- exactly @n@ bytes into memory. -writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder -writeN n f = writeAtMost n (\ p -> f p >> return n) -{-# INLINE writeN #-} - -writeBuffer :: (Ptr Word8 -> IO Int) -> Buffer -> IO Buffer -writeBuffer f (Buffer fp o u l) = do - n <- withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) - return $! Buffer fp o (u+n) (l-n) -{-# INLINE writeBuffer #-} - -newBuffer :: Int -> IO Buffer -newBuffer size = do - fp <- S.mallocByteString size - return $! Buffer fp 0 0 size -{-# INLINE newBuffer #-} - ------------------------------------------------------------------------- - --- --- 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) - - --- | Write a Int16 in big endian format -putInt16be :: Int16 -> Builder -putInt16be = putWord16be . fromIntegral -{-# INLINE putInt16be #-} - --- | Write a Int16 in little endian format -putInt16le :: Int16 -> Builder -putInt16le = putWord16le . fromIntegral -{-# INLINE putInt16le #-} - --- | Write a Int32 in big endian format -putInt32be :: Int32 -> Builder -putInt32be = putWord32be . fromIntegral -{-# INLINE putInt32be #-} - --- | Write a Int32 in little endian format -putInt32le :: Int32 -> Builder -putInt32le = putWord32le . fromIntegral -{-# INLINE putInt32le #-} - --- | Write a Int64 in big endian format -putInt64be :: Int64 -> Builder -putInt64be = putWord64be . fromIntegral - --- | Write a Int64 in little endian format -putInt64le :: Int64 -> Builder -putInt64le = putWord64le . fromIntegral - - - ------------------------------------------------------------------------- --- 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 = - writeN (sizeOf (undefined :: Word)) (\p -> poke (castPtr 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 = - writeN (sizeOf (undefined :: Word16)) (\p -> poke (castPtr 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 = - writeN (sizeOf (undefined :: Word32)) (\p -> poke (castPtr 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 = - writeN (sizeOf (undefined :: Word64)) (\p -> poke (castPtr p) w) -{-# INLINE putWord64host #-} - --- | /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 Int 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. --- -putInthost :: Int -> Builder -putInthost w = - writeN (sizeOf (undefined :: Int)) (\p -> poke (castPtr p) w) -{-# INLINE putInthost #-} - --- | Write a Int16 in native host order and host endianness. --- 2 bytes will be written, unaligned. -putInt16host :: Int16 -> Builder -putInt16host w16 = - writeN (sizeOf (undefined :: Int16)) (\p -> poke (castPtr p) w16) -{-# INLINE putInt16host #-} - --- | Write a Int32 in native host order and host endianness. --- 4 bytes will be written, unaligned. -putInt32host :: Int32 -> Builder -putInt32host w32 = - writeN (sizeOf (undefined :: Int32)) (\p -> poke (castPtr p) w32) -{-# INLINE putInt32host #-} - --- | Write a Int64 in native host order. --- On a 32 bit machine we write two host order Int32s, in big endian form. --- 8 bytes will be written, unaligned. -putInt64host :: Int64 -> Builder -putInt64host w = - writeN (sizeOf (undefined :: Int64)) (\p -> poke (castPtr p) w) -{-# INLINE putInt64host #-} - - ------------------------------------------------------------------------- --- Unicode - --- Code lifted from the text package by Bryan O'Sullivan. - --- | Write a character using UTF-8 encoding. -putCharUtf8 :: Char -> Builder -putCharUtf8 x = writeAtMost 4 $ \ p -> case undefined of - _ | n <= 0x7F -> poke p c >> return 1 - | n <= 0x07FF -> do - poke p a2 - poke (p `plusPtr` 1) b2 - return 2 - | n <= 0xFFFF -> do - poke p a3 - poke (p `plusPtr` 1) b3 - poke (p `plusPtr` 2) c3 - return 3 - | otherwise -> do - poke p a4 - poke (p `plusPtr` 1) b4 - poke (p `plusPtr` 2) c4 - poke (p `plusPtr` 3) d4 - return 4 - where - n = ord x - c = fromIntegral n - (a2,b2) = ord2 x - (a3,b3,c3) = ord3 x - (a4,b4,c4,d4) = ord4 x - -ord2 :: Char -> (Word8,Word8) -ord2 c = (x1,x2) - where - n = ord c - x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 - x2 = fromIntegral $ (n .&. 0x3F) + 0x80 - -ord3 :: Char -> (Word8,Word8,Word8) -ord3 c = (x1,x2,x3) - where - n = ord c - x1 = fromIntegral $ (n `shiftR` 12) + 0xE0 - x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 - x3 = fromIntegral $ (n .&. 0x3F) + 0x80 - -ord4 :: Char -> (Word8,Word8,Word8,Word8) -ord4 c = (x1,x2,x3,x4) - where - n = ord c - x1 = fromIntegral $ (n `shiftR` 18) + 0xF0 - x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 - x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 - x4 = fromIntegral $ (n .&. 0x3F) + 0x80 - ------------------------------------------------------------------------- --- 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) -# else -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) -# endif - -#else -shiftr_w16 = shiftR -shiftr_w32 = shiftR -shiftr_w64 = shiftR -#endif - ------------------------------------------------------------------------- --- Some nice rules for Builder - -#if __GLASGOW_HASKELL__ >= 700 --- In versions of GHC prior to 7.0 these rules would make GHC believe --- that 'writeN' and 'ensureFree' are recursive and the rules wouldn't --- fire. -{-# RULES - -"append/writeAtMost" forall a b (f::Ptr Word8 -> IO Int) - (g::Ptr Word8 -> IO Int) ws. - append (writeAtMost a f) (append (writeAtMost b g) ws) = - append (writeAtMost (a+b) (\p -> f p >>= \n -> - g (p `plusPtr` n) >>= \m -> - let s = n+m in s `seq` return s)) ws - -"writeAtMost/writeAtMost" forall a b (f::Ptr Word8 -> IO Int) - (g::Ptr Word8 -> IO Int). - append (writeAtMost a f) (writeAtMost b g) = - writeAtMost (a+b) (\p -> f p >>= \n -> - g (p `plusPtr` n) >>= \m -> - let s = n+m in s `seq` return s) - -"ensureFree/ensureFree" forall a b . - append (ensureFree a) (ensureFree b) = ensureFree (max a b) - -"flush/flush" - append flush flush = flush #-} -#endif diff --git a/src/Data/Binary/Builder/Internal.hs b/src/Data/Binary/Builder/Internal.hs deleted file mode 100644 index 2a285396..00000000 --- a/src/Data/Binary/Builder/Internal.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Safe #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Binary.Builder.Internal --- Copyright : Lennart Kolmodin, Ross Paterson --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : experimental --- Portability : portable to Hugs and GHC --- --- A module containing semi-public 'Builder' internals that exposes --- low level construction functions. Modules which extend the --- 'Builder' system will need to use this module while ideally most --- users will be able to make do with the public interface modules. --- ------------------------------------------------------------------------------ - -module Data.Binary.Builder.Internal ( - -- * Low-level construction of Builders - writeN - , writeAtMost - ) where - -import Data.Binary.Builder.Base