diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Revision history for mason +## 0.2 + +* Added `doubleFixed`, `doubleSI` and `doubleExp` +* Added `textUtf8` +* Added `prefixVarInt`, `wordVLQ` and `intVLQ` +* Renamed `padded` and `zeroPadded` to `paddedBoundedPrim` and `zeroPaddedBoundedPrim` respectively +* Added `Mason.Builder.Dynamic` + ## 0 -- 2019-12-05 * First version. Released on an unsuspecting world. diff --git a/mason.cabal b/mason.cabal --- a/mason.cabal +++ b/mason.cabal @@ -1,23 +1,30 @@ cabal-version: 2.4 name: mason -version: 0.1 +version: 0.2 synopsis: Fast and extensible bytestring builder -description: See README.md +description: + This package provides efficient implementation of bytestring builders. + See README.md for details bug-reports: https://github.com/fumieval/mason/issues license: BSD-3-Clause license-file: LICENSE author: Fumiaki Kinoshita maintainer: fumiexcel@gmail.com -copyright: 2019 Fumiaki Kinoshita, Don Stewart 2005-2009, Duncan Coutts 2006-2015, David Roundy 2003-2005, Jasper Van der Jeugt 2010, Simon Meier 2010-2013, Ben Gamari 2017 +copyright: 2020 Fumiaki Kinoshita, Don Stewart 2005-2009, Duncan Coutts 2006-2015, David Roundy 2003-2005, Jasper Van der Jeugt 2010, Simon Meier 2010-2013, Ben Gamari 2017 category: Data extra-source-files: CHANGELOG.md, README.md tested-with: GHC == 8.6.5, GHC==8.8.1 +source-repository head + type: git + location: https://github.com/fumieval/mason.git + library exposed-modules: Mason.Builder Mason.Builder.Internal + Mason.Builder.Dynamic c-sources: cbits/dtoa.c ghc-options: -Wall -O2 @@ -27,5 +34,6 @@ , network >= 2.7 && <3.2 , integer-gmp , ghc-prim + , array hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Mason/Builder.hs b/src/Mason/Builder.hs --- a/src/Mason/Builder.hs +++ b/src/Mason/Builder.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MagicHash, CPP, UnboxedTuples #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} ---------------------------------------------------------------------------- -- | -- Module : Mason.Builders @@ -22,11 +23,21 @@ , sendBuilder -- * Primitives , flush - , encodeUtf8Builder - , encodeUtf8BuilderEscaped + -- * Bytes , byteString , lazyByteString , shortByteString + -- * Text + , textUtf8 + , encodeUtf8Builder + , encodeUtf8BuilderEscaped + , char7 + , string7 + , char8 + , string8 + , charUtf8 + , stringUtf8 + -- * Primitive , storable , int8 , word8 @@ -46,14 +57,12 @@ , word64BE , floatBE , doubleBE - , char7 - , string7 - , char8 - , string8 - , charUtf8 - , stringUtf8 + -- * Numeral , floatDec , doubleDec + , doubleSI + , doubleExp + , doubleFixed , word8Dec , word16Dec , word32Dec @@ -82,22 +91,32 @@ , doubleHexFixed , byteStringHex , lazyByteStringHex + -- * Variable-length encoding + , intVLQ + , intVLQBP + , wordVLQ + , wordVLQBP + , prefixVarInt + , prefixVarIntBP -- * Advanced - , padded - , zeroPadded + , paddedBoundedPrim + , zeroPaddedBoundedPrim , primFixed , primBounded , lengthPrefixedWithin ) where import Control.Monad +import qualified Data.Array as A import Data.Bits import Data.Word import Data.Int import qualified Data.Text as T import Foreign.C.Types -import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Ptr (Ptr, plusPtr, castPtr) +import Foreign.Storable import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as BL import Mason.Builder.Internal as B import qualified Data.ByteString.Builder.Prim as P @@ -107,7 +126,7 @@ import System.IO (Handle) -- | Put the content of a 'Builder' to a 'Handle'. -hPutBuilder :: Handle -> BuilderFor PutBuilderEnv -> IO () +hPutBuilder :: Handle -> BuilderFor PutEnv -> IO () hPutBuilder h b = void $ hPutBuilderLen h b {-# INLINE hPutBuilder #-} @@ -259,11 +278,16 @@ charUtf8 :: Char -> Builder charUtf8 = B.primBounded P.charUtf8 --- | Encode 'T.Text' as a UTF-8 byte stream. +-- | Encode 'T.Text' as a UTF-8 byte stream. Synonym for 'textUtf8'. encodeUtf8Builder :: T.Text -> Builder -encodeUtf8Builder = B.encodeUtf8BuilderEscaped (P.liftFixedToBounded P.word8) +encodeUtf8Builder = textUtf8 {-# INLINE encodeUtf8Builder #-} +-- | Encode 'T.Text' as a UTF-8 byte stream. +textUtf8 :: T.Text -> Builder +textUtf8 = B.encodeUtf8BuilderEscaped (P.liftFixedToBounded P.word8) +{-# INLINE textUtf8 #-} + -------------------- -- Unsigned integers -------------------- @@ -301,16 +325,21 @@ floatDec :: Float -> Builder floatDec = string7 . show +wrapDoubleDec :: (Double -> Builder) -> Double -> Builder +wrapDoubleDec k x + | isNaN x = string7 "NaN" + | isInfinite x = if x < 0 then string7 "-Infinity" else string7 "Infinity" + | isNegativeZero x = char7 '-' <> k 0.0 + | x < 0 = char7 '-' <> k (-x) + | otherwise = k x +{-# INLINE wrapDoubleDec #-} + -- | Decimal encoding of an IEEE 'Double'. {-# INLINE doubleDec #-} doubleDec :: Double -> Builder -doubleDec x - | isNaN x = string7 "NaN" - | isInfinite x = if x < 0 then string7 "-Infinity" else string7 "Infinity" - | x < 0 = char7 '-' <> grisu (-x) - | isNegativeZero x = string7 "-0.0" - | x == 0 = string7 "0.0" - | otherwise = grisu x +doubleDec = wrapDoubleDec $ \case + 0 -> string7 "0.0" + x -> grisu x where grisu v = withPtr 24 $ \ptr -> do n <- dtoa_grisu3 v ptr @@ -319,6 +348,93 @@ foreign import ccall unsafe "static dtoa_grisu3" dtoa_grisu3 :: Double -> Ptr Word8 -> IO CInt +-- | Attach an SI prefix so that abs(mantissa) is within [1, 1000). Omits c, d, da and h. +doubleSI :: Int -- ^ precision: must be equal or greater than 3 + -> Double + -> Builder +doubleSI prec | prec < 3 = error "Mason.Builder.doubleSI: precision less than 3" +doubleSI prec = wrapDoubleDec $ \case + 0 -> zeroes prec + val -> Builder $ \env buf -> withGrisu3Rounded prec val $ \ptr len e -> do + let (pindex, dp) = divMod (e - 1) 3 + print (dp, prec, len) + let mantissa + -- when the decimal separator would be at the end + | dp + 1 == prec = withPtr (prec + dp - 2) $ \dst -> do + _ <- B.memset dst 48 $ fromIntegral (prec + dp - 2) + B.memcpy dst ptr $ min len prec + return $ dst `plusPtr` (prec + dp - 2) + | otherwise = withPtr (prec + 1) $ \dst -> do + _ <- B.memset dst 48 $ fromIntegral (prec + 1) + B.memcpy dst ptr $ min len $ dp + 1 + pokeElemOff dst (dp + 1) 46 + B.memcpy (dst `plusPtr` (dp + 2)) (ptr `plusPtr` (dp + 1)) $ max 0 $ len - dp - 1 + return $ dst `plusPtr` (prec + 1) + let prefix + | pindex == 0 = mempty + | pindex > 8 || pindex < (-8) = char7 'e' <> intDec (3 * pindex) + | otherwise = charUtf8 (prefices A.! pindex) + unBuilder (mantissa <> prefix) env buf + where + prefices = A.listArray (-8,8) "yzafpnμm\NULkMGTPEZY" + +zeroes :: Int -> Builder +zeroes n = withPtr (n + 1) $ \dst -> do + _ <- B.memset dst 48 $ fromIntegral $ n + 1 + pokeElemOff dst 1 46 + return $ dst `plusPtr` (n + 1) + +-- | Always use exponents +doubleExp :: Int -- ^ number of digits in the mantissa + -> Double + -> Builder +doubleExp prec | prec < 1 = error "Mason.Builder.doubleFixed: precision too small" +doubleExp prec = wrapDoubleDec $ \case + 0 -> zeroes prec <> string7 "e0" + val -> Builder $ \env buf -> withGrisu3Rounded prec val $ \ptr len dp -> do + let len' = 1 + prec + + firstDigit <- peek ptr + + unBuilder (withPtr len' (\dst -> do + _ <- B.memset dst 48 $ fromIntegral len' + poke dst firstDigit + poke (dst `plusPtr` 1) (46 :: Word8) + B.memcpy (dst `plusPtr` 2) (ptr `plusPtr` 1) (min (len - 1) len') + return (dst `plusPtr` len')) + <> char7 'e' <> intDec (dp - 1)) env buf + +-- | Fixed precision +doubleFixed :: Int -- ^ decimal points + -> Double + -> Builder +doubleFixed 0 = intDec . round +doubleFixed prec | prec < 0 = error "Mason.Builder.doubleFixed: negative precision" +doubleFixed prec = wrapDoubleDec $ \case + 0 -> zeroes (prec + 1) + val -> Builder $ \env buf -> withGrisu3 val (unBuilder (doubleDec val) env buf) $ \ptr0 len e0 -> do + bump <- roundDigit (prec + e0) len ptr0 + let dp + | bump = e0 + 1 + | otherwise = e0 + let ptr + | bump = ptr0 + | otherwise = ptr0 `plusPtr` 1 + let len' = 1 + prec + max 1 dp + + unBuilder (withPtr len' $ \dst -> do + _ <- B.memset dst 48 $ fromIntegral len' + if dp >= 1 + then do + B.memcpy dst ptr $ min len dp + pokeElemOff dst dp 46 + B.memcpy (dst `plusPtr` (dp + 1)) (ptr `plusPtr` dp) $ max 0 (len - dp) + else do + pokeElemOff dst 1 46 + B.memcpy (dst `plusPtr` (2 - dp)) ptr len + return $ dst `plusPtr` len' + ) env buf + ------------------------------------------------------------------------------ -- Decimal Encoding ------------------------------------------------------------------------------ @@ -534,3 +650,71 @@ intDecPadded = P.liftFixedToBounded $ caseWordSize_32_64 (P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral) (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral) + +-- Variable-length encoding +---- + +-- | Signed VLQ encoding (the first bit is a sign) +intVLQ :: Int -> Builder +intVLQ = primBounded intVLQBP +{-# INLINE intVLQ #-} + +intVLQBP :: P.BoundedPrim Int +intVLQBP = P.boudedPrim 10 writeIntFinite +{-# INLINE CONLIKE intVLQBP #-} + +-- | Unsigned VLQ encoding +wordVLQ :: Word -> Builder +wordVLQ = primBounded wordVLQBP + +wordVLQBP :: P.BoundedPrim Word +wordVLQBP = P.boudedPrim 10 (writeUnsignedFinite pure) + +writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8) +writeWord8 w p = do + poke p w + return $! plusPtr p 1 + +writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8) +writeIntFinite n + | n < 0 = case negate n of + n' + | n' < 0x40 -> writeWord8 (fromIntegral n' `setBit` 6) + | otherwise -> + writeWord8 (0xc0 .|. fromIntegral n') >=> + writeUnsignedFinite pure (unsafeShiftR n' 6) + | n < 0x40 = writeWord8 (fromIntegral n) + | otherwise = writeWord8 (fromIntegral n `setBit` 7 `clearBit` 6) >=> + writeUnsignedFinite pure (unsafeShiftR n 6) +{-# INLINE writeIntFinite #-} + +writeUnsignedFinite :: (Bits a, Integral a) => (Ptr Word8 -> IO r) -> a -> Ptr Word8 -> IO r +writeUnsignedFinite k = go + where + go m + | m < 0x80 = writeWord8 (fromIntegral m) >=> k + | otherwise = writeWord8 (setBit (fromIntegral m) 7) >=> go (unsafeShiftR m 7) +{-# INLINE writeUnsignedFinite #-} + +-- | Encode a Word in +prefixVarInt :: Word -> Builder +prefixVarInt = primBounded prefixVarIntBP + +prefixVarIntBP :: P.BoundedPrim Word +prefixVarIntBP = P.boudedPrim 9 $ \x ptr0 -> do + let bits = 64 - countLeadingZeros (x .|. 1) + if bits > 56 + then do + poke ptr0 0 + poke (castPtr ptr0 `plusPtr` 1) x + return $! ptr0 `plusPtr` 9 + else do + let bytes = 1 + (bits - 1) `div` 7 + let end = ptr0 `plusPtr` bytes + let go ptr n + | ptr == end = pure ptr + | otherwise = do + poke ptr (fromIntegral n .&. 0xff) + go (ptr `plusPtr` 1) (n `shiftR` 8) + go ptr0 $! (2 * x + 1) `shiftL` (bytes - 1) +{-# INLINE CONLIKE prefixVarIntBP #-} diff --git a/src/Mason/Builder/Dynamic.hs b/src/Mason/Builder/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Mason/Builder/Dynamic.hs @@ -0,0 +1,60 @@ +module Mason.Builder.Dynamic + ( DynBuilder + , DynamicBackend(..) + -- * Runners + , toStrictByteString + , toLazyByteString + , hPutBuilderLen + , hPutBuilder + , sendBuilder + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Mason.Builder as B +import qualified Mason.Builder.Internal as B +import Network.Socket (Socket) +import System.IO (Handle) + +data DynamicBackend = DynGrowingBuffer !B.GrowingBuffer + | DynChannel !B.Channel + | DynPutEnv !B.PutEnv + +instance B.Buildable DynamicBackend where + byteString bs = B.Builder $ \env buf -> case env of + DynGrowingBuffer e -> B.unBuilder (B.byteString bs) e buf + DynChannel e -> B.unBuilder (B.byteString bs) e buf + DynPutEnv e -> B.unBuilder (B.byteString bs) e buf + flush = B.Builder $ \env buf -> case env of + DynGrowingBuffer e -> B.unBuilder B.flush e buf + DynChannel e -> B.unBuilder B.flush e buf + DynPutEnv e -> B.unBuilder B.flush e buf + allocate n = B.Builder $ \env buf -> case env of + DynGrowingBuffer e -> B.unBuilder (B.allocate n) e buf + DynChannel e -> B.unBuilder (B.allocate n) e buf + DynPutEnv e -> B.unBuilder (B.allocate n) e buf + +-- | Builder with a fixed set of backends. This helps reducing code size +-- and unoptimised code especially on complex/recursive structures, at the cost of +-- extensibility. +type DynBuilder = B.BuilderFor DynamicBackend + +toStrictByteString :: DynBuilder -> B.ByteString +toStrictByteString b = B.toStrictByteString $ B.Builder $ B.unBuilder b . DynGrowingBuffer +{-# INLINE toStrictByteString #-} + +toLazyByteString :: DynBuilder -> BL.ByteString +toLazyByteString b = B.toLazyByteString $ B.Builder $ B.unBuilder b . DynChannel +{-# INLINE toLazyByteString #-} + +hPutBuilder :: Handle -> DynBuilder -> IO () +hPutBuilder h b = B.hPutBuilder h $ B.Builder $ B.unBuilder b . DynPutEnv +{-# INLINE hPutBuilder #-} + +hPutBuilderLen :: Handle -> DynBuilder -> IO Int +hPutBuilderLen h b = B.hPutBuilderLen h $ B.Builder $ B.unBuilder b . DynPutEnv +{-# INLINE hPutBuilderLen #-} + +sendBuilder :: Socket -> DynBuilder -> IO Int +sendBuilder h b = B.sendBuilder h $ B.Builder $ B.unBuilder b . DynPutEnv +{-# INLINE sendBuilder #-} diff --git a/src/Mason/Builder/Internal.hs b/src/Mason/Builder/Internal.hs --- a/src/Mason/Builder/Internal.hs +++ b/src/Mason/Builder/Internal.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE RecordWildCards #-} module Mason.Builder.Internal (Builder , BuilderFor(..) , Buildable(..) @@ -21,21 +22,22 @@ , primMapListBounded , primMapByteStringFixed , primMapLazyByteStringFixed + , PutEnv(..) , hPutBuilderLen - , PutBuilderEnv(..) , encodeUtf8BuilderEscaped , sendBuilder - , SocketEnv(..) , cstring , cstringUtf8 , withPtr , storable - , padded - , zeroPadded + , paddedBoundedPrim + , zeroPaddedBoundedPrim -- * Internal , ensure , allocateConstant - , grisu3 + , withGrisu3 + , withGrisu3Rounded + , roundDigit ) where import Control.Concurrent @@ -66,7 +68,6 @@ import qualified Data.Text.Internal as T import qualified Data.Text.Internal.Encoding.Utf16 as U16 import qualified Network.Socket as S -import qualified Network.Socket.ByteString as S import GHC.Prim (eqWord#, plusAddr#, indexWord8OffAddr#) import GHC.Ptr (Ptr(..)) import GHC.Word (Word8(..)) @@ -244,12 +245,13 @@ primMapLazyByteStringFixed fp = BL.foldr (mappend . primFixed fp) mempty {-# INLINE primMapLazyByteStringFixed #-} -padded :: Word8 +paddedBoundedPrim + :: Word8 -- ^ filler -> Int -- ^ pad if shorter than this -> B.BoundedPrim a -> a -> Builder -padded ch size bp a = ensure (B.sizeBound bp) $ \(Buffer end ptr) -> do +paddedBoundedPrim ch size bp a = ensure (B.sizeBound bp) $ \(Buffer end ptr) -> do ptr' <- B.runB bp a ptr let len = ptr' `minusPtr` ptr let pad = size - len @@ -258,8 +260,8 @@ void $ B.memset ptr ch (fromIntegral pad) return $ Buffer end $ ptr' `plusPtr` max pad 0 -zeroPadded :: Int -> B.BoundedPrim a -> a -> Builder -zeroPadded = padded 48 +zeroPaddedBoundedPrim :: Int -> B.BoundedPrim a -> a -> Builder +zeroPaddedBoundedPrim = paddedBoundedPrim 48 newtype GrowingBuffer = GrowingBuffer (IORef (ForeignPtr Word8)) @@ -304,7 +306,7 @@ instance Buildable Channel where byteString bs - | B.length bs < 3272 = byteStringCopy bs + | B.length bs < 4096 = byteStringCopy bs | otherwise = flush <> Builder (\(Channel v _) b -> b <$ putMVar v bs) {-# INLINE byteString #-} flush = Builder $ \(Channel v ref) (Buffer end ptr) -> do @@ -321,14 +323,15 @@ toLazyByteString body = unsafePerformIO $ do resp <- newEmptyMVar - fptr <- mallocForeignPtrBytes defaultBufferSize + let initialSize = 4096 + fptr <- mallocForeignPtrBytes initialSize ref <- newIORef fptr let ptr = unsafeForeignPtrToPtr fptr let final (Left e) = throw e final (Right _) = putMVar resp B.empty _ <- flip forkFinally final $ unBuilder (body <> flush) (Channel resp ref) - $ Buffer (ptr `plusPtr` defaultBufferSize) ptr + $ Buffer (ptr `plusPtr` initialSize) ptr let go _ = unsafePerformIO $ do bs <- takeMVar resp @@ -338,11 +341,13 @@ return $ go () {-# INLINE toLazyByteString #-} --- | Environemnt for handle output -data PutBuilderEnv = PBE - { pbHandle :: !Handle - , pbBuffer :: !(IORef (ForeignPtr Word8)) - , pbTotal :: !(IORef Int) +-- | Environment for handle output +data PutEnv = PutEnv + { peThreshold :: !Int + , pePut :: !(Ptr Word8 -> Ptr Word8 -> IO ()) + -- ^ takes a pointer range and returns the number of bytes written + , peBuffer :: !(IORef (ForeignPtr Word8)) + , peTotal :: !(IORef Int) } -- | Allocate a new buffer. @@ -354,50 +359,44 @@ return $! Buffer (ptr1 `plusPtr` len) ptr1 {-# INLINE allocateConstant #-} -instance Buildable PutBuilderEnv where - byteString bs - | len > defaultBufferSize = mappend flush $ Builder $ \(PBE h _ _) buf -> do - B.hPut h bs - return buf - | otherwise = byteStringCopy bs - where - len = B.length bs +instance Buildable PutEnv where + byteString bs@(B.PS fptr ofs len) = Builder $ \env@PutEnv{..} buf -> if len > peThreshold + then do + buf' <- unBuilder flush env buf + withForeignPtr fptr $ \ptr -> do + let ptr0 = ptr `plusPtr` ofs + pePut ptr0 (ptr0 `plusPtr` len) + pure buf' + else unBuilder (byteStringCopy bs) env buf {-# INLINE byteString #-} - flush = Builder $ \(PBE h ref counter) (Buffer end ptr) -> do - ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref + flush = Builder $ \PutEnv{..} (Buffer end ptr) -> do + ptr0 <- unsafeForeignPtrToPtr <$> readIORef peBuffer let len = minusPtr ptr ptr0 - modifyIORef' counter (+len) - hPutBuf h ptr0 len + modifyIORef' peTotal (+len) + pePut ptr0 ptr return $! Buffer end ptr0 {-# INLINE flush #-} - allocate = allocateConstant pbBuffer + allocate = allocateConstant peBuffer {-# INLINE allocate #-} -defaultBufferSize :: Int -defaultBufferSize = 2048 - -- | Write a 'Builder' into a handle and obtain the number of bytes written. -- 'flush' does not imply actual disk operations. Set 'NoBuffering' if you want -- it to write the content immediately. -hPutBuilderLen :: Handle -> BuilderFor PutBuilderEnv -> IO Int +hPutBuilderLen :: Handle -> BuilderFor PutEnv -> IO Int hPutBuilderLen h b = do - fptr <- mallocForeignPtrBytes defaultBufferSize + let initialSize = 4096 + fptr <- mallocForeignPtrBytes initialSize ref <- newIORef fptr let ptr = unsafeForeignPtrToPtr fptr counter <- newIORef 0 - _ <- unBuilder (b <> flush) (PBE h ref counter) (Buffer (ptr `plusPtr` defaultBufferSize) ptr) + _ <- unBuilder (b <> flush) + (PutEnv initialSize (\ptr0 ptr1 -> hPutBuf h ptr (minusPtr ptr1 ptr0)) ref counter) + (Buffer (ptr `plusPtr` initialSize) ptr) readIORef counter {-# INLINE hPutBuilderLen #-} --- | Environemnt for socket output -data SocketEnv = SE - { seSocket :: !S.Socket - , seBuffer :: !(IORef (ForeignPtr Word8)) - , seCounter :: !(IORef Int) - } - sendBufRange :: S.Socket -> Ptr Word8 -> Ptr Word8 -> IO () sendBufRange sock ptr0 ptr1 = go ptr0 where go p @@ -407,33 +406,17 @@ S.withFdSocket sock $ threadWaitWrite . fromIntegral when (sent > 0) $ go $ p `plusPtr` sent -instance Buildable SocketEnv where - byteString bs - | len > defaultBufferSize = mappend flush $ Builder $ \(SE sock _ _) (Buffer end ptr) -> do - S.sendAll sock bs - return $! Buffer end ptr - | otherwise = byteStringCopy bs - where - len = B.length bs - {-# INLINE byteString #-} - - flush = Builder $ \(SE sock ref counter) (Buffer end ptr1) -> do - ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref - sendBufRange sock ptr0 ptr1 - modifyIORef' counter (+minusPtr ptr1 ptr0) - return $! Buffer end ptr0 - {-# INLINE flush #-} - - allocate = allocateConstant seBuffer - -- | Write a 'Builder' into a handle and obtain the number of bytes written. -sendBuilder :: S.Socket -> BuilderFor SocketEnv -> IO Int +sendBuilder :: S.Socket -> BuilderFor PutEnv -> IO Int sendBuilder sock b = do - fptr <- mallocForeignPtrBytes defaultBufferSize + let initialSize = 4096 + fptr <- mallocForeignPtrBytes initialSize ref <- newIORef fptr let ptr = unsafeForeignPtrToPtr fptr counter <- newIORef 0 - _ <- unBuilder (b <> flush) (SE sock ref counter) (Buffer (ptr `plusPtr` defaultBufferSize) ptr) + _ <- unBuilder (b <> flush) + (PutEnv initialSize (sendBufRange sock) ref counter) + (Buffer (ptr `plusPtr` initialSize) ptr) readIORef counter {-# INLINE sendBuilder #-} @@ -485,18 +468,47 @@ c_memmove :: Ptr Word8 -> Ptr Word8 -> Int -> IO () -- | Decimal encoding of a positive 'Double'. -{-# INLINE grisu3 #-} -grisu3 :: Double -> Maybe (B.ByteString, Int) -grisu3 d = unsafeDupablePerformIO $ allocaArray 2 $ \plen -> do - fptr <- B.mallocByteString 18 +{-# INLINE withGrisu3 #-} +withGrisu3 :: Double -> IO r -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r +withGrisu3 d contFail cont = allocaArray 2 $ \plen -> allocaArray 19 $ \ptr -> do let pexp = plusPtr plen (S.sizeOf (undefined :: CInt)) - success <- withForeignPtr fptr $ \ptr -> c_grisu3 (realToFrac d) ptr plen pexp + success <- c_grisu3 (realToFrac d) (ptr `plusPtr` 1) plen pexp if success == 0 - then return Nothing + then contFail else do len <- fromIntegral <$> S.peek plen e <- fromIntegral <$> S.peek pexp - return $ Just (B.PS fptr 0 len, len + e) + cont ptr len (len + e) + +{-# INLINE withGrisu3Rounded #-} +withGrisu3Rounded :: Int -> Double -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r +withGrisu3Rounded prec val cont = withGrisu3 val (error "withGrisu3Rounded: failed") $ \ptr len e -> do + let len' = min prec len + bump <- roundDigit prec len ptr + if bump then cont ptr len' (e + 1) else cont (ptr `plusPtr` 1) len' e + +-- | Round up to the supplied precision inplace. +roundDigit + :: Int -- ^ precision + -> Int -- ^ available digits + -> Ptr Word8 -- ^ content + -> IO Bool +roundDigit prec len _ | prec >= len = pure False +roundDigit prec _ ptr = do + rd <- peekElemOff ptr (prec + 1) + let carry 0 = do + poke ptr 49 + pure True + carry i = do + d <- peekElemOff ptr i + if d == 57 + then pokeElemOff ptr i 48 *> carry (i - 1) + else do + pokeElemOff ptr i (d + 1) + pure False + if rd >= 53 + then carry prec + else pure False foreign import ccall unsafe "static grisu3" c_grisu3 :: CDouble -> Ptr Word8 -> Ptr CInt -> Ptr CInt -> IO CInt