diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jasper Van der Jeugt 2010, Simon Meier 2010-2013 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jasper Van der Jeugt nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,40 @@ +import Distribution.Simple +import Distribution.Simple.Setup +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription +import Distribution.Version + +-- This checks the direct dependency of the bytestring package being +-- compiled against to set the bytestring_has_itoa_c and +-- bytestring_has_builder flags accordingly. + +main = defaultMainWithHooks simpleUserHooks { + confHook = \pkg flags -> + if null (configConstraints flags) + then do + confHook simpleUserHooks pkg flags + else do + let bytestring_version = + case [ versionBranch v + | (Dependency pkg ver) <- configConstraints flags + , pkg == PackageName "bytestring" + , (Just v) <- [isSpecificVersion ver] ] + of + [v] -> v + vs -> error ("error detecting bytestring version " ++ show vs) + + let has_itoa_c = ( FlagName "bytestring_has_itoa_c" + , bytestring_version >= [0,10] ) + + let has_builder = ( FlagName "bytestring_has_builder" + , bytestring_version >= [0,10,4] ) + + let update fs gs = + fs ++ [ g | g <- gs, not $ any (\f -> fst f == fst g) fs] + + let flags' = flags { configConfigurationsFlags = + update [has_itoa_c, has_builder] + (configConfigurationsFlags flags) } + + confHook simpleUserHooks pkg flags' + } diff --git a/bytestring-builder.cabal b/bytestring-builder.cabal new file mode 100644 --- /dev/null +++ b/bytestring-builder.cabal @@ -0,0 +1,95 @@ +name: bytestring-builder +version: 0.10.4.0 +synopsis: The new bytestring builder, packaged outside of GHC +description: + This is the bytestring builder that is debuting in bytestring-0.10.4.0, which + should be shipping with GHC 7.8, probably late in 2013. This builder has + several nice simplifications and improvements, and more out-of-box + functionality than the older blaze-builder. + . + Note that this package detects which version of bytestring you are compiling + against, and if you are compiling against bytestring-0.10.4 or later, will + be an empty package. + . + This package lets the new interface and implementation be used with most + older compilers without upgrading bytestring, which can be rather + problematic. In conjunction with blaze-builder-0.4 or later, which + offers an implementation of blaze-builder in terms of bytestring-builder, + this should let most people try the new interface and implementation without + causing undue compatibility problems with packages that depend on + blaze-builder. + . + GHC 7.6 did debut an almost identical interface and implementation, but with + slightly different module names and organization. Trying to re-export/rename + the builder provided with 7.6 did not turn out to be very practical, because + this interface includes new functions that rely on Builder internals, + which are not exported in 7.6. Furthermore, these module names should be + deprecated in 7.10. +license: BSD3 +license-file: LICENSE +author: Simon Meier, Jasper Van der Jeugt +maintainer: Leon P Smith +copyright: (c) 2010 Jasper Van der Jeugt + (c) 2010-2013 Simon Meier +category: Data +build-type: Custom +extra-source-files: + cbits/*.c + + src/Data/ByteString/*.hs + src/Data/ByteString/Builder/*.hs + src/Data/ByteString/Builder/Prim/*.hs + src/Data/ByteString/Builder/Prim/Internal/*.hs + src/Data/ByteString/Short/*.hs +cabal-version: >=1.8 + +source-repository head + type: git + location: http://github.com/lpsmith/bytestring-builder + +source-repository this + type: git + location: http://github.com/lpsmith/bytestring-builder + tag: v0.10.4.0 + +-- Note that these flags are set by Setup.hs + +Flag bytestring_has_itoa_c + default: True + manual: True + +Flag bytestring_has_builder + default: True + manual: True + +library + build-depends: base == 4.* , + bytestring >= 0.9 && < 1.0, + deepseq + + if !flag(bytestring_has_itoa_c) + c-sources: cbits/itoa.c + + + if !flag(bytestring_has_builder) + hs-source-dirs: src + c-sources: cbits/fpstring.c + exposed-modules: + Data.ByteString.Builder + Data.ByteString.Builder.Extra + Data.ByteString.Builder.Prim + + -- perhaps only exposed temporarily + Data.ByteString.Builder.Internal + Data.ByteString.Builder.Prim.Internal + + Data.ByteString.Short + Data.ByteString.Short.Internal + + other-modules: + Data.ByteString.Builder.ASCII + Data.ByteString.Builder.Prim.Binary + Data.ByteString.Builder.Prim.ASCII + Data.ByteString.Builder.Prim.Internal.Floating + Data.ByteString.Builder.Prim.Internal.UncheckedShifts + Data.ByteString.Builder.Prim.Internal.Base16 diff --git a/cbits/fpstring.c b/cbits/fpstring.c new file mode 100644 --- /dev/null +++ b/cbits/fpstring.c @@ -0,0 +1,9 @@ +#include + +/* This wrapper is here so that we can copy a sub-range of a ByteArray#. + We cannot construct a pointer to the interior of an unpinned ByteArray#, + except by doing an unsafe ffi call, and adjusting the pointer C-side. */ +void * fps_memcpy_offsets(void *dst, unsigned long dst_off, + const void *src, unsigned long src_off, size_t n) { + return memcpy(dst + dst_off, src + src_off, n); +} diff --git a/cbits/itoa.c b/cbits/itoa.c new file mode 100644 --- /dev/null +++ b/cbits/itoa.c @@ -0,0 +1,215 @@ +/////////////////////////////////////////////////////////////// +// Encoding numbers using ASCII characters // +// // +// inspired by: http://www.jb.man.ac.uk/~slowe/cpp/itoa.html // +/////////////////////////////////////////////////////////////// + +#include + +// Decimal Encoding +/////////////////// + +static const char* digits = "0123456789abcdef"; + +// signed integers +char* _hs_bytestring_int_dec (int x, char* buf) +{ + char c, *ptr = buf, *next_free; + int x_tmp; + + // we cannot negate directly as 0 - (minBound :: Int) = minBound + if (x < 0) { + *ptr++ = '-'; + buf++; + x_tmp = x; + x /= 10; + *ptr++ = digits[x * 10 - x_tmp]; + if (x == 0) + return ptr; + else + x = -x; + } + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// signed long long ints (64 bit integers) +char* _hs_bytestring_long_long_int_dec (long long int x, char* buf) +{ + char c, *ptr = buf, *next_free; + long long int x_tmp; + + // we cannot negate directly as 0 - (minBound :: Int) = minBound + if (x < 0) { + *ptr++ = '-'; + buf++; + x_tmp = x; + x /= 10; + *ptr++ = digits[x * 10 - x_tmp]; + if (x == 0) + return ptr; + else + x = -x; + } + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// unsigned integers +char* _hs_bytestring_uint_dec (unsigned int x, char* buf) +{ + char c, *ptr = buf, *next_free; + unsigned int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// unsigned long ints +char* _hs_bytestring_long_long_uint_dec (long long unsigned int x, char* buf) +{ + char c, *ptr = buf, *next_free; + long long unsigned int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + + +// Padded, decimal, positive integers for the decimal output of bignums +/////////////////////////////////////////////////////////////////////// + +// Padded (9 digits), decimal, positive int: +// We will use it with numbers that fit in 31 bits; i.e., numbers smaller than +// 10^9, as "31 * log 2 / log 10 = 9.33" +void _hs_bytestring_int_dec_padded9 (int x, char* buf) +{ + const int max_width_int32_dec = 9; + char* ptr = buf + max_width_int32_dec; + int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *(--ptr) = digits[x_tmp - x * 10]; + } while ( x ); + + // pad beginning + while (buf < ptr) { *(--ptr) = '0'; } +} + +// Padded (19 digits), decimal, positive long long int: +// We will use it with numbers that fit in 63 bits; i.e., numbers smaller than +// 10^18, as "63 * log 2 / log 10 = 18.96" +void _hs_bytestring_long_long_int_dec_padded18 (long long int x, char* buf) +{ + const int max_width_int64_dec = 18; + char* ptr = buf + max_width_int64_dec; + long long int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *(--ptr) = digits[x_tmp - x * 10]; + } while ( x ); + + // pad beginning + while (buf < ptr) { *(--ptr) = '0'; } +} + + +/////////////////////// +// Hexadecimal encoding +/////////////////////// + +// unsigned ints (32 bit words) +char* _hs_bytestring_uint_hex (unsigned int x, char* buf) { + // write hex representation in reverse order + char c, *ptr = buf, *next_free; + do { + *ptr++ = digits[x & 0xf]; + x >>= 4; + } while ( x ); + // invert written digits + next_free = ptr--; + while(buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +}; + +// unsigned long ints (64 bit words) +char* _hs_bytestring_long_long_uint_hex (long long unsigned int x, char* buf) { + // write hex representation in reverse order + char c, *ptr = buf, *next_free; + do { + *ptr++ = digits[x & 0xf]; + x >>= 4; + } while ( x ); + // invert written digits + next_free = ptr--; + while(buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +}; diff --git a/src/Data/ByteString/Builder.hs b/src/Data/ByteString/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder.hs @@ -0,0 +1,458 @@ +{-# LANGUAGE CPP, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +{- | Copyright : (c) 2010 Jasper Van der Jeugt + (c) 2010 - 2011 Simon Meier +License : BSD3-style (see LICENSE) +Maintainer : Simon Meier +Portability : GHC + +'Builder's are used to efficiently construct sequences of bytes from + smaller parts. +Typically, + such a construction is part of the implementation of an /encoding/, i.e., + a function for converting Haskell values to sequences of bytes. +Examples of encodings are the generation of the sequence of bytes + representing a HTML document to be sent in a HTTP response by a + web application or the serialization of a Haskell value using + a fixed binary format. + +For an /efficient implementation of an encoding/, + it is important that (a) little time is spent on converting + the Haskell values to the resulting sequence of bytes /and/ + (b) that the representation of the resulting sequence + is such that it can be consumed efficiently. +'Builder's support (a) by providing an /O(1)/ concatentation operation + and efficient implementations of basic encodings for 'Char's, 'Int's, + and other standard Haskell values. +They support (b) by providing their result as a lazy 'L.ByteString', + which is internally just a linked list of pointers to /chunks/ + of consecutive raw memory. +Lazy 'L.ByteString's can be efficiently consumed by functions that + write them to a file or send them over a network socket. +Note that each chunk boundary incurs expensive extra work (e.g., a system call) + that must be amortized over the work spent on consuming the chunk body. +'Builder's therefore take special care to ensure that the + average chunk size is large enough. +The precise meaning of large enough is application dependent. +The current implementation is tuned + for an average chunk size between 4kb and 32kb, + which should suit most applications. + +As a simple example of an encoding implementation, + we show how to efficiently convert the following representation of mixed-data + tables to an UTF-8 encoded Comma-Separated-Values (CSV) table. + +>data Cell = StringC String +> | IntC Int +> deriving( Eq, Ord, Show ) +> +>type Row = [Cell] +>type Table = [Row] + +We use the following imports and abbreviate 'mappend' to simplify reading. + +@ +import qualified "Data.ByteString.Lazy" as L +import "Data.ByteString.Builder" +import Data.Monoid +import Data.Foldable ('foldMap') +import Data.List ('intersperse') + +infixr 4 \<\> +(\<\>) :: 'Monoid' m => m -> m -> m +(\<\>) = 'mappend' +@ + +CSV is a character-based representation of tables. For maximal modularity, +we could first render 'Table's as 'String's and then encode this 'String' +using some Unicode character encoding. However, this sacrifices performance +due to the intermediate 'String' representation being built and thrown away +right afterwards. We get rid of this intermediate 'String' representation by +fixing the character encoding to UTF-8 and using 'Builder's to convert +'Table's directly to UTF-8 encoded CSV tables represented as lazy +'L.ByteString's. + +@ +encodeUtf8CSV :: Table -> L.ByteString +encodeUtf8CSV = 'toLazyByteString' . renderTable + +renderTable :: Table -> Builder +renderTable rs = 'mconcat' [renderRow r \<\> 'charUtf8' \'\\n\' | r <- rs] + +renderRow :: Row -> Builder +renderRow [] = 'mempty' +renderRow (c:cs) = + renderCell c \<\> mconcat [ charUtf8 \',\' \<\> renderCell c\' | c\' <- cs ] + +renderCell :: Cell -> Builder +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = 'intDec' i + +renderString :: String -> Builder +renderString cs = charUtf8 \'\"\' \<\> foldMap escape cs \<\> charUtf8 \'\"\' + where + escape \'\\\\\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\\\' + escape \'\\\"\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\"\' + escape c = charUtf8 c +@ + +Note that the ASCII encoding is a subset of the UTF-8 encoding, + which is why we can use the optimized function 'intDec' to + encode an 'Int' as a decimal number with UTF-8 encoded digits. +Using 'intDec' is more efficient than @'stringUtf8' . 'show'@, + as it avoids constructing an intermediate 'String'. +Avoiding this intermediate data structure significantly improves + performance because encoding 'Cell's is the core operation + for rendering CSV-tables. +See "Data.ByteString.Builder.Prim" for further + information on how to improve the performance of 'renderString'. + +We demonstrate our UTF-8 CSV encoding function on the following table. + +@ +strings :: [String] +strings = [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] + +table :: Table +table = [map StringC strings, map IntC [-3..3]] +@ + +The expression @encodeUtf8CSV table@ results in the following lazy +'L.ByteString'. + +>Chunk "\"hello\",\"\\\"1\\\"\",\"\206\187-w\195\182rld\"\n-3,-2,-1,0,1,2,3\n" Empty + +We can clearly see that we are converting to a /binary/ format. The \'λ\' +and \'ö\' characters, which have a Unicode codepoint above 127, are +expanded to their corresponding UTF-8 multi-byte representation. + +We use the @criterion@ library () + to benchmark the efficiency of our encoding function on the following table. + +>import Criterion.Main -- add this import to the ones above +> +>maxiTable :: Table +>maxiTable = take 1000 $ cycle table +> +>main :: IO () +>main = defaultMain +> [ bench "encodeUtf8CSV maxiTable (original)" $ +> whnf (L.length . encodeUtf8CSV) maxiTable +> ] + +On a Core2 Duo 2.20GHz on a 32-bit Linux, + the above code takes 1ms to generate the 22'500 bytes long lazy 'L.ByteString'. +Looking again at the definitions above, + we see that we took care to avoid intermediate data structures, + as otherwise we would sacrifice performance. +For example, + the following (arguably simpler) definition of 'renderRow' is about 20% slower. + +>renderRow :: Row -> Builder +>renderRow = mconcat . intersperse (charUtf8 ',') . map renderCell + +Similarly, using /O(n)/ concatentations like '++' or the equivalent 'S.concat' + operations on strict and lazy 'L.ByteString's should be avoided. +The following definition of 'renderString' is also about 20% slower. + +>renderString :: String -> Builder +>renderString cs = charUtf8 $ "\"" ++ concatMap escape cs ++ "\"" +> where +> escape '\\' = "\\" +> escape '\"' = "\\\"" +> escape c = return c + +Apart from removing intermediate data-structures, + encodings can be optimized further by fine-tuning their execution + parameters using the functions in "Data.ByteString.Builder.Extra" and + their \"inner loops\" using the functions in + "Data.ByteString.Builder.Prim". +-} + + +module Data.ByteString.Builder + ( + -- * The Builder type + Builder + + -- * Executing Builders + -- | Internally, 'Builder's are buffer-filling functions. They are + -- executed by a /driver/ that provides them with an actual buffer to + -- fill. Once called with a buffer, a 'Builder' fills it and returns a + -- signal to the driver telling it that it is either done, has filled the + -- current buffer, or wants to directly insert a reference to a chunk of + -- memory. In the last two cases, the 'Builder' also returns a + -- continutation 'Builder' that the driver can call to fill the next + -- buffer. Here, we provide the two drivers that satisfy almost all use + -- cases. See "Data.ByteString.Builder.Extra", for information + -- about fine-tuning them. + , toLazyByteString + , hPutBuilder + + -- * Creating Builders + + -- ** Binary encodings + , byteString + , lazyByteString + , shortByteString + , int8 + , word8 + + -- *** Big-endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- *** Little-endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- ** Character encodings + + -- *** ASCII (Char7) + -- | The ASCII encoding is a 7-bit encoding. The /Char7/ encoding implemented here + -- works by truncating the Unicode codepoint to 7-bits, prefixing it + -- with a leading 0, and encoding the resulting 8-bits as a single byte. + -- For the codepoints 0-127 this corresponds the ASCII encoding. In + -- "Data.ByteString.Builder.ASCII", we also provide efficient + -- implementations of ASCII-based encodings of numbers (e.g., decimal and + -- hexadecimal encodings). + , char7 + , string7 + + -- *** ISO/IEC 8859-1 (Char8) + -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. + -- The /Char8/ encoding implemented here works by truncating the Unicode codepoint + -- to 8-bits and encoding them as a single byte. For the codepoints 0-255 this corresponds + -- to the ISO/IEC 8859-1 encoding. Note that you can also use + -- the functions from "Data.ByteString.Builder.ASCII", as the ASCII encoding + -- and ISO/IEC 8859-1 are equivalent on the codepoints 0-127. + , char8 + , string8 + + -- *** UTF-8 + -- | The UTF-8 encoding can encode /all/ Unicode codepoints. We recommend + -- using it always for encoding 'Char's and 'String's unless an application + -- really requires another encoding. Note that you can also use the + -- functions from "Data.ByteString.Builder.ASCII" for UTF-8 encoding, + -- as the ASCII encoding is equivalent to the UTF-8 encoding on the Unicode + -- codepoints 0-127. + , charUtf8 + , stringUtf8 + + , module Data.ByteString.Builder.ASCII + + ) where + +import Data.ByteString.Builder.Internal +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Lazy.Internal as L +import Data.ByteString.Builder.ASCII + +import Data.String (IsString(..)) +import System.IO (Handle) +import Foreign + +-- HADDOCK only imports +import qualified Data.ByteString as S (concat) +import Data.Monoid +import Data.Foldable (foldMap) +import Data.List (intersperse) + + +-- | Execute a 'Builder' and return the generated chunks as a lazy 'L.ByteString'. +-- The work is performed lazy, i.e., only when a chunk of the lazy 'L.ByteString' +-- is forced. +{-# NOINLINE toLazyByteString #-} -- ensure code is shared +toLazyByteString :: Builder -> L.ByteString +toLazyByteString = toLazyByteStringWith + (safeStrategy L.smallChunkSize L.defaultChunkSize) L.Empty + +{- Not yet stable enough. + See note on 'hPut' in Data.ByteString.Builder.Internal +-} + +-- | Output a 'Builder' to a 'Handle'. +-- The 'Builder' is executed directly on the buffer of the 'Handle'. If the +-- buffer is too small (or not present), then it is replaced with a large +-- enough buffer. +-- +-- It is recommended that the 'Handle' is set to binary and +-- 'BlockBuffering' mode. See 'hSetBinaryMode' and 'hSetBuffering'. +-- +-- This function is more efficient than @hPut . 'toLazyByteString'@ because in +-- many cases no buffer allocation has to be done. Moreover, the results of +-- several executions of short 'Builder's are concatenated in the 'Handle's +-- buffer, therefore avoiding unnecessary buffer flushes. +hPutBuilder :: Handle -> Builder -> IO () +hPutBuilder h = hPut h . putBuilder + + +------------------------------------------------------------------------------ +-- Binary encodings +------------------------------------------------------------------------------ + +-- | Encode a single signed byte as-is. +-- +{-# INLINE int8 #-} +int8 :: Int8 -> Builder +int8 = P.primFixed P.int8 + +-- | Encode a single unsigned byte as-is. +-- +{-# INLINE word8 #-} +word8 :: Word8 -> Builder +word8 = P.primFixed P.word8 + + +------------------------------------------------------------------------------ +-- Binary little-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in little endian format. +{-# INLINE int16LE #-} +int16LE :: Int16 -> Builder +int16LE = P.primFixed P.int16LE + +-- | Encode an 'Int32' in little endian format. +{-# INLINE int32LE #-} +int32LE :: Int32 -> Builder +int32LE = P.primFixed P.int32LE + +-- | Encode an 'Int64' in little endian format. +{-# INLINE int64LE #-} +int64LE :: Int64 -> Builder +int64LE = P.primFixed P.int64LE + +-- | Encode a 'Word16' in little endian format. +{-# INLINE word16LE #-} +word16LE :: Word16 -> Builder +word16LE = P.primFixed P.word16LE + +-- | Encode a 'Word32' in little endian format. +{-# INLINE word32LE #-} +word32LE :: Word32 -> Builder +word32LE = P.primFixed P.word32LE + +-- | Encode a 'Word64' in little endian format. +{-# INLINE word64LE #-} +word64LE :: Word64 -> Builder +word64LE = P.primFixed P.word64LE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: Float -> Builder +floatLE = P.primFixed P.floatLE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: Double -> Builder +doubleLE = P.primFixed P.doubleLE + + +------------------------------------------------------------------------------ +-- Binary big-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in big endian format. +{-# INLINE int16BE #-} +int16BE :: Int16 -> Builder +int16BE = P.primFixed P.int16BE + +-- | Encode an 'Int32' in big endian format. +{-# INLINE int32BE #-} +int32BE :: Int32 -> Builder +int32BE = P.primFixed P.int32BE + +-- | Encode an 'Int64' in big endian format. +{-# INLINE int64BE #-} +int64BE :: Int64 -> Builder +int64BE = P.primFixed P.int64BE + +-- | Encode a 'Word16' in big endian format. +{-# INLINE word16BE #-} +word16BE :: Word16 -> Builder +word16BE = P.primFixed P.word16BE + +-- | Encode a 'Word32' in big endian format. +{-# INLINE word32BE #-} +word32BE :: Word32 -> Builder +word32BE = P.primFixed P.word32BE + +-- | Encode a 'Word64' in big endian format. +{-# INLINE word64BE #-} +word64BE :: Word64 -> Builder +word64BE = P.primFixed P.word64BE + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: Float -> Builder +floatBE = P.primFixed P.floatBE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: Double -> Builder +doubleBE = P.primFixed P.doubleBE + +------------------------------------------------------------------------------ +-- ASCII encoding +------------------------------------------------------------------------------ + +-- | Char7 encode a 'Char'. +{-# INLINE char7 #-} +char7 :: Char -> Builder +char7 = P.primFixed P.char7 + +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = P.primMapListFixed P.char7 + +------------------------------------------------------------------------------ +-- ISO/IEC 8859-1 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: Char -> Builder +char8 = P.primFixed P.char8 + +-- | Char8 encode a 'String'. +{-# INLINE string8 #-} +string8 :: String -> Builder +string8 = P.primMapListFixed P.char8 + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: Char -> Builder +charUtf8 = P.primBounded P.charUtf8 + +-- | UTF-8 encode a 'String'. +{-# INLINE stringUtf8 #-} +stringUtf8 :: String -> Builder +stringUtf8 = P.primMapListBounded P.charUtf8 + +instance IsString Builder where + fromString = stringUtf8 diff --git a/src/Data/ByteString/Builder/ASCII.hs b/src/Data/ByteString/Builder/ASCII.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/ASCII.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface, + MagicHash, UnboxedTuples #-} +{-# OPTIONS_HADDOCK hide #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +-- | Copyright : (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Constructing 'Builder's using ASCII-based encodings. +-- +module Data.ByteString.Builder.ASCII + ( + -- ** ASCII text + -- *** Decimal numbers + -- | Decimal encoding of numbers using ASCII encoded characters. + int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + , integerDec + + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + + , floatDec + , doubleDec + + -- *** Hexadecimal numbers + + -- | Encoding positive integers as hexadecimal numbers using lower-case + -- ASCII characters. The shortest + -- possible representation is used. For example, + -- + -- >>> toLazyByteString (word16Hex 0x0a10) + -- Chunk "a10" Empty + -- + -- Note that there is no support for using upper-case characters. Please + -- contact the maintainer, if your application cannot work without + -- hexadecimal encodings that use upper-case characters. + -- + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + + -- *** Fixed-width hexadecimal numbers + -- + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + + , floatHexFixed + , doubleHexFixed + + , byteStringHex + , lazyByteStringHex + + ) where + +import Data.ByteString as S +import Data.ByteString.Lazy as L +import Data.ByteString.Builder.Internal (Builder) +import qualified Data.ByteString.Builder.Prim as P + +import Foreign + + +#if defined(__GLASGOW_HASKELL__) && defined(INTEGER_GMP) +import Data.Monoid (mappend) +import Foreign.C.Types + +import qualified Data.ByteString.Builder.Prim.Internal as P +import Data.ByteString.Builder.Prim.Internal.UncheckedShifts + ( caseWordSize_32_64 ) + +import GHC.Num (quotRemInteger) +import GHC.Types (Int(..)) + + +# if __GLASGOW_HASKELL__ < 611 +import GHC.Integer.Internals +# else +import GHC.Integer.GMP.Internals +# endif +#endif + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + + +-- | Encode a 'String' using 'P.char7'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = P.primMapListFixed P.char7 + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +-- | Decimal encoding of an 'Int8' using the ASCII digits. +-- +-- e.g. +-- +-- > toLazyByteString (int8Dec 42) = "42" +-- > toLazyByteString (int8Dec (-1)) = "-1" +-- +{-# INLINE int8Dec #-} +int8Dec :: Int8 -> Builder +int8Dec = P.primBounded P.int8Dec + +-- | Decimal encoding of an 'Int16' using the ASCII digits. +{-# INLINE int16Dec #-} +int16Dec :: Int16 -> Builder +int16Dec = P.primBounded P.int16Dec + +-- | Decimal encoding of an 'Int32' using the ASCII digits. +{-# INLINE int32Dec #-} +int32Dec :: Int32 -> Builder +int32Dec = P.primBounded P.int32Dec + +-- | Decimal encoding of an 'Int64' using the ASCII digits. +{-# INLINE int64Dec #-} +int64Dec :: Int64 -> Builder +int64Dec = P.primBounded P.int64Dec + +-- | Decimal encoding of an 'Int' using the ASCII digits. +{-# INLINE intDec #-} +intDec :: Int -> Builder +intDec = P.primBounded P.intDec + + +-- Unsigned integers +-------------------- + +-- | Decimal encoding of a 'Word8' using the ASCII digits. +{-# INLINE word8Dec #-} +word8Dec :: Word8 -> Builder +word8Dec = P.primBounded P.word8Dec + +-- | Decimal encoding of a 'Word16' using the ASCII digits. +{-# INLINE word16Dec #-} +word16Dec :: Word16 -> Builder +word16Dec = P.primBounded P.word16Dec + +-- | Decimal encoding of a 'Word32' using the ASCII digits. +{-# INLINE word32Dec #-} +word32Dec :: Word32 -> Builder +word32Dec = P.primBounded P.word32Dec + +-- | Decimal encoding of a 'Word64' using the ASCII digits. +{-# INLINE word64Dec #-} +word64Dec :: Word64 -> Builder +word64Dec = P.primBounded P.word64Dec + +-- | Decimal encoding of a 'Word' using the ASCII digits. +{-# INLINE wordDec #-} +wordDec :: Word -> Builder +wordDec = P.primBounded P.wordDec + + +-- Floating point numbers +------------------------- + +-- TODO: Use Bryan O'Sullivan's double-conversion package to speed it up. + +-- | /Currently slow./ Decimal encoding of an IEEE 'Float'. +{-# INLINE floatDec #-} +floatDec :: Float -> Builder +floatDec = string7 . show + +-- | /Currently slow./ Decimal encoding of an IEEE 'Double'. +{-# INLINE doubleDec #-} +doubleDec :: Double -> Builder +doubleDec = string7 . show + + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +-- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters. +{-# INLINE word8Hex #-} +word8Hex :: Word8 -> Builder +word8Hex = P.primBounded P.word8Hex + +-- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters. +{-# INLINE word16Hex #-} +word16Hex :: Word16 -> Builder +word16Hex = P.primBounded P.word16Hex + +-- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters. +{-# INLINE word32Hex #-} +word32Hex :: Word32 -> Builder +word32Hex = P.primBounded P.word32Hex + +-- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters. +{-# INLINE word64Hex #-} +word64Hex :: Word64 -> Builder +word64Hex = P.primBounded P.word64Hex + +-- | Shortest hexadecimal encoding of a 'Word' using lower-case characters. +{-# INLINE wordHex #-} +wordHex :: Word -> Builder +wordHex = P.primBounded P.wordHex + + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: Int8 -> Builder +int8HexFixed = P.primFixed P.int8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: Int16 -> Builder +int16HexFixed = P.primFixed P.int16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: Int32 -> Builder +int32HexFixed = P.primFixed P.int32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: Int64 -> Builder +int64HexFixed = P.primFixed P.int64HexFixed + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: Word8 -> Builder +word8HexFixed = P.primFixed P.word8HexFixed + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: Word16 -> Builder +word16HexFixed = P.primFixed P.word16HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: Word32 -> Builder +word32HexFixed = P.primFixed P.word32HexFixed + +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: Word64 -> Builder +word64HexFixed = P.primFixed P.word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: Float -> Builder +floatHexFixed = P.primFixed P.floatHexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: Double -> Builder +doubleHexFixed = P.primFixed P.doubleHexFixed + +-- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding. +{-# NOINLINE byteStringHex #-} -- share code +byteStringHex :: S.ByteString -> Builder +byteStringHex = P.primMapByteStringFixed P.word8HexFixed + +-- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding. +{-# NOINLINE lazyByteStringHex #-} -- share code +lazyByteStringHex :: L.ByteString -> Builder +lazyByteStringHex = P.primMapLazyByteStringFixed P.word8HexFixed + + +------------------------------------------------------------------------------ +-- Fast decimal 'Integer' encoding. +------------------------------------------------------------------------------ + +#if defined(__GLASGOW_HASKELL__) && defined(INTEGER_GMP) +-- An optimized version of the integer serialization code +-- in blaze-textual (c) 2011 MailRank, Inc. Bryan O'Sullivan +-- . It is 2.5x faster on Int-sized integers and 4.5x faster +-- on larger integers. + +# define PAIR(a,b) (# a,b #) + +-- | Maximal power of 10 fitting into an 'Int' without using the MSB. +-- 10 ^ 9 for 32 bit ints (31 * log 2 / log 10 = 9.33) +-- 10 ^ 18 for 64 bit ints (63 * log 2 / log 10 = 18.96) +-- +-- FIXME: Think about also using the MSB. For 64 bit 'Int's this makes a +-- difference. +maxPow10 :: Integer +maxPow10 = toInteger $ (10 :: Int) ^ caseWordSize_32_64 (9 :: Int) 18 + +-- | Decimal encoding of an 'Integer' using the ASCII digits. +integerDec :: Integer -> Builder +integerDec (S# i#) = intDec (I# i#) +integerDec i + | i < 0 = P.primFixed P.char8 '-' `mappend` go (-i) + | otherwise = go ( i) + where + errImpossible fun = + error $ "integerDec: " ++ fun ++ ": the impossible happened." + + go :: Integer -> Builder + go n | n < maxPow10 = intDec (fromInteger n) + | otherwise = + case putH (splitf (maxPow10 * maxPow10) n) of + (x:xs) -> intDec x `mappend` P.primMapListBounded intDecPadded xs + [] -> errImpossible "integerDec: go" + + splitf :: Integer -> Integer -> [Integer] + splitf pow10 n0 + | pow10 > n0 = [n0] + | otherwise = splith (splitf (pow10 * pow10) n0) + where + splith [] = errImpossible "splith" + splith (n:ns) = + case n `quotRemInteger` pow10 of + PAIR(q,r) | q > 0 -> q : r : splitb ns + | otherwise -> r : splitb ns + + splitb [] = [] + splitb (n:ns) = case n `quotRemInteger` pow10 of + PAIR(q,r) -> q : r : splitb ns + + putH :: [Integer] -> [Int] + putH [] = errImpossible "putH" + putH (n:ns) = case n `quotRemInteger` maxPow10 of + PAIR(x,y) + | q > 0 -> q : r : putB ns + | otherwise -> r : putB ns + where q = fromInteger x + r = fromInteger y + + putB :: [Integer] -> [Int] + putB [] = [] + putB (n:ns) = case n `quotRemInteger` maxPow10 of + PAIR(q,r) -> fromInteger q : fromInteger r : putB ns + + +foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9" + c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO () + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18" + c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO () + +{-# INLINE intDecPadded #-} +intDecPadded :: P.BoundedPrim Int +intDecPadded = P.liftFixedToBounded $ caseWordSize_32_64 + (P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral) + (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral) + +#else +-- compilers other than GHC + +-- | Decimal encoding of an 'Integer' using the ASCII digits. Implemented +-- using via the 'Show' instance of 'Integer's. +integerDec :: Integer -> Builder +integerDec = string7 . show +#endif diff --git a/src/Data/ByteString/Builder/Extra.hs b/src/Data/ByteString/Builder/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Extra.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | Copyright : (c) 2010 Jasper Van der Jeugt +-- (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Extra functions for creating and executing 'Builder's. They are intended +-- for application-specific fine-tuning the performance of 'Builder's. +-- +----------------------------------------------------------------------------- +module Data.ByteString.Builder.Extra + ( + -- * Execution strategies + toLazyByteStringWith + , AllocationStrategy + , safeStrategy + , untrimmedStrategy + , smallChunkSize + , defaultChunkSize + + -- * Controlling chunk boundaries + , byteStringCopy + , byteStringInsert + , byteStringThreshold + + , lazyByteStringCopy + , lazyByteStringInsert + , lazyByteStringThreshold + + , flush + + -- * Low level execution + , BufferWriter + , Next(..) + , runBuilder + + -- * Host-specific binary encodings + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + ) where + + +import Data.ByteString.Builder.Internal + ( Builder, toLazyByteStringWith + , AllocationStrategy, safeStrategy, untrimmedStrategy + , smallChunkSize, defaultChunkSize, flush + , byteStringCopy, byteStringInsert, byteStringThreshold + , lazyByteStringCopy, lazyByteStringInsert, lazyByteStringThreshold ) + +import qualified Data.ByteString.Builder.Internal as I +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Internal as S + +import Foreign + +------------------------------------------------------------------------------ +-- Builder execution public API +------------------------------------------------------------------------------ + +-- | A 'BufferWriter' represents the result of running a 'Builder'. +-- It unfolds as a sequence of chunks of data. These chunks come in two forms: +-- +-- * an IO action for writing the Builder's data into a user-supplied memory +-- buffer. +-- +-- * a pre-existing chunks of data represented by a strict 'ByteString' +-- +-- While this is rather low level, it provides you with full flexibility in +-- how the data is written out. +-- +-- The 'BufferWriter' itself is an IO action: you supply it with a buffer +-- (as a pointer and length) and it will write data into the buffer. +-- It returns a number indicating how many bytes were actually written +-- (which can be @0@). It also returns a 'Next' which describes what +-- comes next. +-- +type BufferWriter = Ptr Word8 -> Int -> IO (Int, Next) + +-- | After running a 'BufferWriter' action there are three possibilities for +-- what comes next: +-- +data Next = + -- | This means we're all done. All the builder data has now been written. + Done + + -- | This indicates that there may be more data to write. It + -- gives you the next 'BufferWriter' action. You should call that action + -- with an appropriate buffer. The int indicates the /minimum/ buffer size + -- required by the next 'BufferWriter' action. That is, if you call the next + -- action you /must/ supply it with a buffer length of at least this size. + | More !Int BufferWriter + + -- | In addition to the data that has just been written into your buffer + -- by the 'BufferWriter' action, it gives you a pre-existing chunk + -- of data as a 'S.ByteString'. It also gives you the following 'BufferWriter' + -- action. It is safe to run this following action using a buffer with as + -- much free space as was left by the previous run action. + | Chunk !S.ByteString BufferWriter + +-- | Turn a 'Builder' into its initial 'BufferWriter' action. +-- +runBuilder :: Builder -> BufferWriter +runBuilder = run . I.runBuilder + where + bytesWritten startPtr endPtr = endPtr `minusPtr` startPtr + + run :: I.BuildStep () -> BufferWriter + run step = \buf len -> + let doneH endPtr () = + let !wc = bytesWritten buf endPtr + next = Done + in return (wc, next) + + bufferFullH endPtr minReq step' = + let !wc = bytesWritten buf endPtr + next = More minReq (run step') + in return (wc, next) + + insertChunkH endPtr bs step' = + let !wc = bytesWritten buf endPtr + next = Chunk bs (run step') + in return (wc, next) + + br = I.BufferRange buf (buf `plusPtr` len) + + in I.fillWithBuildStep step doneH bufferFullH insertChunkH br + + + +------------------------------------------------------------------------------ +-- Host-specific encodings +------------------------------------------------------------------------------ + +-- | Encode a single native machine 'Int'. The 'Int' is encoded 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 encoded this way +-- are not portable to different endian or int sized machines, without +-- conversion. +-- +{-# INLINE intHost #-} +intHost :: Int -> Builder +intHost = P.primFixed P.intHost + +-- | Encode a 'Int16' in native host order and host endianness. +{-# INLINE int16Host #-} +int16Host :: Int16 -> Builder +int16Host = P.primFixed P.int16Host + +-- | Encode a 'Int32' in native host order and host endianness. +{-# INLINE int32Host #-} +int32Host :: Int32 -> Builder +int32Host = P.primFixed P.int32Host + +-- | Encode a 'Int64' in native host order and host endianness. +{-# INLINE int64Host #-} +int64Host :: Int64 -> Builder +int64Host = P.primFixed P.int64Host + +-- | Encode a single native machine 'Word'. The 'Word' is encoded 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 encoded this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +{-# INLINE wordHost #-} +wordHost :: Word -> Builder +wordHost = P.primFixed P.wordHost + +-- | Encode a 'Word16' in native host order and host endianness. +{-# INLINE word16Host #-} +word16Host :: Word16 -> Builder +word16Host = P.primFixed P.word16Host + +-- | Encode a 'Word32' in native host order and host endianness. +{-# INLINE word32Host #-} +word32Host :: Word32 -> Builder +word32Host = P.primFixed P.word32Host + +-- | Encode a 'Word64' in native host order and host endianness. +{-# INLINE word64Host #-} +word64Host :: Word64 -> Builder +word64Host = P.primFixed P.word64Host + +-- | Encode a 'Float' in native host order. Values encoded this way are not +-- portable to different endian machines, without conversion. +{-# INLINE floatHost #-} +floatHost :: Float -> Builder +floatHost = P.primFixed P.floatHost + +-- | Encode a 'Double' in native host order. +{-# INLINE doubleHost #-} +doubleHost :: Double -> Builder +doubleHost = P.primFixed P.doubleHost + diff --git a/src/Data/ByteString/Builder/Internal.hs b/src/Data/ByteString/Builder/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Internal.hs @@ -0,0 +1,1133 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, RankNTypes #-} +#if __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Unsafe #-} +#endif +{-# OPTIONS_HADDOCK hide #-} +-- | Copyright : (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : unstable, private +-- Portability : GHC +-- +-- *Warning:* this module is internal. If you find that you need it then please +-- contact the maintainers and explain what you are trying to do and discuss +-- what you would need in the public API. It is important that you do this as +-- the module may not be exposed at all in future releases. +-- +-- Core types and functions for the 'Builder' monoid and its generalization, +-- the 'Put' monad. +-- +-- The design of the 'Builder' monoid is optimized such that +-- +-- 1. buffers of arbitrary size can be filled as efficiently as possible and +-- +-- 2. sequencing of 'Builder's is as cheap as possible. +-- +-- We achieve (1) by completely handing over control over writing to the buffer +-- to the 'BuildStep' implementing the 'Builder'. This 'BuildStep' is just told +-- the start and the end of the buffer (represented as a 'BufferRange'). Then, +-- the 'BuildStep' can write to as big a prefix of this 'BufferRange' in any +-- way it desires. If the 'BuildStep' is done, the 'BufferRange' is full, or a +-- long sequence of bytes should be inserted directly, then the 'BuildStep' +-- signals this to its caller using a 'BuildSignal'. +-- +-- We achieve (2) by requiring that every 'Builder' is implemented by a +-- 'BuildStep' that takes a continuation 'BuildStep', which it calls with the +-- updated 'BufferRange' after it is done. Therefore, only two pointers have +-- to be passed in a function call to implement concatenation of 'Builder's. +-- Moreover, many 'Builder's are completely inlined, which enables the compiler +-- to sequence them without a function call and with no boxing at all. +-- +-- This design gives the implementation of a 'Builder' full access to the 'IO' +-- monad. Therefore, utmost care has to be taken to not overwrite anything +-- outside the given 'BufferRange's. Moreover, further care has to be taken to +-- ensure that 'Builder's and 'Put's are referentially transparent. See the +-- comments of the 'builder' and 'put' functions for further information. +-- Note that there are /no safety belts/ at all, when implementing a 'Builder' +-- using an 'IO' action: you are writing code that might enable the next +-- buffer-overflow attack on a Haskell server! +-- +module Data.ByteString.Builder.Internal ( + -- * Buffer management + Buffer(..) + , BufferRange(..) + , newBuffer + , bufferSize + , byteStringFromBuffer + + , ChunkIOStream(..) + , buildStepToCIOS + , ciosUnitToLazyByteString + , ciosToLazyByteString + + -- * Build signals and steps + , BuildSignal + , BuildStep + , finalBuildStep + + , done + , bufferFull + , insertChunk + + , fillWithBuildStep + + -- * The Builder monoid + , Builder + , builder + , runBuilder + , runBuilderWith + + -- ** Primitive combinators + , empty + , append + , flush + , ensureFree + -- , sizedChunksInsert + + , byteStringCopy + , byteStringInsert + , byteStringThreshold + + , lazyByteStringCopy + , lazyByteStringInsert + , lazyByteStringThreshold + + , shortByteString + + , maximalCopySize + , byteString + , lazyByteString + + -- ** Execution + , toLazyByteStringWith + , AllocationStrategy + , safeStrategy + , untrimmedStrategy + , customStrategy + , L.smallChunkSize + , L.defaultChunkSize + , L.chunkOverhead + + -- * The Put monad + , Put + , put + , runPut + + -- ** Execution + , putToLazyByteString + , putToLazyByteStringWith + , hPut + + -- ** Conversion to and from Builders + , putBuilder + , fromPut + + -- -- ** Lifting IO actions + -- , putLiftIO + +) where + +import Control.Arrow (second) +import Control.Applicative (Applicative(..), (<$>)) +-- import Control.Exception (return) + +import Data.Monoid +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +import qualified Data.ByteString.Short.Internal as Sh + +#if __GLASGOW_HASKELL__ >= 611 +import qualified GHC.IO.Buffer as IO (Buffer(..), newByteBuffer) +import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer) +import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode) +import System.IO (hFlush, BufferMode(..)) +import Data.IORef +#else +import qualified Data.ByteString.Lazy as L +#endif +import System.IO (Handle) + +#if MIN_VERSION_base(4,4,0) +#if MIN_VERSION_base(4,7,0) +import Foreign +#else +import Foreign hiding (unsafeForeignPtrToPtr) +#endif +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafeDupablePerformIO) +#else +import Foreign +import GHC.IO (unsafeDupablePerformIO) +#endif + +------------------------------------------------------------------------------ +-- Buffers +------------------------------------------------------------------------------ +-- | A range of bytes in a buffer represented by the pointer to the first byte +-- of the range and the pointer to the first byte /after/ the range. +data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8) -- First byte of range + {-# UNPACK #-} !(Ptr Word8) -- First byte /after/ range + +-- | A 'Buffer' together with the 'BufferRange' of free bytes. The filled +-- space starts at offset 0 and ends at the first free byte. +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !BufferRange + + +-- | Combined size of the filled and free space in the buffer. +{-# INLINE bufferSize #-} +bufferSize :: Buffer -> Int +bufferSize (Buffer fpbuf (BufferRange _ ope)) = + ope `minusPtr` unsafeForeignPtrToPtr fpbuf + +-- | Allocate a new buffer of the given size. +{-# INLINE newBuffer #-} +newBuffer :: Int -> IO Buffer +newBuffer size = do + fpbuf <- S.mallocByteString size + let pbuf = unsafeForeignPtrToPtr fpbuf + return $! Buffer fpbuf (BufferRange pbuf (pbuf `plusPtr` size)) + +-- | Convert the filled part of a 'Buffer' to a strict 'S.ByteString'. +{-# INLINE byteStringFromBuffer #-} +byteStringFromBuffer :: Buffer -> S.ByteString +byteStringFromBuffer (Buffer fpbuf (BufferRange op _)) = + S.PS fpbuf 0 (op `minusPtr` unsafeForeignPtrToPtr fpbuf) + +--- | Prepend the filled part of a 'Buffer' to a lazy 'L.ByteString' +--- trimming it if necessary. +{-# INLINE trimmedChunkFromBuffer #-} +trimmedChunkFromBuffer :: AllocationStrategy -> Buffer + -> L.ByteString -> L.ByteString +trimmedChunkFromBuffer (AllocationStrategy _ _ trim) buf k + | S.null bs = k + | trim (S.length bs) (bufferSize buf) = L.Chunk (S.copy bs) k + | otherwise = L.Chunk bs k + where + bs = byteStringFromBuffer buf + +------------------------------------------------------------------------------ +-- Chunked IO Stream +------------------------------------------------------------------------------ + +-- | A stream of chunks that are constructed in the 'IO' monad. +-- +-- This datatype serves as the common interface for the buffer-by-buffer +-- execution of a 'BuildStep' by 'buildStepToCIOS'. Typical users of this +-- interface are 'ciosToLazyByteString' or iteratee-style libraries like +-- @enumerator@. +data ChunkIOStream a = + Finished Buffer a + -- ^ The partially filled last buffer together with the result. + | Yield1 S.ByteString (IO (ChunkIOStream a)) + -- ^ Yield a /non-empty/ strict 'S.ByteString'. + +-- | A smart constructor for yielding one chunk that ignores the chunk if +-- it is empty. +{-# INLINE yield1 #-} +yield1 :: S.ByteString -> IO (ChunkIOStream a) -> IO (ChunkIOStream a) +yield1 bs cios | S.null bs = cios + | otherwise = return $ Yield1 bs cios + +-- | Convert a @'ChunkIOStream' ()@ to a lazy 'L.ByteString' using +-- 'unsafeDupablePerformIO'. +{-# INLINE ciosUnitToLazyByteString #-} +ciosUnitToLazyByteString :: AllocationStrategy + -> L.ByteString -> ChunkIOStream () -> L.ByteString +ciosUnitToLazyByteString strategy k = go + where + go (Finished buf _) = trimmedChunkFromBuffer strategy buf k + go (Yield1 bs io) = L.Chunk bs $ unsafeDupablePerformIO (go <$> io) + +-- | Convert a 'ChunkIOStream' to a lazy tuple of the result and the written +-- 'L.ByteString' using 'unsafeDupablePerformIO'. +{-# INLINE ciosToLazyByteString #-} +ciosToLazyByteString :: AllocationStrategy + -> (a -> (b, L.ByteString)) + -> ChunkIOStream a + -> (b, L.ByteString) +ciosToLazyByteString strategy k = + go + where + go (Finished buf x) = + second (trimmedChunkFromBuffer strategy buf) $ k x + go (Yield1 bs io) = second (L.Chunk bs) $ unsafeDupablePerformIO (go <$> io) + +------------------------------------------------------------------------------ +-- Build signals +------------------------------------------------------------------------------ + +-- | 'BuildStep's may be called *multiple times* and they must not rise an +-- async. exception. +type BuildStep a = BufferRange -> IO (BuildSignal a) + +-- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are +-- three signals: 'done', 'bufferFull', or 'insertChunks signals +data BuildSignal a = + Done {-# UNPACK #-} !(Ptr Word8) a + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + (BuildStep a) + | InsertChunk + {-# UNPACK #-} !(Ptr Word8) + S.ByteString + (BuildStep a) + +-- | Signal that the current 'BuildStep' is done and has computed a value. +{-# INLINE done #-} +done :: Ptr Word8 -- ^ Next free byte in current 'BufferRange' + -> a -- ^ Computed value + -> BuildSignal a +done = Done + +-- | Signal that the current buffer is full. +{-# INLINE bufferFull #-} +bufferFull :: Int + -- ^ Minimal size of next 'BufferRange'. + -> Ptr Word8 + -- ^ Next free byte in current 'BufferRange'. + -> BuildStep a + -- ^ 'BuildStep' to run on the next 'BufferRange'. This 'BuildStep' + -- may assume that it is called with a 'BufferRange' of at least the + -- required minimal size; i.e., the caller of this 'BuildStep' must + -- guarantee this. + -> BuildSignal a +bufferFull = BufferFull + + +-- | Signal that a 'S.ByteString' chunk should be inserted directly. +{-# INLINE insertChunk #-} +insertChunk :: Ptr Word8 + -- ^ Next free byte in current 'BufferRange' + -> S.ByteString + -- ^ Chunk to insert. + -> BuildStep a + -- ^ 'BuildStep' to run on next 'BufferRange' + -> BuildSignal a +insertChunk op bs = InsertChunk op bs + + +-- | Fill a 'BufferRange' using a 'BuildStep'. +{-# INLINE fillWithBuildStep #-} +fillWithBuildStep + :: BuildStep a + -- ^ Build step to use for filling the 'BufferRange'. + -> (Ptr Word8 -> a -> IO b) + -- ^ Handling the 'done' signal + -> (Ptr Word8 -> Int -> BuildStep a -> IO b) + -- ^ Handling the 'bufferFull' signal + -> (Ptr Word8 -> S.ByteString -> BuildStep a -> IO b) + -- ^ Handling the 'insertChunk' signal + -> BufferRange + -- ^ Buffer range to fill. + -> IO b + -- ^ Value computed while filling this 'BufferRange'. +fillWithBuildStep step fDone fFull fChunk !br = do + signal <- step br + case signal of + Done op x -> fDone op x + BufferFull minSize op nextStep -> fFull op minSize nextStep + InsertChunk op bs nextStep -> fChunk op bs nextStep + + +------------------------------------------------------------------------------ +-- The 'Builder' monoid +------------------------------------------------------------------------------ + +-- | 'Builder's denote sequences of bytes. +-- They are 'Monoid's where +-- 'mempty' is the zero-length sequence and +-- 'mappend' is concatenation, which runs in /O(1)/. +newtype Builder = Builder (forall r. BuildStep r -> BuildStep r) + +-- | Construct a 'Builder'. In contrast to 'BuildStep's, 'Builder's are +-- referentially transparent. +{-# INLINE builder #-} +builder :: (forall r. BuildStep r -> BuildStep r) + -- ^ A function that fills a 'BufferRange', calls the continuation with + -- the updated 'BufferRange' once its done, and signals its caller how + -- to proceed using 'done', 'bufferFull', or 'insertChunk'. + -- + -- This function must be referentially transparent; i.e., calling it + -- multiple times with equally sized 'BufferRange's must result in the + -- same sequence of bytes being written. If you need mutable state, + -- then you must allocate it anew upon each call of this function. + -- Moroever, this function must call the continuation once its done. + -- Otherwise, concatenation of 'Builder's does not work. Finally, this + -- function must write to all bytes that it claims it has written. + -- Otherwise, the resulting 'Builder' is not guaranteed to be + -- referentially transparent and sensitive data might leak. + -> Builder +builder = Builder + +-- | The final build step that returns the 'done' signal. +finalBuildStep :: BuildStep () +finalBuildStep !(BufferRange op _) = return $ Done op () + +-- | Run a 'Builder' with the 'finalBuildStep'. +{-# INLINE runBuilder #-} +runBuilder :: Builder -- ^ 'Builder' to run + -> BuildStep () -- ^ 'BuildStep' that writes the byte stream of this + -- 'Builder' and signals 'done' upon completion. +runBuilder b = runBuilderWith b finalBuildStep + +-- | Run a 'Builder'. +{-# INLINE runBuilderWith #-} +runBuilderWith :: Builder -- ^ 'Builder' to run + -> BuildStep a -- ^ Continuation 'BuildStep' + -> BuildStep a +runBuilderWith (Builder b) = b + +-- | The 'Builder' denoting a zero-length sequence of bytes. This function is +-- only exported for use in rewriting rules. Use 'mempty' otherwise. +{-# INLINE[1] empty #-} +empty :: Builder +empty = Builder id + +-- | Concatenate two 'Builder's. This function is only exported for use in rewriting +-- rules. Use 'mappend' otherwise. +{-# INLINE[1] append #-} +append :: Builder -> Builder -> Builder +append (Builder b1) (Builder b2) = Builder $ b1 . b2 + +instance Monoid Builder where + {-# INLINE mempty #-} + mempty = empty + {-# INLINE mappend #-} + mappend = append + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty + +-- | Flush the current buffer. This introduces a chunk boundary. +{-# INLINE flush #-} +flush :: Builder +flush = builder step + where + step k !(BufferRange op _) = return $ insertChunk op S.empty k + + +------------------------------------------------------------------------------ +-- Put +------------------------------------------------------------------------------ + +-- | A 'Put' action denotes a computation of a value that writes a stream of +-- bytes as a side-effect. 'Put's are strict in their side-effect; i.e., the +-- stream of bytes will always be written before the computed value is +-- returned. +-- +-- 'Put's are a generalization of 'Builder's. The typical use case is the +-- implementation of an encoding that might fail (e.g., an interface to the +-- 'zlib' compression library or the conversion from Base64 encoded data to +-- 8-bit data). For a 'Builder', the only way to handle and report such a +-- failure is ignore it or call 'error'. In contrast, 'Put' actions are +-- expressive enough to allow reportng and handling such a failure in a pure +-- fashion. +-- +-- @'Put' ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder' +-- and 'fromPut' convert between these two types. Where possible, you should +-- use 'Builder's, as sequencing them is slightly cheaper than sequencing +-- 'Put's because they do not carry around a computed value. +newtype Put a = Put { unPut :: forall r. (a -> BuildStep r) -> BuildStep r } + +-- | Construct a 'Put' action. In contrast to 'BuildStep's, 'Put's are +-- referentially transparent in the sense that sequencing the same 'Put' +-- multiple times yields every time the same value with the same side-effect. +{-# INLINE put #-} +put :: (forall r. (a -> BuildStep r) -> BuildStep r) + -- ^ A function that fills a 'BufferRange', calls the continuation with + -- the updated 'BufferRange' and its computed value once its done, and + -- signals its caller how to proceed using 'done', 'bufferFull', or + -- 'insertChunk' signals. + -- + -- This function must be referentially transparent; i.e., calling it + -- multiple times with equally sized 'BufferRange's must result in the + -- same sequence of bytes being written and the same value being + -- computed. If you need mutable state, then you must allocate it anew + -- upon each call of this function. Moroever, this function must call + -- the continuation once its done. Otherwise, monadic sequencing of + -- 'Put's does not work. Finally, this function must write to all bytes + -- that it claims it has written. Otherwise, the resulting 'Put' is + -- not guaranteed to be referentially transparent and sensitive data + -- might leak. + -> Put a +put = Put + +-- | Run a 'Put'. +{-# INLINE runPut #-} +runPut :: Put a -- ^ Put to run + -> BuildStep a -- ^ 'BuildStep' that first writes the byte stream of + -- this 'Put' and then yields the computed value using + -- the 'done' signal. +runPut (Put p) = p $ \x (BufferRange op _) -> return $ Done op x + +instance Functor Put where + fmap f p = Put $ \k -> unPut p (\x -> k (f x)) + {-# INLINE fmap #-} + +-- | Synonym for '<*' from 'Applicative'; used in rewriting rules. +{-# INLINE[1] ap_l #-} +ap_l :: Put a -> Put b -> Put a +ap_l (Put a) (Put b) = Put $ \k -> a (\a' -> b (\_ -> k a')) + +-- | Synonym for '*>' from 'Applicative' and '>>' from 'Monad'; used in +-- rewriting rules. +{-# INLINE[1] ap_r #-} +ap_r :: Put a -> Put b -> Put b +ap_r (Put a) (Put b) = Put $ \k -> a (\_ -> b k) + +instance Applicative Put where + {-# INLINE pure #-} + pure x = Put $ \k -> k x + {-# INLINE (<*>) #-} + Put f <*> Put a = Put $ \k -> f (\f' -> a (\a' -> k (f' a'))) +#if MIN_VERSION_base(4,2,0) + {-# INLINE (<*) #-} + (<*) = ap_l + {-# INLINE (*>) #-} + (*>) = ap_r +#endif + +instance Monad Put where + {-# INLINE return #-} + return x = Put $ \k -> k x + {-# INLINE (>>=) #-} + Put m >>= f = Put $ \k -> m (\m' -> unPut (f m') k) + {-# INLINE (>>) #-} + (>>) = ap_r + + +-- Conversion between Put and Builder +------------------------------------- + +-- | Run a 'Builder' as a side-effect of a @'Put' ()@ action. +{-# INLINE[1] putBuilder #-} +putBuilder :: Builder -> Put () +putBuilder (Builder b) = Put $ \k -> b (k ()) + +-- | Convert a @'Put' ()@ action to a 'Builder'. +{-# INLINE fromPut #-} +fromPut :: Put () -> Builder +fromPut (Put p) = Builder $ \k -> p (\_ -> k) + +-- We rewrite consecutive uses of 'putBuilder' such that the append of the +-- involved 'Builder's is used. This can significantly improve performance, +-- when the bound-checks of the concatenated builders are fused. + +-- ap_l rules +{-# RULES + +"ap_l/putBuilder" forall b1 b2. + ap_l (putBuilder b1) (putBuilder b2) + = putBuilder (append b1 b2) + +"ap_l/putBuilder/assoc_r" forall b1 b2 (p :: Put a). + ap_l (putBuilder b1) (ap_l (putBuilder b2) p) + = ap_l (putBuilder (append b1 b2)) p + +"ap_l/putBuilder/assoc_l" forall (p :: Put a) b1 b2. + ap_l (ap_l p (putBuilder b1)) (putBuilder b2) + = ap_l p (putBuilder (append b1 b2)) + #-} + +-- ap_r rules +{-# RULES + +"ap_r/putBuilder" forall b1 b2. + ap_r (putBuilder b1) (putBuilder b2) + = putBuilder (append b1 b2) + +"ap_r/putBuilder/assoc_r" forall b1 b2 (p :: Put a). + ap_r (putBuilder b1) (ap_r (putBuilder b2) p) + = ap_r (putBuilder (append b1 b2)) p + +"ap_r/putBuilder/assoc_l" forall (p :: Put a) b1 b2. + ap_r (ap_r p (putBuilder b1)) (putBuilder b2) + = ap_r p (putBuilder (append b1 b2)) + + #-} + +-- combined ap_l/ap_r rules +{-# RULES + +"ap_l/ap_r/putBuilder/assoc_r" forall b1 b2 (p :: Put a). + ap_l (putBuilder b1) (ap_r (putBuilder b2) p) + = ap_l (putBuilder (append b1 b2)) p + +"ap_r/ap_l/putBuilder/assoc_r" forall b1 b2 (p :: Put a). + ap_r (putBuilder b1) (ap_l (putBuilder b2) p) + = ap_l (putBuilder (append b1 b2)) p + +"ap_l/ap_r/putBuilder/assoc_l" forall (p :: Put a) b1 b2. + ap_l (ap_r p (putBuilder b1)) (putBuilder b2) + = ap_r p (putBuilder (append b1 b2)) + +"ap_r/ap_l/putBuilder/assoc_l" forall (p :: Put a) b1 b2. + ap_r (ap_l p (putBuilder b1)) (putBuilder b2) + = ap_r p (putBuilder (append b1 b2)) + + #-} + + +-- Lifting IO actions +--------------------- + +{- +-- | Lift an 'IO' action to a 'Put' action. +{-# INLINE putLiftIO #-} +putLiftIO :: IO a -> Put a +putLiftIO io = put $ \k br -> io >>= (`k` br) +-} + + +------------------------------------------------------------------------------ +-- Executing a Put directly on a buffered Handle +------------------------------------------------------------------------------ + +-- | Run a 'Put' action redirecting the produced output to a 'Handle'. +-- +-- The output is buffered using the 'Handle's associated buffer. If this +-- buffer is too small to execute one step of the 'Put' action, then +-- it is replaced with a large enough buffer. +hPut :: forall a. Handle -> Put a -> IO a +#if __GLASGOW_HASKELL__ >= 611 +hPut h p = do + fillHandle 1 (runPut p) + where + fillHandle :: Int -> BuildStep a -> IO a + fillHandle !minFree step = do + next <- wantWritableHandle "hPut" h fillHandle_ + next + where + -- | We need to return an inner IO action that is executed outside + -- the lock taken on the Handle for two reasons: + -- + -- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that + -- we should never do any side-effecting operations before + -- an interuptible operation that may raise an async. exception + -- as long as we are inside 'wantWritableHandle' and the like. + -- We possibly run the interuptible 'flushWriteBuffer' right at + -- the start of 'fillHandle', hence entering it a second time is + -- not safe, as it could lead to a 'BuildStep' being run twice. + -- + -- FIXME (SM): Adapt this function or at least its documentation, + -- as it is OK to run a 'BuildStep' twice. We dropped this + -- requirement in favor of being able to use + -- 'unsafeDupablePerformIO' and the speed improvement that it + -- brings. + -- + -- 2. We use the 'S.hPut' function to also write to the handle. + -- This function tries to take the same lock taken by + -- 'wantWritableHandle'. Therefore, we cannot call 'S.hPut' + -- inside 'wantWritableHandle'. + -- + fillHandle_ :: Handle__ -> IO (IO a) + fillHandle_ h_ = do + makeSpace =<< readIORef refBuf + fillBuffer =<< readIORef refBuf + where + refBuf = haByteBuffer h_ + freeSpace buf = IO.bufSize buf - IO.bufR buf + + makeSpace buf + | IO.bufSize buf < minFree = do + flushWriteBuffer h_ + s <- IO.bufState <$> readIORef refBuf + IO.newByteBuffer minFree s >>= writeIORef refBuf + + | freeSpace buf < minFree = flushWriteBuffer h_ + | otherwise = +#if __GLASGOW_HASKELL__ >= 613 + return () +#else + -- required for ghc-6.12 + flushWriteBuffer h_ +#endif + + fillBuffer buf + | freeSpace buf < minFree = + error $ unlines + [ "Data.ByteString.Builder.Internal.hPut: internal error." + , " Not enough space after flush." + , " required: " ++ show minFree + , " free: " ++ show (freeSpace buf) + ] + | otherwise = do + let !br = BufferRange op (pBuf `plusPtr` IO.bufSize buf) + res <- fillWithBuildStep step doneH fullH insertChunkH br + touchForeignPtr fpBuf + return res + where + fpBuf = IO.bufRaw buf + pBuf = unsafeForeignPtrToPtr fpBuf + op = pBuf `plusPtr` IO.bufR buf + + {-# INLINE updateBufR #-} + updateBufR op' = do + let !off' = op' `minusPtr` pBuf + !buf' = buf {IO.bufR = off'} + writeIORef refBuf buf' + + doneH op' x = do + updateBufR op' + -- We must flush if this Handle is set to NoBuffering. + -- If it is set to LineBuffering, be conservative and + -- flush anyway (we didn't check for newlines in the data). + -- Flushing must happen outside this 'wantWriteableHandle' + -- due to the possible async. exception. + case haBufferMode h_ of + BlockBuffering _ -> return $ return x + _line_or_no_buffering -> return $ hFlush h >> return x + + fullH op' minSize nextStep = do + updateBufR op' + return $ fillHandle minSize nextStep + -- 'fillHandle' will flush the buffer (provided there is + -- really less than 'minSize' space left) before executing + -- the 'nextStep'. + + insertChunkH op' bs nextStep = do + updateBufR op' + return $ do + S.hPut h bs + fillHandle 1 nextStep +#else +hPut h p = + go =<< buildStepToCIOS strategy (runPut p) + where + strategy = untrimmedStrategy L.smallChunkSize L.defaultChunkSize + + go (Finished buf x) = S.hPut h (byteStringFromBuffer buf) >> return x + go (Yield1 bs io) = S.hPut h bs >> io >>= go +#endif + +-- | Execute a 'Put' and return the computed result and the bytes +-- written during the computation as a lazy 'L.ByteString'. +-- +-- This function is strict in the computed result and lazy in the writing of +-- the bytes. For example, given +-- +-- @ +--infinitePut = sequence_ (repeat (putBuilder (word8 1))) >> return 0 +-- @ +-- +-- evaluating the expression +-- +-- @ +--fst $ putToLazyByteString infinitePut +-- @ +-- +-- does not terminate, while evaluating the expression +-- +-- @ +--L.head $ snd $ putToLazyByteString infinitePut +-- @ +-- +-- does terminate and yields the value @1 :: Word8@. +-- +-- An illustrative example for these strictness properties is the +-- implementation of Base64 decoding (). +-- +-- @ +--type DecodingState = ... +-- +--decodeBase64 :: 'S.ByteString' -> DecodingState -> 'Put' (Maybe DecodingState) +--decodeBase64 = ... +-- @ +-- +-- The above function takes a strict 'S.ByteString' supposed to represent +-- Base64 encoded data and the current decoding state. +-- It writes the decoded bytes as the side-effect of the 'Put' and returns the +-- new decoding state, if the decoding of all data in the 'S.ByteString' was +-- successful. The checking if the strict 'S.ByteString' represents Base64 +-- encoded data and the actual decoding are fused. This makes the common case, +-- where all data represents Base64 encoded data, more efficient. It also +-- implies that all data must be decoded before the final decoding +-- state can be returned. 'Put's are intended for implementing such fused +-- checking and decoding/encoding, which is reflected in their strictness +-- properties. +{-# NOINLINE putToLazyByteString #-} +putToLazyByteString + :: Put a -- ^ 'Put' to execute + -> (a, L.ByteString) -- ^ Result and lazy 'L.ByteString' + -- written as its side-effect +putToLazyByteString = putToLazyByteStringWith + (safeStrategy L.smallChunkSize L.defaultChunkSize) (\x -> (x, L.Empty)) + + +-- | Execute a 'Put' with a buffer-allocation strategy and a continuation. For +-- example, 'putToLazyByteString' is implemented as follows. +-- +-- @ +--putToLazyByteString = 'putToLazyByteStringWith' +-- ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') (\x -> (x, L.empty)) +-- @ +-- +{-# INLINE putToLazyByteStringWith #-} +putToLazyByteStringWith + :: AllocationStrategy + -- ^ Buffer allocation strategy to use + -> (a -> (b, L.ByteString)) + -- ^ Continuation to use for computing the final result and the tail of + -- its side-effect (the written bytes). + -> Put a + -- ^ 'Put' to execute + -> (b, L.ByteString) + -- ^ Resulting lazy 'L.ByteString' +putToLazyByteStringWith strategy k p = + ciosToLazyByteString strategy k $ unsafeDupablePerformIO $ + buildStepToCIOS strategy (runPut p) + + + +------------------------------------------------------------------------------ +-- ByteString insertion / controlling chunk boundaries +------------------------------------------------------------------------------ + +-- Raw memory +------------- + +-- | Ensure that there are at least 'n' free bytes for the following 'Builder'. +{-# INLINE ensureFree #-} +ensureFree :: Int -> Builder +ensureFree minFree = + builder step + where + step k br@(BufferRange op ope) + | ope `minusPtr` op < minFree = return $ bufferFull minFree op k + | otherwise = k br + +-- | Copy the bytes from a 'BufferRange' into the output stream. +wrappedBytesCopyStep :: BufferRange -- ^ Input 'BufferRange'. + -> BuildStep a -> BuildStep a +wrappedBytesCopyStep !(BufferRange ip0 ipe) k = + go ip0 + where + go !ip !(BufferRange op ope) + | inpRemaining <= outRemaining = do + copyBytes op ip inpRemaining + let !br' = BufferRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + copyBytes op ip outRemaining + let !ip' = ip `plusPtr` outRemaining + return $ bufferFull 1 ope (go ip') + where + outRemaining = ope `minusPtr` op + inpRemaining = ipe `minusPtr` ip + + +-- Strict ByteStrings +------------------------------------------------------------------------------ + + +-- | Construct a 'Builder' that copies the strict 'S.ByteString's, if it is +-- smaller than the treshold, and inserts it directly otherwise. +-- +-- For example, @byteStringThreshold 1024@ copies strict 'S.ByteString's whose size +-- is less or equal to 1kb, and inserts them directly otherwise. This implies +-- that the average chunk-size of the generated lazy 'L.ByteString' may be as +-- low as 513 bytes, as there could always be just a single byte between the +-- directly inserted 1025 byte, strict 'S.ByteString's. +-- +{-# INLINE byteStringThreshold #-} +byteStringThreshold :: Int -> S.ByteString -> Builder +byteStringThreshold maxCopySize = + \bs -> builder $ step bs + where + step !bs@(S.PS _ _ len) !k br@(BufferRange !op _) + | len <= maxCopySize = byteStringCopyStep bs k br + | otherwise = return $ insertChunk op bs k + +-- | Construct a 'Builder' that copies the strict 'S.ByteString'. +-- +-- Use this function to create 'Builder's from smallish (@<= 4kb@) +-- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not +-- shared with the chunks generated by the 'Builder'. +-- +{-# INLINE byteStringCopy #-} +byteStringCopy :: S.ByteString -> Builder +byteStringCopy = \bs -> builder $ byteStringCopyStep bs + +{-# INLINE byteStringCopyStep #-} +byteStringCopyStep :: S.ByteString -> BuildStep a -> BuildStep a +byteStringCopyStep (S.PS ifp ioff isize) !k0 br0@(BufferRange op ope) + -- Ensure that the common case is not recursive and therefore yields + -- better code. + | op' <= ope = do copyBytes op ip isize + touchForeignPtr ifp + k0 (BufferRange op' ope) + | otherwise = do wrappedBytesCopyStep (BufferRange ip ipe) k br0 + where + op' = op `plusPtr` isize + ip = unsafeForeignPtrToPtr ifp `plusPtr` ioff + ipe = ip `plusPtr` isize + k br = do touchForeignPtr ifp -- input consumed: OK to release here + k0 br + +-- | Construct a 'Builder' that always inserts the strict 'S.ByteString' +-- directly as a chunk. +-- +-- This implies flushing the output buffer, even if it contains just +-- a single byte. You should therefore use 'byteStringInsert' only for large +-- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too +-- fragmented to be processed efficiently afterwards. +-- +{-# INLINE byteStringInsert #-} +byteStringInsert :: S.ByteString -> Builder +byteStringInsert = + \bs -> builder $ \k (BufferRange op _) -> return $ insertChunk op bs k + +-- Short bytestrings +------------------------------------------------------------------------------ + +-- | Construct a 'Builder' that copies the 'SH.ShortByteString'. +-- +{-# INLINE shortByteString #-} +shortByteString :: Sh.ShortByteString -> Builder +shortByteString = \sbs -> builder $ shortByteStringCopyStep sbs + +-- | Copy the bytes from a 'SH.ShortByteString' into the output stream. +{-# INLINE shortByteStringCopyStep #-} +shortByteStringCopyStep :: Sh.ShortByteString -- ^ Input 'SH.ShortByteString'. + -> BuildStep a -> BuildStep a +shortByteStringCopyStep !sbs k = + go 0 (Sh.length sbs) + where + go !ip !ipe !(BufferRange op ope) + | inpRemaining <= outRemaining = do + Sh.copyToPtr sbs ip op inpRemaining + let !br' = BufferRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + Sh.copyToPtr sbs ip op outRemaining + let !ip' = ip + outRemaining + return $ bufferFull 1 ope (go ip' ipe) + where + outRemaining = ope `minusPtr` op + inpRemaining = ipe - ip + + +-- Lazy bytestrings +------------------------------------------------------------------------------ + +-- | Construct a 'Builder' that uses the thresholding strategy of 'byteStringThreshold' +-- for each chunk of the lazy 'L.ByteString'. +-- +{-# INLINE lazyByteStringThreshold #-} +lazyByteStringThreshold :: Int -> L.ByteString -> Builder +lazyByteStringThreshold maxCopySize = + L.foldrChunks (\bs b -> byteStringThreshold maxCopySize bs `mappend` b) mempty + -- TODO: We could do better here. Currently, Large, Small, Large, leads to + -- an unnecessary copy of the 'Small' chunk. + +-- | Construct a 'Builder' that copies the lazy 'L.ByteString'. +-- +{-# INLINE lazyByteStringCopy #-} +lazyByteStringCopy :: L.ByteString -> Builder +lazyByteStringCopy = + L.foldrChunks (\bs b -> byteStringCopy bs `mappend` b) mempty + +-- | Construct a 'Builder' that inserts all chunks of the lazy 'L.ByteString' +-- directly. +-- +{-# INLINE lazyByteStringInsert #-} +lazyByteStringInsert :: L.ByteString -> Builder +lazyByteStringInsert = + L.foldrChunks (\bs b -> byteStringInsert bs `mappend` b) mempty + +-- | Create a 'Builder' denoting the same sequence of bytes as a strict +-- 'S.ByteString'. +-- The 'Builder' inserts large 'S.ByteString's directly, but copies small ones +-- to ensure that the generated chunks are large on average. +-- +{-# INLINE byteString #-} +byteString :: S.ByteString -> Builder +byteString = byteStringThreshold maximalCopySize + +-- | Create a 'Builder' denoting the same sequence of bytes as a lazy +-- 'S.ByteString'. +-- The 'Builder' inserts large chunks of the lazy 'L.ByteString' directly, +-- but copies small ones to ensure that the generated chunks are large on +-- average. +-- +{-# INLINE lazyByteString #-} +lazyByteString :: L.ByteString -> Builder +lazyByteString = lazyByteStringThreshold maximalCopySize +-- FIXME: also insert the small chunk for [large,small,large] directly. +-- Perhaps it makes even sense to concatenate the small chunks in +-- [large,small,small,small,large] and insert them directly afterwards to avoid +-- unnecessary buffer spilling. Hmm, but that uncontrollably increases latency +-- => no good! + +-- | The maximal size of a 'S.ByteString' that is copied. +-- @2 * 'L.smallChunkSize'@ to guarantee that on average a chunk is of +-- 'L.smallChunkSize'. +maximalCopySize :: Int +maximalCopySize = 2 * L.smallChunkSize + +------------------------------------------------------------------------------ +-- Builder execution +------------------------------------------------------------------------------ + +-- | A buffer allocation strategy for executing 'Builder's. + +-- The strategy +-- +-- > 'AllocationStrategy' firstBufSize bufSize trim +-- +-- states that the first buffer is of size @firstBufSize@, all following buffers +-- are of size @bufSize@, and a buffer of size @n@ filled with @k@ bytes should +-- be trimmed iff @trim k n@ is 'True'. +data AllocationStrategy = AllocationStrategy + (Maybe (Buffer, Int) -> IO Buffer) + {-# UNPACK #-} !Int + (Int -> Int -> Bool) + +-- | Create a custom allocation strategy. See the code for 'safeStrategy' and +-- 'untrimmedStrategy' for examples. +{-# INLINE customStrategy #-} +customStrategy + :: (Maybe (Buffer, Int) -> IO Buffer) + -- ^ Buffer allocation function. If 'Nothing' is given, then a new first + -- buffer should be allocated. If @'Just' (oldBuf, minSize)@ is given, + -- then a buffer with minimal size 'minSize' must be returned. The + -- strategy may reuse the 'oldBuffer', if it can guarantee that this + -- referentially transparent and 'oldBuffer' is large enough. + -> Int + -- ^ Default buffer size. + -> (Int -> Int -> Bool) + -- ^ A predicate @trim used allocated@ returning 'True', if the buffer + -- should be trimmed before it is returned. + -> AllocationStrategy +customStrategy = AllocationStrategy + +-- | Sanitize a buffer size; i.e., make it at least the size of an 'Int'. +{-# INLINE sanitize #-} +sanitize :: Int -> Int +sanitize = max (sizeOf (undefined :: Int)) + +-- | Use this strategy for generating lazy 'L.ByteString's whose chunks are +-- discarded right after they are generated. For example, if you just generate +-- them to write them to a network socket. +{-# INLINE untrimmedStrategy #-} +untrimmedStrategy :: Int -- ^ Size of the first buffer + -> Int -- ^ Size of successive buffers + -> AllocationStrategy + -- ^ An allocation strategy that does not trim any of the + -- filled buffers before converting it to a chunk +untrimmedStrategy firstSize bufSize = + AllocationStrategy nextBuffer (sanitize bufSize) (\_ _ -> False) + where + {-# INLINE nextBuffer #-} + nextBuffer Nothing = newBuffer $ sanitize firstSize + nextBuffer (Just (_, minSize)) = newBuffer minSize + + +-- | Use this strategy for generating lazy 'L.ByteString's whose chunks are +-- likely to survive one garbage collection. This strategy trims buffers +-- that are filled less than half in order to avoid spilling too much memory. +{-# INLINE safeStrategy #-} +safeStrategy :: Int -- ^ Size of first buffer + -> Int -- ^ Size of successive buffers + -> AllocationStrategy + -- ^ An allocation strategy that guarantees that at least half + -- of the allocated memory is used for live data +safeStrategy firstSize bufSize = + AllocationStrategy nextBuffer (sanitize bufSize) trim + where + trim used size = 2 * used < size + {-# INLINE nextBuffer #-} + nextBuffer Nothing = newBuffer $ sanitize firstSize + nextBuffer (Just (_, minSize)) = newBuffer minSize + +-- | /Heavy inlining./ Execute a 'Builder' with custom execution parameters. +-- +-- This function is inlined despite its heavy code-size to allow fusing with +-- the allocation strategy. For example, the default 'Builder' execution +-- function 'toLazyByteString' is defined as follows. +-- +-- @ +-- {-\# NOINLINE toLazyByteString \#-} +-- toLazyByteString = +-- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') L.empty +-- @ +-- +-- where @L.empty@ is the zero-length lazy 'L.ByteString'. +-- +-- In most cases, the parameters used by 'toLazyByteString' give good +-- performance. A sub-performing case of 'toLazyByteString' is executing short +-- (<128 bytes) 'Builder's. In this case, the allocation overhead for the first +-- 4kb buffer and the trimming cost dominate the cost of executing the +-- 'Builder'. You can avoid this problem using +-- +-- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.empty +-- +-- This reduces the allocation and trimming overhead, as all generated +-- 'L.ByteString's fit into the first buffer and there is no trimming +-- required, if more than 64 bytes and less than 128 bytes are written. +-- +{-# INLINE toLazyByteStringWith #-} +toLazyByteStringWith + :: AllocationStrategy + -- ^ Buffer allocation strategy to use + -> L.ByteString + -- ^ Lazy 'L.ByteString' to use as the tail of the generated lazy + -- 'L.ByteString' + -> Builder + -- ^ 'Builder' to execute + -> L.ByteString + -- ^ Resulting lazy 'L.ByteString' +toLazyByteStringWith strategy k b = + ciosUnitToLazyByteString strategy k $ unsafeDupablePerformIO $ + buildStepToCIOS strategy (runBuilder b) + +-- | Convert a 'BuildStep' to a 'ChunkIOStream' stream by executing it on +-- 'Buffer's allocated according to the given 'AllocationStrategy'. +{-# INLINE buildStepToCIOS #-} +buildStepToCIOS + :: AllocationStrategy -- ^ Buffer allocation strategy to use + -> BuildStep a -- ^ 'BuildStep' to execute + -> IO (ChunkIOStream a) +buildStepToCIOS !(AllocationStrategy nextBuffer bufSize trim) = + \step -> nextBuffer Nothing >>= fill step + where + fill !step !buf@(Buffer fpbuf br@(BufferRange _ pe)) = do + res <- fillWithBuildStep step doneH fullH insertChunkH br + touchForeignPtr fpbuf + return res + where + pbuf = unsafeForeignPtrToPtr fpbuf + + doneH op' x = return $ + Finished (Buffer fpbuf (BufferRange op' pe)) x + + fullH op' minSize nextStep = + wrapChunk op' $ const $ + nextBuffer (Just (buf, max minSize bufSize)) >>= fill nextStep + + insertChunkH op' bs nextStep = + wrapChunk op' $ \isEmpty -> yield1 bs $ + -- Checking for empty case avoids allocating 'n-1' empty + -- buffers for 'n' insertChunkH right after each other. + if isEmpty + then fill nextStep buf + else do buf' <- nextBuffer (Just (buf, bufSize)) + fill nextStep buf' + + -- Wrap and yield a chunk, trimming it if necesary + {-# INLINE wrapChunk #-} + wrapChunk !op' mkCIOS + | chunkSize == 0 = mkCIOS True + | trim chunkSize size = do + bs <- S.create chunkSize $ \pbuf' -> + copyBytes pbuf' pbuf chunkSize + -- FIXME: We could reuse the trimmed buffer here. + return $ Yield1 bs (mkCIOS False) + | otherwise = + return $ Yield1 (S.PS fpbuf 0 chunkSize) (mkCIOS False) + where + chunkSize = op' `minusPtr` pbuf + size = pe `minusPtr` pbuf diff --git a/src/Data/ByteString/Builder/Prim.hs b/src/Data/ByteString/Builder/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Prim.hs @@ -0,0 +1,741 @@ +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +{- | Copyright : (c) 2010-2011 Simon Meier + (c) 2010 Jasper van der Jeugt +License : BSD3-style (see LICENSE) +Maintainer : Simon Meier +Portability : GHC + +This module provides 'Builder' /primitives/, which are lower level building +blocks for constructing 'Builder's. You don't need to go down to this level but +it can be slightly faster. + +Morally, builder primitives are like functions @a -> Builder@, that is they +take a value and encode it as a sequence of bytes, represented as a 'Builder'. +Of course their implementation is a bit more specialised. + +Builder primitives come in two forms: fixed-size and bounded-size. + +* /Fixed(-size) primitives/ are builder primitives that always result in a + sequence of bytes of a fixed length. That is, the length is independent of + the value that is encoded. An example of a fixed size primitive is the + big-endian encoding of a 'Word64', which always results in exactly 8 bytes. + +* /Bounded(-size) primitives/ are builder primitives that always result in a + sequence of bytes that is no larger than a predetermined bound. That is, the + bound is independent of the value that is encoded but the actual length will + depend on the value. An example for a bounded primitive is the UTF-8 encoding + of a 'Char', which can be 1,2,3 or 4 bytes long, so the bound is 4 bytes. + +Note that fixed primitives can be considered as a special case of bounded +primitives, and we can lift from fixed to bounded. + +Because bounded primitives are the more general case, in this documentation we +only refer to fixed size primitives where it matters that the resulting +sequence of bytes is of a fixed length. Otherwise, we just refer to bounded +size primitives. + +The purpose of using builder primitives is to improve the performance of +'Builder's. These improvements stem from making the two most common steps +performed by a 'Builder' more efficient. We explain these two steps in turn. + +The first most common step is the concatenation of two 'Builder's. Internally, +concatenation corresponds to function composition. (Note that 'Builder's can +be seen as difference-lists of buffer-filling functions; cf. +. ) +Function composition is a fast /O(1)/ operation. However, we can use bounded +primitives to remove some of these function compositions altogether, which is +more efficient. + +The second most common step performed by a 'Builder' is to fill a buffer using +a bounded primitives, which works as follows. The 'Builder' checks whether +there is enough space left to execute the bounded primitive. If there is, then +the 'Builder' executes the bounded primitive and calls the next 'Builder' with +the updated buffer. Otherwise, the 'Builder' signals its driver that it +requires a new buffer. This buffer must be at least as large as the bound of +the primitive. We can use bounded primitives to reduce the number of +buffer-free checks by fusing the buffer-free checks of consecutive 'Builder's. +We can also use bounded primitives to simplify the control flow for signalling +that a buffer is full by ensuring that we check first that there is enough +space left and only then decide on how to encode a given value. + +Let us illustrate these improvements on the CSV-table rendering example from +"Data.ByteString.Builder". Its \"hot code\" is the rendering of a table's +cells, which we implement as follows using only the functions from the +'Builder' API. + +@ +import "Data.ByteString.Builder" as B + +renderCell :: Cell -> Builder +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = B.intDec i + +renderString :: String -> Builder +renderString cs = B.charUtf8 \'\"\' \<\> foldMap escape cs \<\> B.charUtf8 \'\"\' + where + escape \'\\\\\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\\\' + escape \'\\\"\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\"\' + escape c = B.charUtf8 c +@ + +Efficient encoding of 'Int's as decimal numbers is performed by @intDec@. +Optimization potential exists for the escaping of 'String's. The above +implementation has two optimization opportunities. First, the buffer-free +checks of the 'Builder's for escaping double quotes and backslashes can be +fused. Second, the concatenations performed by 'foldMap' can be eliminated. +The following implementation exploits these optimizations. + +@ +import qualified Data.ByteString.Builder.Prim as P +import Data.ByteString.Builder.Prim + ( 'condB', 'liftFixedToBounded', ('>*<'), ('>$<') ) + +renderString :: String -\> Builder +renderString cs = + B.charUtf8 \'\"\' \<\> E.'encodeListWithB' escape cs \<\> B.charUtf8 \'\"\' + where + escape :: E.'BoundedPrim' Char + escape = + 'condB' (== \'\\\\\') (fixed2 (\'\\\\\', \'\\\\\')) $ + 'condB' (== \'\\\"\') (fixed2 (\'\\\\\', \'\\\"\')) $ + E.'charUtf8' +   + {-\# INLINE fixed2 \#-} + fixed2 x = 'liftFixedToBounded' $ const x '>$<' E.'char7' '>*<' E.'char7' +@ + +The code should be mostly self-explanatory. The slightly awkward syntax is +because the combinators are written such that the size-bound of the resulting +'BoundedPrim' can be computed at compile time. We also explicitly inline the +'fixed2' primitive, which encodes a fixed tuple of characters, to ensure that +the bound computation happens at compile time. When encoding the following list +of 'String's, the optimized implementation of 'renderString' is two times +faster. + +@ +maxiStrings :: [String] +maxiStrings = take 1000 $ cycle [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] +@ + +Most of the performance gain stems from using 'primMapListBounded', which +encodes a list of values from left-to-right with a 'BoundedPrim'. It exploits +the 'Builder' internals to avoid unnecessary function compositions (i.e., +concatenations). In the future, we might expect the compiler to perform the +optimizations implemented in 'primMapListBounded'. However, it seems that the +code is currently to complicated for the compiler to see through. Therefore, we +provide the 'BoundedPrim' escape hatch, which allows data structures to provide +very efficient encoding traversals, like 'primMapListBounded' for lists. + +Note that 'BoundedPrim's are a bit verbose, but quite versatile. Here is an +example of a 'BoundedPrim' for combined HTML escaping and UTF-8 encoding. It +exploits that the escaped character with the maximal Unicode codepoint is \'>\'. + +@ +{-\# INLINE charUtf8HtmlEscaped \#-} +charUtf8HtmlEscaped :: E.BoundedPrim Char +charUtf8HtmlEscaped = + 'condB' (> \'\>\' ) E.'charUtf8' $ + 'condB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $ -- < + 'condB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $ -- > + 'condB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $ -- & + 'condB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $ -- &\#34; + 'condB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $ -- &\#39; + ('liftFixedToBounded' E.'char7') -- fallback for 'Char's smaller than \'\>\' + where + {-\# INLINE fixed4 \#-} + fixed4 x = 'liftFixedToBounded' $ const x '>$<' + E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 +   + {-\# INLINE fixed5 \#-} + fixed5 x = 'liftFixedToBounded' $ const x '>$<' + E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 +@ + +This module currently does not expose functions that require the special +properties of fixed-size primitives. They are useful for prefixing 'Builder's +with their size or for implementing chunked encodings. We will expose the +corresponding functions in future releases of this library. +-} + + + +{- +-- +-- +-- A /bounded primitive/ is a builder primitive that never results in a sequence +-- longer than some fixed number of bytes. This number of bytes must be +-- independent of the value being encoded. Typical examples of bounded +-- primitives are the big-endian encoding of a 'Word64', which results always +-- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always +-- in less or equal to 4 bytes. +-- +-- Typically, primitives are implemented efficiently by allocating a buffer (an +-- array of bytes) and repeatedly executing the following two steps: (1) +-- writing to the buffer until it is full and (2) handing over the filled part +-- to the consumer of the encoded value. Step (1) is where bounded primitives +-- are used. We must use a bounded primitive, as we must check that there is +-- enough free space /before/ actually writing to the buffer. +-- +-- In term of expressiveness, it would be sufficient to construct all encodings +-- from the single bounded encoding that encodes a 'Word8' as-is. However, +-- this is not sufficient in terms of efficiency. It results in unnecessary +-- buffer-full checks and it complicates the program-flow for writing to the +-- buffer, as buffer-full checks are interleaved with analysing the value to be +-- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a +-- significant effect on overall encoding performance, as encoding primitive +-- Haskell values such as 'Word8's or 'Char's lies at the heart of every +-- encoding implementation. +-- +-- The bounded 'Encoding's provided by this module remove this performance +-- problem. Intuitively, they consist of a tuple of the bound on the maximal +-- number of bytes written and the actual implementation of the encoding as a +-- function that modifies a mutable buffer. Hence when executing a bounded +-- 'Encoding', the buffer-full check can be done once before the actual writing +-- to the buffer. The provided 'Encoding's also take care to implement the +-- actual writing to the buffer efficiently. Moreover, combinators are +-- provided to construct new bounded encodings from the provided ones. +-- +-- A typical example for using the combinators is a bounded 'Encoding' that +-- combines escaping the ' and \\ characters with UTF-8 encoding. More +-- precisely, the escaping to be done is the one implemented by the following +-- @escape@ function. +-- +-- > escape :: Char -> [Char] +-- > escape '\'' = "\\'" +-- > escape '\\' = "\\\\" +-- > escape c = [c] +-- +-- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is +-- the following. +-- +-- > import Data.ByteString.Builder.Prim.Utf8 (char) +-- > +-- > {-# INLINE escapeChar #-} +-- > escapeUtf8 :: BoundedPrim Char +-- > escapeUtf8 = +-- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ +-- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ +-- > char +-- +-- The definition of 'escapeUtf8' is more complicated than 'escape', because +-- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in +-- 'escapeChar' compute both the bound on the maximal number of bytes written +-- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required +-- to implement the encoding. Bounded 'Encoding's should always be inlined. +-- Otherwise, the compiler cannot compute the bound on the maximal number of +-- bytes written at compile-time. Without inlinining, it would also fail to +-- optimize the constant encoding of the escape characters in the above +-- example. Functions that execute bounded 'Encoding's also perform +-- suboptimally, if the definition of the bounded 'Encoding' is not inlined. +-- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. +-- +-- Currently, the only library that executes bounded 'Encoding's is the +-- 'bytestring' library (). It +-- uses bounded 'Encoding's to implement most of its lazy bytestring builders. +-- Executing a bounded encoding should be done using the corresponding +-- functions in the lazy bytestring builder 'Extras' module. +-- +-- TODO: Merge with explanation/example below +-- +-- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by +-- writing a bounded-size sequence of bytes directly to memory. They are +-- lifted to conversions from Haskell values to 'Builder's by wrapping them +-- with a bound-check. The compiler can implement this bound-check very +-- efficiently (i.e, a single comparison of the difference of two pointers to a +-- constant), because the bound of a 'E.Encoding' is always independent of the +-- value being encoded and, in most cases, a literal constant. +-- +-- 'E.Encoding's are the primary means for defining conversion functions from +-- primitive Haskell values to 'Builder's. Most 'Builder' constructors +-- provided by this library are implemented that way. +-- 'E.Encoding's are also used to construct conversions that exploit the internal +-- representation of data-structures. +-- +-- For example, 'encodeByteStringWith' works directly on the underlying byte +-- array and uses some tricks to reduce the number of variables in its inner +-- loop. Its efficiency is exploited for implementing the @filter@ and @map@ +-- functions in "Data.ByteString.Lazy" as +-- +-- > import qualified Codec.Bounded.Encoding as E +-- > +-- > filter :: (Word8 -> Bool) -> ByteString -> ByteString +-- > filter p = toLazyByteString . encodeLazyByteStringWithB write +-- > where +-- > write = E.encodeIf p E.word8 E.emptyEncoding +-- > +-- > map :: (Word8 -> Word8) -> ByteString -> ByteString +-- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) +-- +-- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, +-- these versions use a more efficient inner loop and have the additional +-- advantage that they always result in well-chunked 'L.ByteString's; i.e, they +-- also perform automatic defragmentation. +-- +-- We can also use 'E.Encoding's to improve the efficiency of the following +-- 'renderString' function from our UTF-8 CSV table encoding example in +-- "Data.ByteString.Builder". +-- +-- > renderString :: String -> Builder +-- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' +-- > where +-- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' +-- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' +-- > escape c = charUtf8 c +-- +-- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes +-- characters and using 'encodeListWith', which implements writing a list of +-- values with a tighter inner loop and no 'mappend'. +-- +-- > import Data.ByteString.Builder.Extra -- assume these +-- > import Data.ByteString.Builder.Prim -- imports are present +-- > ( BoundedPrim, encodeIf, (<#>), (#.) ) +-- > import Data.ByteString.Builder.Prim.Utf8 (char) +-- > +-- > renderString :: String -> Builder +-- > renderString cs = +-- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' +-- > where +-- > escapedUtf8 :: BoundedPrim Char +-- > escapedUtf8 = +-- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ +-- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ +-- > char +-- +-- This 'Builder' considers a buffer with less than 8 free bytes as full. As +-- all functions are inlined, the compiler is able to optimize the constant +-- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of +-- 'renderString' this implementation is 1.7x faster. +-- +-} +{- +Internally, 'Builder's are buffer-fill operations that are +given a continuation buffer-fill operation and a buffer-range to be filled. +A 'Builder' first checks if the buffer-range is large enough. If that's +the case, the 'Builder' writes the sequences of bytes to the buffer and +calls its continuation. Otherwise, it returns a signal that it requires a +new buffer together with a continuation to be called on this new buffer. +Ignoring the rare case of a full buffer-range, the execution cost of a +'Builder' consists of three parts: + + 1. The time taken to read the parameters; i.e., the buffer-fill + operation to call after the 'Builder' is done and the buffer-range to + fill. + + 2. The time taken to check for the size of the buffer-range. + + 3. The time taken for the actual encoding. + +We can reduce cost (1) by ensuring that fewer buffer-fill function calls are +required. We can reduce cost (2) by fusing buffer-size checks of sequential +writes. For example, when escaping a 'String' using 'renderString', it would +be sufficient to check before encoding a character that at least 8 bytes are +free. We can reduce cost (3) by implementing better primitive 'Builder's. +For example, 'renderCell' builds an intermediate list containing the decimal +representation of an 'Int'. Implementing a direct decimal encoding of 'Int's +to memory would be more efficient, as it requires fewer buffer-size checks +and less allocation. It is also a planned extension of this library. + +The first two cost reductions are supported for user code through functions +in "Data.ByteString.Builder.Extra". There, we continue the above example +and drop the generation time to 0.8ms by implementing 'renderString' more +cleverly. The third reduction requires meddling with the internals of +'Builder's and is not recommended in code outside of this library. However, +patches to this library are very welcome. +-} +module Data.ByteString.Builder.Prim ( + + -- * Bounded-size primitives + + BoundedPrim + + -- ** Combinators + -- | The combinators for 'BoundedPrim's are implemented such that the + -- size of the resulting 'BoundedPrim' can be computed at compile time. + , emptyB + , (>*<) + , (>$<) + , eitherB + , condB + + -- ** Builder construction + , primBounded + , primMapListBounded + , primUnfoldrBounded + + , primMapByteStringBounded + , primMapLazyByteStringBounded + + -- * Fixed-size primitives + , FixedPrim + + -- ** Combinators + -- | The combinators for 'FixedPrim's are implemented such that the 'size' + -- of the resulting 'FixedPrim' is computed at compile time. + -- + -- The '(>*<)' and '(>$<)' pairing and mapping operators can be used + -- with 'FixedPrim'. + , emptyF + , liftFixedToBounded + + -- ** Builder construction + -- | In terms of expressivity, the function 'fixedPrim' would be sufficient + -- for constructing 'Builder's from 'FixedPrim's. The fused variants of + -- this function are provided because they allow for more efficient + -- implementations. Our compilers are just not smart enough yet; and for some + -- of the employed optimizations (see the code of 'encodeByteStringWithF') + -- they will very likely never be. + -- + -- Note that functions marked with \"/Heavy inlining./\" are forced to be + -- inlined because they must be specialized for concrete encodings, + -- but are rather heavy in terms of code size. We recommend to define a + -- top-level function for every concrete instantiation of such a function in + -- order to share its code. A typical example is the function + -- 'byteStringHex' from "Data.ByteString.Builder.ASCII", which is + -- implemented as follows. + -- + -- @ + -- byteStringHex :: S.ByteString -> Builder + -- byteStringHex = 'encodeByteStringWithF' 'word8HexFixed' + -- @ + -- + , primFixed + , primMapListFixed + , primUnfoldrFixed + + , primMapByteStringFixed + , primMapLazyByteStringFixed + + -- * Standard encodings of Haskell values + + , module Data.ByteString.Builder.Prim.Binary + + -- ** Character encodings + , module Data.ByteString.Builder.Prim.ASCII + + -- *** ISO/IEC 8859-1 (Char8) + -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. + -- The /Char8/ encoding implemented here works by truncating the Unicode + -- codepoint to 8-bits and encoding them as a single byte. For the codepoints + -- 0-255 this corresponds to the ISO/IEC 8859-1 encoding. Note that the + -- Char8 encoding is equivalent to the ASCII encoding on the Unicode + -- codepoints 0-127. Hence, functions such as 'intDec' can also be used for + -- encoding 'Int's as a decimal number with Char8 encoded characters. + , char8 + + -- *** UTF-8 + -- | The UTF-8 encoding can encode all Unicode codepoints. + -- It is equivalent to the ASCII encoding on the Unicode codepoints 0-127. + -- Hence, functions such as 'intDec' can also be used for encoding 'Int's as + -- a decimal number with UTF-8 encoded characters. + , charUtf8 + +{- + -- * Testing support + -- | The following four functions are intended for testing use + -- only. They are /not/ efficient. Basic encodings are efficently executed by + -- creating 'Builder's from them using the @encodeXXX@ functions explained at + -- the top of this module. + + , evalF + , evalB + + , showF + , showB +-} + ) where + +import Data.ByteString.Builder.Internal +import Data.ByteString.Builder.Prim.Internal.UncheckedShifts + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + +import Data.Monoid +import Data.List (unfoldr) -- HADDOCK ONLY +import Data.Char (chr, ord) +import Control.Monad ((<=<), unless) + +import Data.ByteString.Builder.Prim.Internal hiding (size, sizeBound) +import qualified Data.ByteString.Builder.Prim.Internal as I (size, sizeBound) +import Data.ByteString.Builder.Prim.Binary +import Data.ByteString.Builder.Prim.ASCII + +#if MIN_VERSION_base(4,4,0) +#if MIN_VERSION_base(4,7,0) +import Foreign +#else +import Foreign hiding (unsafeForeignPtrToPtr) +#endif +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +#else +import Foreign +#endif + +------------------------------------------------------------------------------ +-- Creating Builders from bounded primitives +------------------------------------------------------------------------------ + +-- | Encode a value with a 'FixedPrim'. +{-# INLINE primFixed #-} +primFixed :: FixedPrim a -> (a -> Builder) +primFixed = primBounded . toB + +-- | Encode a list of values from left-to-right with a 'FixedPrim'. +{-# INLINE primMapListFixed #-} +primMapListFixed :: FixedPrim a -> ([a] -> Builder) +primMapListFixed = primMapListBounded . toB + +-- | Encode a list of values represented as an 'unfoldr' with a 'FixedPrim'. +{-# INLINE primUnfoldrFixed #-} +primUnfoldrFixed :: FixedPrim b -> (a -> Maybe (b, a)) -> a -> Builder +primUnfoldrFixed = primUnfoldrBounded . toB + +-- | /Heavy inlining./ Encode all bytes of a strict 'S.ByteString' from +-- left-to-right with a 'FixedPrim'. This function is quite versatile. For +-- example, we can use it to construct a 'Builder' that maps every byte before +-- copying it to the buffer to be filled. +-- +-- > mapToBuilder :: (Word8 -> Word8) -> S.ByteString -> Builder +-- > mapToBuilder f = encodeByteStringWithF (contramapF f word8) +-- +-- We can also use it to hex-encode a strict 'S.ByteString' as shown by the +-- 'byteStringHex' example above. +{-# INLINE primMapByteStringFixed #-} +primMapByteStringFixed :: FixedPrim Word8 -> (S.ByteString -> Builder) +primMapByteStringFixed = primMapByteStringBounded . toB + +-- | /Heavy inlining./ Encode all bytes of a lazy 'L.ByteString' from +-- left-to-right with a 'FixedPrim'. +{-# INLINE primMapLazyByteStringFixed #-} +primMapLazyByteStringFixed :: FixedPrim Word8 -> (L.ByteString -> Builder) +primMapLazyByteStringFixed = primMapLazyByteStringBounded . toB + +-- IMPLEMENTATION NOTE: Sadly, 'encodeListWith' cannot be used for foldr/build +-- fusion. Its performance relies on hoisting several variables out of the +-- inner loop. That's not possible when writing 'encodeListWith' as a 'foldr'. +-- If we had stream fusion for lists, then we could fuse 'encodeListWith', as +-- 'encodeWithStream' can keep control over the execution. + + +-- | Create a 'Builder' that encodes values with the given 'BoundedPrim'. +-- +-- We rewrite consecutive uses of 'primBounded' such that the bound-checks are +-- fused. For example, +-- +-- > primBounded (word32 c1) `mappend` primBounded (word32 c2) +-- +-- is rewritten such that the resulting 'Builder' checks only once, if ther are +-- at 8 free bytes, instead of checking twice, if there are 4 free bytes. This +-- optimization is not observationally equivalent in a strict sense, as it +-- influences the boundaries of the generated chunks. However, for a user of +-- this library it is observationally equivalent, as chunk boundaries of a lazy +-- 'L.ByteString' can only be observed through the internal interface. +-- Morevoer, we expect that all primitives write much fewer than 4kb (the +-- default short buffer size). Hence, it is safe to ignore the additional +-- memory spilled due to the more agressive buffer wrapping introduced by this +-- optimization. +-- +{-# INLINE[1] primBounded #-} +primBounded :: BoundedPrim a -> (a -> Builder) +primBounded w x = + -- It is important to avoid recursive 'BuildStep's where possible, as + -- their closure allocation is expensive. Using 'ensureFree' allows the + -- 'step' to assume that at least 'sizeBound w' free space is available. + ensureFree (I.sizeBound w) `mappend` builder step + where + step k (BufferRange op ope) = do + op' <- runB w x op + let !br' = BufferRange op' ope + k br' + +{-# RULES + +"append/primBounded" forall w1 w2 x1 x2. + append (primBounded w1 x1) (primBounded w2 x2) + = primBounded (pairB w1 w2) (x1, x2) + +"append/primBounded/assoc_r" forall w1 w2 x1 x2 b. + append (primBounded w1 x1) (append (primBounded w2 x2) b) + = append (primBounded (pairB w1 w2) (x1, x2)) b + +"append/primBounded/assoc_l" forall w1 w2 x1 x2 b. + append (append b (primBounded w1 x1)) (primBounded w2 x2) + = append b (primBounded (pairB w1 w2) (x1, x2)) + #-} + +-- TODO: The same rules for 'putBuilder (..) >> putBuilder (..)' + +-- | Create a 'Builder' that encodes a list of values consecutively using a +-- 'BoundedPrim' for each element. This function is more efficient than the +-- canonical +-- +-- > filter p = +-- > B.toLazyByteString . +-- > E.encodeLazyByteStringWithF (E.ifF p E.word8) E.emptyF) +-- > +-- +-- > mconcat . map (primBounded w) +-- +-- or +-- +-- > foldMap (primBounded w) +-- +-- because it moves several variables out of the inner loop. +{-# INLINE primMapListBounded #-} +primMapListBounded :: BoundedPrim a -> [a] -> Builder +primMapListBounded w xs0 = + builder $ step xs0 + where + step xs1 k (BufferRange op0 ope0) = + go xs1 op0 + where + go [] !op = k (BufferRange op ope0) + go xs@(x':xs') !op + | op `plusPtr` bound <= ope0 = runB w x' op >>= go xs' + | otherwise = + return $ bufferFull bound op (step xs k) + + bound = I.sizeBound w + +-- TODO: Add 'foldMap/encodeWith' its variants +-- TODO: Ensure rewriting 'primBounded w . f = primBounded (w #. f)' + +-- | Create a 'Builder' that encodes a sequence generated from a seed value +-- using a 'BoundedPrim' for each sequence element. +{-# INLINE primUnfoldrBounded #-} +primUnfoldrBounded :: BoundedPrim b -> (a -> Maybe (b, a)) -> a -> Builder +primUnfoldrBounded w f x0 = + builder $ fillWith x0 + where + fillWith x k !(BufferRange op0 ope0) = + go (f x) op0 + where + go !Nothing !op = do let !br' = BufferRange op ope0 + k br' + go !(Just (y, x')) !op + | op `plusPtr` bound <= ope0 = runB w y op >>= go (f x') + | otherwise = return $ bufferFull bound op $ + \(BufferRange opNew opeNew) -> do + !opNew' <- runB w y opNew + fillWith x' k (BufferRange opNew' opeNew) + bound = I.sizeBound w + +-- | Create a 'Builder' that encodes each 'Word8' of a strict 'S.ByteString' +-- using a 'BoundedPrim'. For example, we can write a 'Builder' that filters +-- a strict 'S.ByteString' as follows. +-- +-- > import Data.ByteString.Builder.Primas P (word8, condB, emptyB) +-- +-- > filterBS p = P.condB p P.word8 P.emptyB +-- +{-# INLINE primMapByteStringBounded #-} +primMapByteStringBounded :: BoundedPrim Word8 -> S.ByteString -> Builder +primMapByteStringBounded w = + \bs -> builder $ step bs + where + bound = I.sizeBound w + step (S.PS ifp ioff isize) !k = + goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) + where + !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) + goBS !ip0 !br@(BufferRange op0 ope) + | ip0 >= ipe = do + touchForeignPtr ifp -- input buffer consumed + k br + + | op0 `plusPtr` bound < ope = + goPartial (ip0 `plusPtr` min outRemaining inpRemaining) + + | otherwise = return $ bufferFull bound op0 (goBS ip0) + where + outRemaining = (ope `minusPtr` op0) `div` bound + inpRemaining = ipe `minusPtr` ip0 + + goPartial !ipeTmp = go ip0 op0 + where + go !ip !op + | ip < ipeTmp = do + x <- peek ip + op' <- runB w x op + go (ip `plusPtr` 1) op' + | otherwise = + goBS ip (BufferRange op ope) + +-- | Chunk-wise application of 'primMapByteStringBounded'. +{-# INLINE primMapLazyByteStringBounded #-} +primMapLazyByteStringBounded :: BoundedPrim Word8 -> L.ByteString -> Builder +primMapLazyByteStringBounded w = + L.foldrChunks (\x b -> primMapByteStringBounded w x `mappend` b) mempty + + +------------------------------------------------------------------------------ +-- Char8 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: FixedPrim Char +char8 = (fromIntegral . ord) >$< word8 + + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: BoundedPrim Char +charUtf8 = boudedPrim 4 (encodeCharUtf8 f1 f2 f3 f4) + where + pokeN n io op = io op >> return (op `plusPtr` n) + + f1 x1 = pokeN 1 $ \op -> do pokeByteOff op 0 x1 + + f2 x1 x2 = pokeN 2 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + + f3 x1 x2 x3 = pokeN 3 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + + f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + pokeByteOff op 3 x4 + +-- | Encode a Unicode character to another datatype, using UTF-8. This function +-- acts as an abstract way of encoding characters, as it is unaware of what +-- needs to happen with the resulting bytes: you have to specify functions to +-- deal with those. +-- +{-# INLINE encodeCharUtf8 #-} +encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8 + -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8 + -> Char -- ^ Input 'Char' + -> a -- ^ Result +encodeCharUtf8 f1 f2 f3 f4 c = case ord c of + x | x <= 0x7F -> f1 $ fromIntegral x + | x <= 0x07FF -> + let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f2 x1 x2 + | x <= 0xFFFF -> + let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f3 x1 x2 x3 + | otherwise -> + let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f4 x1 x2 x3 x4 + + diff --git a/src/Data/ByteString/Builder/Prim/ASCII.hs b/src/Data/ByteString/Builder/Prim/ASCII.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Prim/ASCII.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-} +-- | Copyright : (c) 2010 Jasper Van der Jeugt +-- (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Encodings using ASCII encoded Unicode characters. +-- +module Data.ByteString.Builder.Prim.ASCII + ( + + -- *** ASCII + char7 + + -- **** Decimal numbers + -- | Decimal encoding of numbers using ASCII encoded characters. + , int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + + {- + -- These are the functions currently provided by Bryan O'Sullivans + -- double-conversion library. + -- + -- , float + -- , floatWith + -- , double + -- , doubleWith + -} + + -- **** Hexadecimal numbers + + -- | Encoding positive integers as hexadecimal numbers using lower-case + -- ASCII characters. The shortest possible representation is used. For + -- example, + -- + -- > toLazyByteString (primBounded word16Hex 0x0a10) = "a10" + -- + -- Note that there is no support for using upper-case characters. Please + -- contact the maintainer if your application cannot work without + -- hexadecimal encodings that use upper-case characters. + -- + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + + -- **** Fixed-width hexadecimal numbers + -- + -- | Encoding the bytes of fixed-width types as hexadecimal + -- numbers using lower-case ASCII characters. For example, + -- + -- > toLazyByteString (primFixed word16HexFixed 0x0a10) = "0a10" + -- + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + , floatHexFixed + , doubleHexFixed + + ) where + +import Data.ByteString.Builder.Prim.Binary +import Data.ByteString.Builder.Prim.Internal +import Data.ByteString.Builder.Prim.Internal.Floating +import Data.ByteString.Builder.Prim.Internal.Base16 +import Data.ByteString.Builder.Prim.Internal.UncheckedShifts + +import Data.Char (ord) + +import Foreign +import Foreign.C.Types + +-- | Encode the least 7-bits of a 'Char' using the ASCII encoding. +{-# INLINE char7 #-} +char7 :: FixedPrim Char +char7 = (\c -> fromIntegral $ ord c .&. 0x7f) >$< word8 + + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +foreign import ccall unsafe "static _hs_bytestring_int_dec" c_int_dec + :: CInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec" c_long_long_int_dec + :: CLLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeIntDecimal #-} +encodeIntDecimal :: Integral a => Int -> BoundedPrim a +encodeIntDecimal bound = boudedPrim bound $ c_int_dec . fromIntegral + +-- | Decimal encoding of an 'Int8'. +{-# INLINE int8Dec #-} +int8Dec :: BoundedPrim Int8 +int8Dec = encodeIntDecimal 4 + +-- | Decimal encoding of an 'Int16'. +{-# INLINE int16Dec #-} +int16Dec :: BoundedPrim Int16 +int16Dec = encodeIntDecimal 6 + + +-- | Decimal encoding of an 'Int32'. +{-# INLINE int32Dec #-} +int32Dec :: BoundedPrim Int32 +int32Dec = encodeIntDecimal 11 + +-- | Decimal encoding of an 'Int64'. +{-# INLINE int64Dec #-} +int64Dec :: BoundedPrim Int64 +int64Dec = boudedPrim 20 $ c_long_long_int_dec . fromIntegral + +-- | Decimal encoding of an 'Int'. +{-# INLINE intDec #-} +intDec :: BoundedPrim Int +intDec = caseWordSize_32_64 + (fromIntegral >$< int32Dec) + (fromIntegral >$< int64Dec) + + +-- Unsigned integers +-------------------- + +foreign import ccall unsafe "static _hs_bytestring_uint_dec" c_uint_dec + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_dec" c_long_long_uint_dec + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeWordDecimal #-} +encodeWordDecimal :: Integral a => Int -> BoundedPrim a +encodeWordDecimal bound = boudedPrim bound $ c_uint_dec . fromIntegral + +-- | Decimal encoding of a 'Word8'. +{-# INLINE word8Dec #-} +word8Dec :: BoundedPrim Word8 +word8Dec = encodeWordDecimal 3 + +-- | Decimal encoding of a 'Word16'. +{-# INLINE word16Dec #-} +word16Dec :: BoundedPrim Word16 +word16Dec = encodeWordDecimal 5 + +-- | Decimal encoding of a 'Word32'. +{-# INLINE word32Dec #-} +word32Dec :: BoundedPrim Word32 +word32Dec = encodeWordDecimal 10 + +-- | Decimal encoding of a 'Word64'. +{-# INLINE word64Dec #-} +word64Dec :: BoundedPrim Word64 +word64Dec = boudedPrim 20 $ c_long_long_uint_dec . fromIntegral + +-- | Decimal encoding of a 'Word'. +{-# INLINE wordDec #-} +wordDec :: BoundedPrim Word +wordDec = caseWordSize_32_64 + (fromIntegral >$< word32Dec) + (fromIntegral >$< word64Dec) + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +foreign import ccall unsafe "static _hs_bytestring_uint_hex" c_uint_hex + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_hex" c_long_long_uint_hex + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeWordHex #-} +encodeWordHex :: forall a. (Storable a, Integral a) => BoundedPrim a +encodeWordHex = + boudedPrim (2 * sizeOf (undefined :: a)) $ c_uint_hex . fromIntegral + +-- | Hexadecimal encoding of a 'Word8'. +{-# INLINE word8Hex #-} +word8Hex :: BoundedPrim Word8 +word8Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word16'. +{-# INLINE word16Hex #-} +word16Hex :: BoundedPrim Word16 +word16Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word32'. +{-# INLINE word32Hex #-} +word32Hex :: BoundedPrim Word32 +word32Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word64'. +{-# INLINE word64Hex #-} +word64Hex :: BoundedPrim Word64 +word64Hex = boudedPrim 16 $ c_long_long_uint_hex . fromIntegral + +-- | Hexadecimal encoding of a 'Word'. +{-# INLINE wordHex #-} +wordHex :: BoundedPrim Word +wordHex = caseWordSize_32_64 + (fromIntegral >$< word32Hex) + (fromIntegral >$< word64Hex) + + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: FixedPrim Word8 +word8HexFixed = fixedPrim 2 $ + \x op -> poke (castPtr op) =<< encode8_as_16h lowerTable x + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: FixedPrim Word16 +word16HexFixed = + (\x -> (fromIntegral $ x `shiftr_w16` 8, fromIntegral x)) + >$< pairF word8HexFixed word8HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: FixedPrim Word32 +word32HexFixed = + (\x -> (fromIntegral $ x `shiftr_w32` 16, fromIntegral x)) + >$< pairF word16HexFixed word16HexFixed +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: FixedPrim Word64 +word64HexFixed = + (\x -> (fromIntegral $ x `shiftr_w64` 32, fromIntegral x)) + >$< pairF word32HexFixed word32HexFixed + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: FixedPrim Int8 +int8HexFixed = fromIntegral >$< word8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: FixedPrim Int16 +int16HexFixed = fromIntegral >$< word16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: FixedPrim Int32 +int32HexFixed = fromIntegral >$< word32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: FixedPrim Int64 +int64HexFixed = fromIntegral >$< word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: FixedPrim Float +floatHexFixed = encodeFloatViaWord32F word32HexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: FixedPrim Double +doubleHexFixed = encodeDoubleViaWord64F word64HexFixed + + diff --git a/src/Data/ByteString/Builder/Prim/Binary.hs b/src/Data/ByteString/Builder/Prim/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Prim/Binary.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE CPP, BangPatterns #-} +-- | Copyright : (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +module Data.ByteString.Builder.Prim.Binary ( + + -- ** Binary encodings + int8 + , word8 + + -- *** Big-endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- *** Little-endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- *** Non-portable, host-dependent + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + ) where + +import Data.ByteString.Builder.Prim.Internal +import Data.ByteString.Builder.Prim.Internal.UncheckedShifts +import Data.ByteString.Builder.Prim.Internal.Floating + +import Foreign + +#include "MachDeps.h" + +------------------------------------------------------------------------------ +-- Binary encoding +------------------------------------------------------------------------------ + +-- Word encodings +----------------- + +-- | Encoding single unsigned bytes as-is. +-- +{-# INLINE word8 #-} +word8 :: FixedPrim Word8 +word8 = storableToF + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Encoding 'Word16's in big endian format. +{-# INLINE word16BE #-} +word16BE :: FixedPrim Word16 +#ifdef WORD_BIGENDIAN +word16BE = word16Host +#else +word16BE = fixedPrim 2 $ \w p -> do + poke p (fromIntegral (shiftr_w16 w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) +#endif + +-- | Encoding 'Word16's in little endian format. +{-# INLINE word16LE #-} +word16LE :: FixedPrim Word16 +#ifdef WORD_BIGENDIAN +word16LE = fixedPrim 2 $ \w p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) +#else +word16LE = word16Host +#endif + +-- | Encoding 'Word32's in big endian format. +{-# INLINE word32BE #-} +word32BE :: FixedPrim Word32 +#ifdef WORD_BIGENDIAN +word32BE = word32Host +#else +word32BE = fixedPrim 4 $ \w 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) +#endif + +-- | Encoding 'Word32's in little endian format. +{-# INLINE word32LE #-} +word32LE :: FixedPrim Word32 +#ifdef WORD_BIGENDIAN +word32LE = fixedPrim 4 $ \w 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) +#else +word32LE = word32Host +#endif + +-- on a little endian machine: +-- word32LE w32 = fixedPrim 4 (\w p -> poke (castPtr p) w32) + +-- | Encoding 'Word64's in big endian format. +{-# INLINE word64BE #-} +word64BE :: FixedPrim Word64 +#ifdef WORD_BIGENDIAN +word64BE = word64Host +#else +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +word64BE = + fixedPrim 8 $ \w p -> do + let a = fromIntegral (shiftr_w64 w 32) :: Word32 + b = fromIntegral w :: Word32 + 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 +word64BE = fixedPrim 8 $ \w 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 +#endif + +-- | Encoding 'Word64's in little endian format. +{-# INLINE word64LE #-} +word64LE :: FixedPrim Word64 +#ifdef WORD_BIGENDIAN +#if WORD_SIZE_IN_BITS < 64 +word64LE = + fixedPrim 8 $ \w p -> do + let b = fromIntegral (shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + 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 +word64LE = fixedPrim 8 $ \w 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 +#else +word64LE = word64Host +#endif + + +-- | Encode a single native machine 'Word'. The 'Word's is encoded in host order, +-- host endian form, for the machine you are on. On a 64 bit machine the 'Word' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +{-# INLINE wordHost #-} +wordHost :: FixedPrim Word +wordHost = storableToF + +-- | Encoding 'Word16's in native host order and host endianness. +{-# INLINE word16Host #-} +word16Host :: FixedPrim Word16 +word16Host = storableToF + +-- | Encoding 'Word32's in native host order and host endianness. +{-# INLINE word32Host #-} +word32Host :: FixedPrim Word32 +word32Host = storableToF + +-- | Encoding 'Word64's in native host order and host endianness. +{-# INLINE word64Host #-} +word64Host :: FixedPrim Word64 +word64Host = storableToF + + +------------------------------------------------------------------------------ +-- Int encodings +------------------------------------------------------------------------------ +-- +-- We rely on 'fromIntegral' to do a loss-less conversion to the corresponding +-- 'Word' type +-- +------------------------------------------------------------------------------ + +-- | Encoding single signed bytes as-is. +-- +{-# INLINE int8 #-} +int8 :: FixedPrim Int8 +int8 = fromIntegral >$< word8 + +-- | Encoding 'Int16's in big endian format. +{-# INLINE int16BE #-} +int16BE :: FixedPrim Int16 +int16BE = fromIntegral >$< word16BE + +-- | Encoding 'Int16's in little endian format. +{-# INLINE int16LE #-} +int16LE :: FixedPrim Int16 +int16LE = fromIntegral >$< word16LE + +-- | Encoding 'Int32's in big endian format. +{-# INLINE int32BE #-} +int32BE :: FixedPrim Int32 +int32BE = fromIntegral >$< word32BE + +-- | Encoding 'Int32's in little endian format. +{-# INLINE int32LE #-} +int32LE :: FixedPrim Int32 +int32LE = fromIntegral >$< word32LE + +-- | Encoding 'Int64's in big endian format. +{-# INLINE int64BE #-} +int64BE :: FixedPrim Int64 +int64BE = fromIntegral >$< word64BE + +-- | Encoding 'Int64's in little endian format. +{-# INLINE int64LE #-} +int64LE :: FixedPrim Int64 +int64LE = fromIntegral >$< word64LE + + +-- TODO: Ensure that they are safe on architectures where an unaligned write is +-- an error. + +-- | Encode a single native machine 'Int'. The 'Int's is encoded in host order, +-- host endian form, for the machine you are on. On a 64 bit machine the 'Int' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or integer sized machines, without +-- conversion. +-- +{-# INLINE intHost #-} +intHost :: FixedPrim Int +intHost = storableToF + +-- | Encoding 'Int16's in native host order and host endianness. +{-# INLINE int16Host #-} +int16Host :: FixedPrim Int16 +int16Host = storableToF + +-- | Encoding 'Int32's in native host order and host endianness. +{-# INLINE int32Host #-} +int32Host :: FixedPrim Int32 +int32Host = storableToF + +-- | Encoding 'Int64's in native host order and host endianness. +{-# INLINE int64Host #-} +int64Host :: FixedPrim Int64 +int64Host = storableToF + +-- IEEE Floating Point Numbers +------------------------------ + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: FixedPrim Float +floatBE = encodeFloatViaWord32F word32BE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: FixedPrim Float +floatLE = encodeFloatViaWord32F word32LE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: FixedPrim Double +doubleBE = encodeDoubleViaWord64F word64BE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: FixedPrim Double +doubleLE = encodeDoubleViaWord64F word64LE + + +-- | Encode a 'Float' in native host order and host endianness. Values written +-- this way are not portable to different endian machines, without conversion. +-- +{-# INLINE floatHost #-} +floatHost :: FixedPrim Float +floatHost = storableToF + +-- | Encode a 'Double' in native host order and host endianness. +{-# INLINE doubleHost #-} +doubleHost :: FixedPrim Double +doubleHost = storableToF + + diff --git a/src/Data/ByteString/Builder/Prim/Internal.hs b/src/Data/ByteString/Builder/Prim/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Prim/Internal.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-} +#if __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Unsafe #-} +#endif +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : unstable, private +-- Portability : GHC +-- +-- *Warning:* this module is internal. If you find that you need it please +-- contact the maintainers and explain what you are trying to do and discuss +-- what you would need in the public API. It is important that you do this as +-- the module may not be exposed at all in future releases. +-- +-- The maintainers are glad to accept patches for further +-- standard encodings of standard Haskell values. +-- +-- If you need to write your own builder primitives, then be aware that you are +-- writing code with /all saftey belts off/; i.e., +-- *this is the code that might make your application vulnerable to buffer-overflow attacks!* +-- The "Data.ByteString.Builder.Prim.Tests" module provides you with +-- utilities for testing your encodings thoroughly. +-- +module Data.ByteString.Builder.Prim.Internal ( + -- * Fixed-size builder primitives + Size + , FixedPrim + , fixedPrim + , size + , runF + + , emptyF + , contramapF + , pairF + -- , liftIOF + + , storableToF + + -- * Bounded-size builder primitives + , BoundedPrim + , boudedPrim + , sizeBound + , runB + + , emptyB + , contramapB + , pairB + , eitherB + , condB + + -- , liftIOB + + , toB + , liftFixedToBounded + + -- , withSizeFB + -- , withSizeBB + + -- * Shared operators + , (>$<) + , (>*<) + + ) where + +import Foreign +import Prelude hiding (maxBound) + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611 +-- ghc-6.10 and older do not support {-# INLINE CONLIKE #-} +#define CONLIKE +#endif + +------------------------------------------------------------------------------ +-- Supporting infrastructure +------------------------------------------------------------------------------ + +-- | Contravariant functors as in the @contravariant@ package. +class Contravariant f where + contramap :: (b -> a) -> f a -> f b + +infixl 4 >$< + +-- | A fmap-like operator for builder primitives, both bounded and fixed size. +-- +-- Builder primitives are contravariant so it's like the normal fmap, but +-- backwards (look at the type). (If it helps to remember, the operator symbol +-- is like (<$>) but backwards.) +-- +-- We can use it for example to prepend and/or append fixed values to an +-- primitive. +-- +-- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'" +-- > where +-- > fixed3 = char7 >*< char7 >*< char7 +-- +-- Note that the rather verbose syntax for composition stems from the +-- requirement to be able to compute the size / size bound at compile time. +-- +(>$<) :: Contravariant f => (b -> a) -> f a -> f b +(>$<) = contramap + + +instance Contravariant FixedPrim where + contramap = contramapF + +instance Contravariant BoundedPrim where + contramap = contramapB + + +-- | Type-constructors supporting lifting of type-products. +class Monoidal f where + pair :: f a -> f b -> f (a, b) + +instance Monoidal FixedPrim where + pair = pairF + +instance Monoidal BoundedPrim where + pair = pairB + +infixr 5 >*< + +-- | A pairing/concatenation operator for builder primitives, both bounded and +-- fixed size. +-- +-- For example, +-- +-- > toLazyByteString (primFixed (char7 >*< char7) ('x','y')) = "xy" +-- +-- We can combine multiple primitives using '>*<' multiple times. +-- +-- > toLazyByteString (primFixed (char7 >*< char7 >*< char7) ('x',('y','z'))) = "xyz" +-- +(>*<) :: Monoidal f => f a -> f b -> f (a, b) +(>*<) = pair + + +-- | The type used for sizes and sizeBounds of sizes. +type Size = Int + + +------------------------------------------------------------------------------ +-- Fixed-size builder primitives +------------------------------------------------------------------------------ + +-- | A builder primitive that always results in a sequence of bytes of a +-- pre-determined, fixed size. +data FixedPrim a = FP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ()) + +fixedPrim :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a +fixedPrim = FP + +-- | The size of the sequences of bytes generated by this 'FixedPrim'. +{-# INLINE CONLIKE size #-} +size :: FixedPrim a -> Int +size (FP l _) = l + +{-# INLINE CONLIKE runF #-} +runF :: FixedPrim a -> a -> Ptr Word8 -> IO () +runF (FP _ io) = io + +-- | The 'FixedPrim' that always results in the zero-length sequence. +{-# INLINE CONLIKE emptyF #-} +emptyF :: FixedPrim a +emptyF = FP 0 (\_ _ -> return ()) + +-- | Encode a pair by encoding its first component and then its second component. +{-# INLINE CONLIKE pairF #-} +pairF :: FixedPrim a -> FixedPrim b -> FixedPrim (a, b) +pairF (FP l1 io1) (FP l2 io2) = + FP (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1)) + +-- | Change a primitives such that it first applies a function to the value +-- to be encoded. +-- +-- Note that primitives are 'Contrafunctors' +-- . Hence, the following +-- laws hold. +-- +-- >contramapF id = id +-- >contramapF f . contramapF g = contramapF (g . f) +{-# INLINE CONLIKE contramapF #-} +contramapF :: (b -> a) -> FixedPrim a -> FixedPrim b +contramapF f (FP l io) = FP l (\x op -> io (f x) op) + +-- | Convert a 'FixedPrim' to a 'BoundedPrim'. +{-# INLINE CONLIKE toB #-} +toB :: FixedPrim a -> BoundedPrim a +toB (FP l io) = BP l (\x op -> io x op >> (return $! op `plusPtr` l)) + +-- | Lift a 'FixedPrim' to a 'BoundedPrim'. +{-# INLINE CONLIKE liftFixedToBounded #-} +liftFixedToBounded :: FixedPrim a -> BoundedPrim a +liftFixedToBounded = toB + +{-# INLINE CONLIKE storableToF #-} +storableToF :: forall a. Storable a => FixedPrim a +storableToF = FP (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x) + +{- +{-# INLINE CONLIKE liftIOF #-} +liftIOF :: FixedPrim a -> FixedPrim (IO a) +liftIOF (FP l io) = FP l (\xWrapped op -> do x <- xWrapped; io x op) +-} + +------------------------------------------------------------------------------ +-- Bounded-size builder primitives +------------------------------------------------------------------------------ + +-- | A builder primitive that always results in sequence of bytes that is no longer +-- than a pre-determined bound. +data BoundedPrim a = BP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8)) + +-- | The bound on the size of sequences of bytes generated by this 'BoundedPrim'. +{-# INLINE CONLIKE sizeBound #-} +sizeBound :: BoundedPrim a -> Int +sizeBound (BP b _) = b + +boudedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a +boudedPrim = BP + +{-# INLINE CONLIKE runB #-} +runB :: BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8) +runB (BP _ io) = io + +-- | Change a 'BoundedPrim' such that it first applies a function to the +-- value to be encoded. +-- +-- Note that 'BoundedPrim's are 'Contrafunctors' +-- . Hence, the following +-- laws hold. +-- +-- >contramapB id = id +-- >contramapB f . contramapB g = contramapB (g . f) +{-# INLINE CONLIKE contramapB #-} +contramapB :: (b -> a) -> BoundedPrim a -> BoundedPrim b +contramapB f (BP b io) = BP b (\x op -> io (f x) op) + +-- | The 'BoundedPrim' that always results in the zero-length sequence. +{-# INLINE CONLIKE emptyB #-} +emptyB :: BoundedPrim a +emptyB = BP 0 (\_ op -> return op) + +-- | Encode a pair by encoding its first component and then its second component. +{-# INLINE CONLIKE pairB #-} +pairB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b) +pairB (BP b1 io1) (BP b2 io2) = + BP (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2) + +-- | Encode an 'Either' value using the first 'BoundedPrim' for 'Left' +-- values and the second 'BoundedPrim' for 'Right' values. +-- +-- Note that the functions 'eitherB', 'pairB', and 'contramapB' (written below +-- using '>$<') suffice to construct 'BoundedPrim's for all non-recursive +-- algebraic datatypes. For example, +-- +-- @ +--maybeB :: BoundedPrim () -> BoundedPrim a -> BoundedPrim (Maybe a) +--maybeB nothing just = 'maybe' (Left ()) Right '>$<' eitherB nothing just +-- @ +{-# INLINE CONLIKE eitherB #-} +eitherB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (Either a b) +eitherB (BP b1 io1) (BP b2 io2) = + BP (max b1 b2) + (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 op) + +-- | Conditionally select a 'BoundedPrim'. +-- For example, we can implement the ASCII primitive that drops characters with +-- Unicode codepoints above 127 as follows. +-- +-- @ +--charASCIIDrop = 'condB' (< '\128') ('fromF' 'char7') 'emptyB' +-- @ +{-# INLINE CONLIKE condB #-} +condB :: (a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a +condB p be1 be2 = + contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2) diff --git a/src/Data/ByteString/Builder/Prim/Internal/Base16.hs b/src/Data/ByteString/Builder/Prim/Internal/Base16.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Prim/Internal/Base16.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Hexadecimal encoding of nibbles (4-bit) and octets (8-bit) as ASCII +-- characters. +-- +-- The current implementation is based on a table based encoding inspired by +-- the code in the 'base64-bytestring' library by Bryan O'Sullivan. In our +-- benchmarks on a 32-bit machine it turned out to be the fastest +-- implementation option. +-- +module Data.ByteString.Builder.Prim.Internal.Base16 ( + EncodingTable + , lowerTable + , encode8_as_16h + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S + +#if MIN_VERSION_base(4,4,0) +#if MIN_VERSION_base(4,7,0) +import Foreign +#else +import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) +#endif +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafePerformIO) +#else +import Foreign +#endif + +-- Creating the encoding table +------------------------------ + +-- TODO: Use table from C implementation. + +-- | An encoding table for Base16 encoding. +newtype EncodingTable = EncodingTable (ForeignPtr Word8) + +tableFromList :: [Word8] -> EncodingTable +tableFromList xs = case S.pack xs of S.PS fp _ _ -> EncodingTable fp + +unsafeIndex :: EncodingTable -> Int -> IO Word8 +unsafeIndex (EncodingTable table) = peekElemOff (unsafeForeignPtrToPtr table) + +base16EncodingTable :: EncodingTable -> IO EncodingTable +base16EncodingTable alphabet = do + xs <- sequence $ concat $ [ [ix j, ix k] | j <- [0..15], k <- [0..15] ] + return $ tableFromList xs + where + ix = unsafeIndex alphabet + +{-# NOINLINE lowerAlphabet #-} +lowerAlphabet :: EncodingTable +lowerAlphabet = + tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['a'..'f'] + +-- | The encoding table for hexadecimal values with lower-case characters; +-- e.g., deadbeef. +{-# NOINLINE lowerTable #-} +lowerTable :: EncodingTable +lowerTable = unsafePerformIO $ base16EncodingTable lowerAlphabet + +-- | Encode an octet as 16bit word comprising both encoded nibbles ordered +-- according to the host endianness. Writing these 16bit to memory will write +-- the nibbles in the correct order (i.e. big-endian). +{-# INLINE encode8_as_16h #-} +encode8_as_16h :: EncodingTable -> Word8 -> IO Word16 +encode8_as_16h (EncodingTable table) = + peekElemOff (castPtr $ unsafeForeignPtrToPtr table) . fromIntegral diff --git a/src/Data/ByteString/Builder/Prim/Internal/Floating.hs b/src/Data/ByteString/Builder/Prim/Internal/Floating.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Prim/Internal/Floating.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Copyright : (c) 2010 Simon Meier +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Conversion of 'Float's and 'Double's to 'Word32's and 'Word64's. +-- +module Data.ByteString.Builder.Prim.Internal.Floating + ( + -- coerceFloatToWord32 + -- , coerceDoubleToWord64 + encodeFloatViaWord32F + , encodeDoubleViaWord64F + ) where + +import Foreign +import Data.ByteString.Builder.Prim.Internal + +{- +We work around ticket http://hackage.haskell.org/trac/ghc/ticket/4092 using the +FFI to store the Float/Double in the buffer and peek it out again from there. +-} + + +-- | Encode a 'Float' using a 'Word32' encoding. +-- +-- PRE: The 'Word32' encoding must have a size of at least 4 bytes. +{-# INLINE encodeFloatViaWord32F #-} +encodeFloatViaWord32F :: FixedPrim Word32 -> FixedPrim Float +encodeFloatViaWord32F w32fe + | size w32fe < sizeOf (undefined :: Float) = + error $ "encodeFloatViaWord32F: encoding not wide enough" + | otherwise = fixedPrim (size w32fe) $ \x op -> do + poke (castPtr op) x + x' <- peek (castPtr op) + runF w32fe x' op + +-- | Encode a 'Double' using a 'Word64' encoding. +-- +-- PRE: The 'Word64' encoding must have a size of at least 8 bytes. +{-# INLINE encodeDoubleViaWord64F #-} +encodeDoubleViaWord64F :: FixedPrim Word64 -> FixedPrim Double +encodeDoubleViaWord64F w64fe + | size w64fe < sizeOf (undefined :: Float) = + error $ "encodeDoubleViaWord64F: encoding not wide enough" + | otherwise = fixedPrim (size w64fe) $ \x op -> do + poke (castPtr op) x + x' <- peek (castPtr op) + runF w64fe x' op + diff --git a/src/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs b/src/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP, MagicHash #-} +-- | +-- Copyright : (c) 2010 Simon Meier +-- +-- Original serialization code from 'Data.Binary.Builder': +-- (c) Lennart Kolmodin, Ross Patterson +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Utilty module defining unchecked shifts. +-- +-- These functions are undefined when the amount being shifted by is +-- greater than the size in bits of a machine Int#.- +-- +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.ByteString.Builder.Prim.Internal.UncheckedShifts ( + shiftr_w16 + , shiftr_w32 + , shiftr_w64 + , shiftr_w + + , caseWordSize_32_64 + ) where + + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 +import GHC.Word (uncheckedShiftRL64#) +#endif +#else +import Data.Word +#endif + +import Foreign + + +------------------------------------------------------------------------ +-- Unchecked shifts + +-- | Right-shift of a 'Word16'. +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 + +-- | Right-shift of a 'Word32'. +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 + +-- | Right-shift of a 'Word64'. +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +-- | Right-shift of a 'Word'. +{-# INLINE shiftr_w #-} +shiftr_w :: Word -> Int -> Word +#if WORD_SIZE_IN_BITS < 64 +shiftr_w w s = fromIntegral $ (`shiftr_w32` s) $ fromIntegral w +#else +shiftr_w w s = fromIntegral $ (`shiftr_w64` s) $ fromIntegral w +#endif + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif + + +-- | Select an implementation depending on the bit-size of 'Word's. +-- Currently, it produces a runtime failure if the bitsize is different. +-- This is detected by the testsuite. +{-# INLINE caseWordSize_32_64 #-} +caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's + -> a -- Value to use for 64-bit 'Word's + -> a +caseWordSize_32_64 f32 f64 = +#if MIN_VERSION_base(4,7,0) + case finiteBitSize (undefined :: Word) of +#else + case bitSize (undefined :: Word) of +#endif + 32 -> f32 + 64 -> f64 + s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s + + diff --git a/src/Data/ByteString/Short.hs b/src/Data/ByteString/Short.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | +-- Module : Data.ByteString.Short +-- Copyright : (c) Duncan Coutts 2012-2013 +-- License : BSD-style +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : stable +-- Portability : ghc only +-- +-- A compact representation suitable for storing short byte strings in memory. +-- +-- In typical use cases it can be imported alongside "Data.ByteString", e.g. +-- +-- > import qualified Data.ByteString as B +-- > import qualified Data.ByteString.Short as B +-- > (ShortByteString, toShort, fromShort) +-- +-- Other 'ShortByteString' operations clash with "Data.ByteString" or "Prelude" +-- functions however, so they should be imported @qualified@ with a different +-- alias e.g. +-- +-- > import qualified Data.ByteString.Short as B.Short +-- +module Data.ByteString.Short ( + + -- * The @ShortByteString@ type + + ShortByteString, + + -- ** Memory overhead + -- | With GHC, the memory overheads are as follows, expressed in words and + -- in bytes (words are 4 and 8 bytes on 32 or 64bit machines respectively). + -- + -- * 'ByteString' unshared: 9 words; 36 or 72 bytes. + -- + -- * 'ByteString' shared substring: 5 words; 20 or 40 bytes. + -- + -- * 'ShortByteString': 4 words; 16 or 32 bytes. + -- + -- For the string data itself, both 'ShortByteString' and 'ByteString' use + -- one byte per element, rounded up to the nearest word. For example, + -- including the overheads, a length 10 'ShortByteString' would take + -- @16 + 12 = 28@ bytes on a 32bit platform and @32 + 16 = 48@ bytes on a + -- 64bit platform. + -- + -- These overheads can all be reduced by 1 word (4 or 8 bytes) when the + -- 'ShortByteString' or 'ByteString' is unpacked into another constructor. + -- + -- For example: + -- + -- > data ThingId = ThingId {-# UNPACK #-} !Int + -- > {-# UNPACK #-} !ShortByteString + -- + -- This will take @1 + 1 + 3@ words (the @ThingId@ constructor + + -- unpacked @Int@ + unpacked @ShortByteString@), plus the words for the + -- string data. + + -- ** Heap fragmentation + -- | With GHC, the 'ByteString' representation uses /pinned/ memory, + -- meaning it cannot be moved by the GC. This is usually the right thing to + -- do for larger strings, but for small strings using pinned memory can + -- lead to heap fragmentation which wastes space. The 'ShortByteString' + -- type (and the @Text@ type from the @text@ package) use /unpinned/ memory + -- so they do not contribute to heap fragmentation. In addition, with GHC, + -- small unpinned strings are allocated in the same way as normal heap + -- allocations, rather than in a separate pinned area. + + -- * Conversions + toShort, + fromShort, + pack, + unpack, + + -- * Other operations + empty, null, length, index, + ) where + +import Data.ByteString.Short.Internal +import Prelude () + diff --git a/src/Data/ByteString/Short/Internal.hs b/src/Data/ByteString/Short/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short/Internal.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE DeriveDataTypeable, CPP, BangPatterns, RankNTypes, + ForeignFunctionInterface, MagicHash, UnboxedTuples, + UnliftedFFITypes #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#if __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Unsafe #-} +#endif +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Module : Data.ByteString.Short.Internal +-- Copyright : (c) Duncan Coutts 2012-2013 +-- License : BSD-style +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : stable +-- Portability : ghc only +-- +-- Internal representation of ShortByteString +-- +module Data.ByteString.Short.Internal ( + + -- * The @ShortByteString@ type and representation + ShortByteString(..), + + -- * Conversions + toShort, + fromShort, + pack, + unpack, + + -- * Other operations + empty, null, length, index, unsafeIndex, + + -- * Low level operations + createFromPtr, copyToPtr + ) where + +import Data.ByteString.Internal (ByteString(..), inlinePerformIO) + +import Data.Typeable (Typeable) +import Data.Data (Data(..), mkNoRepType) +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) +import Control.DeepSeq (NFData(..)) +import qualified Data.List as List (length) +#if MIN_VERSION_base(4,7,0) +import Foreign.C.Types (CSize(..), CInt(..)) +#elif MIN_VERSION_base(4,4,0) +import Foreign.C.Types (CSize(..), CInt(..), CLong(..)) +#else +import Foreign.C.Types (CSize, CInt, CLong) +#endif +import Foreign.Ptr +import Foreign.ForeignPtr (touchForeignPtr) +#if MIN_VERSION_base(4,5,0) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +#else +import Foreign.ForeignPtr (unsafeForeignPtrToPtr) +#endif + +#if MIN_VERSION_base(4,5,0) +import qualified GHC.Exts +#endif +import GHC.Exts ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#) + , State#, RealWorld + , ByteArray#, MutableByteArray# + , newByteArray# +#if MIN_VERSION_base(4,6,0) + , newPinnedByteArray# + , byteArrayContents# + , unsafeCoerce# +#endif +#if MIN_VERSION_base(4,3,0) + , sizeofByteArray# +#endif + , indexWord8Array#, indexCharArray# + , writeWord8Array#, writeCharArray# + , unsafeFreezeByteArray# ) +import GHC.IO +#if MIN_VERSION_base(4,6,0) +import GHC.ForeignPtr (ForeignPtr(ForeignPtr), ForeignPtrContents(PlainPtr)) +#else +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +#endif +import GHC.ST (ST(ST), runST) +import GHC.Word + +import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..) + , ($), error, (++) + , Bool(..), (&&), otherwise + , (+), (-), fromIntegral + , return ) + + +-- | A compact representation of a 'Word8' vector. +-- +-- It has a lower memory overhead than a 'ByteString' and and does not +-- contribute to heap fragmentation. It can be converted to or from a +-- 'ByteString' (at the cost of copying the string data). It supports very few +-- other operations. +-- +-- It is suitable for use as an internal representation for code that needs +-- to keep many short strings in memory, but it /should not/ be used as an +-- interchange type. That is, it should not generally be used in public APIs. +-- The 'ByteString' type is usually more suitable for use in interfaces; it is +-- more flexible and it supports a wide range of operations. +-- +data ShortByteString = SBS ByteArray# +#if !(MIN_VERSION_base(4,3,0)) + Int -- ^ Prior to ghc-7.0.x, 'ByteArray#'s reported + -- their length rounded up to the nearest word. + -- This means we have to store the true length + -- separately, wasting a word. +#define LEN(x) (x) +#else +#define _len /* empty */ +#define LEN(x) /* empty */ +#endif + deriving Typeable + +-- The ByteArray# representation is always word sized and aligned but with a +-- known byte length. Our representation choice for ShortByteString is to leave +-- the 0--3 trailing bytes undefined. This means we can use word-sized writes, +-- but we have to be careful with reads, see equateBytes and compareBytes below. + + +instance Eq ShortByteString where + (==) = equateBytes + +instance Ord ShortByteString where + compare = compareBytes + +instance Monoid ShortByteString where + mempty = empty + mappend = append + mconcat = concat + +instance NFData ShortByteString + +instance Show ShortByteString where + showsPrec p ps r = showsPrec p (unpackChars ps) r + +instance Read ShortByteString where + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] + +instance IsString ShortByteString where + fromString = packChars + +instance Data ShortByteString where + gfoldl f z txt = z packBytes `f` (unpackBytes txt) + toConstr _ = error "Data.ByteString.Short.ShortByteString.toConstr" + gunfold _ _ = error "Data.ByteString.Short.ShortByteString.gunfold" +#if MIN_VERSION_base(4,2,0) + dataTypeOf _ = mkNoRepType "Data.ByteString.Short.ShortByteString" +#else + dataTypeOf _ = mkNorepType "Data.ByteString.Short.ShortByteString" +#endif + +------------------------------------------------------------------------ +-- Simple operations + +-- | /O(1)/. The empty 'ShortByteString'. +empty :: ShortByteString +empty = create 0 (\_ -> return ()) + +-- | /O(1)/ The length of a 'ShortByteString'. +length :: ShortByteString -> Int +#if MIN_VERSION_base(4,3,0) +length (SBS barr#) = I# (sizeofByteArray# barr#) +#else +length (SBS _ len) = len +#endif + +-- | /O(1)/ Test whether a 'ShortByteString' is empty. +null :: ShortByteString -> Bool +null sbs = length sbs == 0 + +-- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. +index :: ShortByteString -> Int -> Word8 +index sbs i + | i >= 0 && i < length sbs = unsafeIndex sbs i + | otherwise = indexError sbs i + +unsafeIndex :: ShortByteString -> Int -> Word8 +unsafeIndex sbs = indexWord8Array (asBA sbs) + +indexError :: ShortByteString -> Int -> a +indexError sbs i = + error $ "Data.ByteString.Short.index: error in array index; " ++ show i + ++ " not in range [0.." ++ show (length sbs) ++ ")" + + +------------------------------------------------------------------------ +-- Internal utils + +asBA :: ShortByteString -> BA +asBA (SBS ba# _len) = BA# ba# + +create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString +create len fill = + runST (do + mba <- newByteArray len + fill mba + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba# LEN(len))) +{-# INLINE create #-} + +------------------------------------------------------------------------ +-- Conversion to and from ByteString + +-- | /O(n)/. Convert a 'ByteString' into a 'ShortByteString'. +-- +-- This makes a copy, so does not retain the input string. +-- +toShort :: ByteString -> ShortByteString +toShort !bs = unsafeDupablePerformIO (toShortIO bs) + +toShortIO :: ByteString -> IO ShortByteString +toShortIO (PS fptr off len) = do + mba <- stToIO (newByteArray len) + let ptr = unsafeForeignPtrToPtr fptr + stToIO (copyAddrToByteArray (ptr `plusPtr` off) mba 0 len) + touchForeignPtr fptr + BA# ba# <- stToIO (unsafeFreezeByteArray mba) + return (SBS ba# LEN(len)) + + +-- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'. +-- +fromShort :: ShortByteString -> ByteString +fromShort !sbs = unsafeDupablePerformIO (fromShortIO sbs) + +fromShortIO :: ShortByteString -> IO ByteString +fromShortIO sbs = do +#if MIN_VERSION_base(4,6,0) + let len = length sbs + mba@(MBA# mba#) <- stToIO (newPinnedByteArray len) + stToIO (copyByteArray (asBA sbs) 0 mba 0 len) + let fp = ForeignPtr (byteArrayContents# (unsafeCoerce# mba#)) + (PlainPtr mba#) + return (PS fp 0 len) +#else + -- Before base 4.6 ForeignPtrContents is not exported from GHC.ForeignPtr + -- so we cannot get direct access to the mbarr# + let len = length sbs + fptr <- mallocPlainForeignPtrBytes len + let ptr = unsafeForeignPtrToPtr fptr + stToIO (copyByteArrayToAddr (asBA sbs) 0 ptr len) + touchForeignPtr fptr + return (PS fptr 0 len) +#endif + + +------------------------------------------------------------------------ +-- Packing and unpacking from lists + +-- | /O(n)/. Convert a list into a 'ShortByteString' +pack :: [Word8] -> ShortByteString +pack = packBytes + +-- | /O(n)/. Convert a 'ShortByteString' into a list. +unpack :: ShortByteString -> [Word8] +unpack = unpackBytes + +packChars :: [Char] -> ShortByteString +packChars cs = packLenChars (List.length cs) cs + +packBytes :: [Word8] -> ShortByteString +packBytes cs = packLenBytes (List.length cs) cs + +packLenChars :: Int -> [Char] -> ShortByteString +packLenChars len cs0 = + create len (\mba -> go mba 0 cs0) + where + go :: MBA s -> Int -> [Char] -> ST s () + go !_ !_ [] = return () + go !mba !i (c:cs) = do + writeCharArray mba i c + go mba (i+1) cs + +packLenBytes :: Int -> [Word8] -> ShortByteString +packLenBytes len ws0 = + create len (\mba -> go mba 0 ws0) + where + go :: MBA s -> Int -> [Word8] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord8Array mba i w + go mba (i+1) ws + +-- Unpacking bytestrings into lists effeciently is a tradeoff: on the one hand +-- we would like to write a tight loop that just blats the list into memory, on +-- the other hand we want it to be unpacked lazily so we don't end up with a +-- massive list data structure in memory. +-- +-- Our strategy is to combine both: we will unpack lazily in reasonable sized +-- chunks, where each chunk is unpacked strictly. +-- +-- unpackChars does the lazy loop, while unpackAppendBytes and +-- unpackAppendChars do the chunks strictly. + +unpackChars :: ShortByteString -> [Char] +unpackChars bs = unpackAppendCharsLazy bs [] + +unpackBytes :: ShortByteString -> [Word8] +unpackBytes bs = unpackAppendBytesLazy bs [] + +-- Why 100 bytes you ask? Because on a 64bit machine the list we allocate +-- takes just shy of 4k which seems like a reasonable amount. +-- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) + +unpackAppendCharsLazy :: ShortByteString -> [Char] -> [Char] +unpackAppendCharsLazy sbs cs0 = + go 0 (length sbs) cs0 + where + sz = 100 + + go off len cs + | len <= sz = unpackAppendCharsStrict sbs off len cs + | otherwise = unpackAppendCharsStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) cs + +unpackAppendBytesLazy :: ShortByteString -> [Word8] -> [Word8] +unpackAppendBytesLazy sbs ws0 = + go 0 (length sbs) ws0 + where + sz = 100 + + go off len ws + | len <= sz = unpackAppendBytesStrict sbs off len ws + | otherwise = unpackAppendBytesStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) ws + +-- For these unpack functions, since we're unpacking the whole list strictly we +-- build up the result list in an accumulator. This means we have to build up +-- the list starting at the end. So our traversal starts at the end of the +-- buffer and loops down until we hit the sentinal: + +unpackAppendCharsStrict :: ShortByteString -> Int -> Int -> [Char] -> [Char] +unpackAppendCharsStrict !sbs off len cs = + go (off-1) (off-1 + len) cs + where + go !sentinal !i !acc + | i == sentinal = acc + | otherwise = let !c = indexCharArray (asBA sbs) i + in go sentinal (i-1) (c:acc) + +unpackAppendBytesStrict :: ShortByteString -> Int -> Int -> [Word8] -> [Word8] +unpackAppendBytesStrict !sbs off len ws = + go (off-1) (off-1 + len) ws + where + go !sentinal !i !acc + | i == sentinal = acc + | otherwise = let !w = indexWord8Array (asBA sbs) i + in go sentinal (i-1) (w:acc) + + +------------------------------------------------------------------------ +-- Eq and Ord implementations + +equateBytes :: ShortByteString -> ShortByteString -> Bool +equateBytes sbs1 sbs2 = + let !len1 = length sbs1 + !len2 = length sbs2 + in len1 == len2 + && 0 == inlinePerformIO (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len1) + +compareBytes :: ShortByteString -> ShortByteString -> Ordering +compareBytes sbs1 sbs2 = + let !len1 = length sbs1 + !len2 = length sbs2 + !len = min len1 len2 + in case inlinePerformIO (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len) of + i | i < 0 -> LT + | i > 0 -> GT + | len2 > len1 -> LT + | len2 < len1 -> GT + | otherwise -> EQ + + +------------------------------------------------------------------------ +-- Appending and concatenation + +append :: ShortByteString -> ShortByteString -> ShortByteString +append src1 src2 = + let !len1 = length src1 + !len2 = length src2 + in create (len1 + len2) $ \dst -> do + copyByteArray (asBA src1) 0 dst 0 len1 + copyByteArray (asBA src2) 0 dst len1 len2 + +concat :: [ShortByteString] -> ShortByteString +concat sbss = + create (totalLen 0 sbss) (\dst -> copy dst 0 sbss) + where + totalLen !acc [] = acc + totalLen !acc (sbs: sbss) = totalLen (acc + length sbs) sbss + + copy :: MBA s -> Int -> [ShortByteString] -> ST s () + copy !_ !_ [] = return () + copy !dst !off (src : sbss) = do + let !len = length src + copyByteArray (asBA src) 0 dst off len + copy dst (off + len) sbss + + +------------------------------------------------------------------------ +-- Exported low level operations + +copyToPtr :: ShortByteString -- ^ source data + -> Int -- ^ offset into source + -> Ptr a -- ^ destination + -> Int -- ^ number of bytes to copy + -> IO () +copyToPtr src off dst len = + stToIO $ + copyByteArrayToAddr (asBA src) off dst len + +createFromPtr :: Ptr a -- ^ source data + -> Int -- ^ number of bytes to copy + -> IO ShortByteString +createFromPtr !ptr len = + stToIO $ do + mba <- newByteArray len + copyAddrToByteArray ptr mba 0 len + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba# LEN(len)) + + +------------------------------------------------------------------------ +-- Primop wrappers + +data BA = BA# ByteArray# +data MBA s = MBA# (MutableByteArray# s) + +indexCharArray :: BA -> Int -> Char +indexCharArray (BA# ba#) (I# i#) = C# (indexCharArray# ba# i#) + +indexWord8Array :: BA -> Int -> Word8 +indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#) + +newByteArray :: Int -> ST s (MBA s) +newByteArray (I# len#) = + ST $ \s -> case newByteArray# len# s of + (# s, mba# #) -> (# s, MBA# mba# #) + +#if MIN_VERSION_base(4,6,0) +newPinnedByteArray :: Int -> ST s (MBA s) +newPinnedByteArray (I# len#) = + ST $ \s -> case newPinnedByteArray# len# s of + (# s, mba# #) -> (# s, MBA# mba# #) +#endif + +unsafeFreezeByteArray :: MBA s -> ST s BA +unsafeFreezeByteArray (MBA# mba#) = + ST $ \s -> case unsafeFreezeByteArray# mba# s of + (# s, ba# #) -> (# s, BA# ba# #) + +writeCharArray :: MBA s -> Int -> Char -> ST s () +writeCharArray (MBA# mba#) (I# i#) (C# c#) = + ST $ \s -> case writeCharArray# mba# i# c# s of + s -> (# s, () #) + +writeWord8Array :: MBA s -> Int -> Word8 -> ST s () +writeWord8Array (MBA# mba#) (I# i#) (W8# w#) = + ST $ \s -> case writeWord8Array# mba# i# w# s of + s -> (# s, () #) + +copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld () +copyAddrToByteArray (Ptr src#) (MBA# dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of + s -> (# s, () #) + +copyByteArrayToAddr :: BA -> Int -> Ptr a -> Int -> ST RealWorld () +copyByteArrayToAddr (BA# src#) (I# src_off#) (Ptr dst#) (I# len#) = + ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of + s -> (# s, () #) + +copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s () +copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of + s -> (# s, () #) + + +------------------------------------------------------------------------ +-- FFI imports + +memcmp_ByteArray :: BA -> BA -> Int -> IO CInt +memcmp_ByteArray (BA# ba1#) (BA# ba2#) len = + c_memcmp_ByteArray ba1# ba2# (fromIntegral len) + +foreign import ccall unsafe "string.h memcmp" + c_memcmp_ByteArray :: ByteArray# -> ByteArray# -> CSize -> IO CInt + + +------------------------------------------------------------------------ +-- Primop replacements + +copyAddrToByteArray# :: Addr# + -> MutableByteArray# RealWorld -> Int# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArrayToAddr# :: ByteArray# -> Int# + -> Addr# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArray# :: ByteArray# -> Int# + -> MutableByteArray# s -> Int# + -> Int# + -> State# s -> State# s + +#if MIN_VERSION_base(4,7,0) + +-- These exist as real primops in ghc-7.8, and for before that we use +-- FFI to C memcpy. +copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray# +copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr# + +#else + +copyAddrToByteArray# src dst dst_off len s = + unIO_ (memcpy_AddrToByteArray dst (clong dst_off) src 0 (csize len)) s + +copyAddrToByteArray0 :: Addr# -> MutableByteArray# s -> Int# + -> State# RealWorld -> State# RealWorld +copyAddrToByteArray0 src dst len s = + unIO_ (memcpy_AddrToByteArray0 dst src (csize len)) s + +{-# INLINE [0] copyAddrToByteArray# #-} +{-# RULES "copyAddrToByteArray# dst_off=0" + forall src dst len s. + copyAddrToByteArray# src dst 0# len s + = copyAddrToByteArray0 src dst len s #-} + +foreign import ccall unsafe "fpstring.h fps_memcpy_offsets" + memcpy_AddrToByteArray :: MutableByteArray# s -> CLong -> Addr# -> CLong -> CSize -> IO () + +foreign import ccall unsafe "string.h memcpy" + memcpy_AddrToByteArray0 :: MutableByteArray# s -> Addr# -> CSize -> IO () + + +copyByteArrayToAddr# src src_off dst len s = + unIO_ (memcpy_ByteArrayToAddr dst 0 src (clong src_off) (csize len)) s + +copyByteArrayToAddr0 :: ByteArray# -> Addr# -> Int# + -> State# RealWorld -> State# RealWorld +copyByteArrayToAddr0 src dst len s = + unIO_ (memcpy_ByteArrayToAddr0 dst src (csize len)) s + +{-# INLINE [0] copyByteArrayToAddr# #-} +{-# RULES "copyByteArrayToAddr# src_off=0" + forall src dst len s. + copyByteArrayToAddr# src 0# dst len s + = copyByteArrayToAddr0 src dst len s #-} + +foreign import ccall unsafe "fpstring.h fps_memcpy_offsets" + memcpy_ByteArrayToAddr :: Addr# -> CLong -> ByteArray# -> CLong -> CSize -> IO () + +foreign import ccall unsafe "string.h memcpy" + memcpy_ByteArrayToAddr0 :: Addr# -> ByteArray# -> CSize -> IO () + + +unIO_ :: IO () -> State# RealWorld -> State# RealWorld +unIO_ io s = case unIO io s of (# s, _ #) -> s + +clong :: Int# -> CLong +clong i# = fromIntegral (I# i#) + +csize :: Int# -> CSize +csize i# = fromIntegral (I# i#) +#endif + +#if MIN_VERSION_base(4,5,0) +copyByteArray# = GHC.Exts.copyByteArray# +#else +copyByteArray# src src_off dst dst_off len s = + unST_ (unsafeIOToST + (memcpy_ByteArray dst (clong dst_off) src (clong src_off) (csize len))) s + where + unST (ST st) = st + unST_ st s = case unST st s of (# s, _ #) -> s + +foreign import ccall unsafe "fpstring.h fps_memcpy_offsets" + memcpy_ByteArray :: MutableByteArray# s -> CLong + -> ByteArray# -> CLong -> CSize -> IO () +#endif +