Implement floating point conversion with ryu

Data/ByteString/Builder.hs

@@ -252,13 +252,15 @@ module Data.ByteString.Builder
     , stringUtf8
 
     , module Data.ByteString.Builder.ASCII
+    , module Data.ByteString.Builder.RealFloat
 
     ) 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.ByteString.Builder.RealFloat
 
 import           Data.String (IsString(..))
 import           System.IO (Handle)

Data/ByteString/Builder/ASCII.hs

@@ -36,9 +36,6 @@ module Data.ByteString.Builder.ASCII
     , word64Dec
     , wordDec
 
-    , floatDec
-    , doubleDec
-
       -- *** Hexadecimal numbers
 
       -- | Encoding positive integers as hexadecimal numbers using lower-case
@@ -197,22 +194,6 @@ 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
 ------------------------------------------------------------------------------

Data/ByteString/Builder/RealFloat.hsc

@@ -0,0 +1,295 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module Data.ByteString.Builder.RealFloat
+  ( FFFormat(..)
+  , floatDec
+  , doubleDec
+  , formatFloat
+  , formatDouble
+  ) where
+
+import Data.ByteString.Internal (ByteString(..), mallocByteString)
+import Data.ByteString.Builder.Internal (Builder, byteString)
+import qualified Data.ByteString.Builder.Prim as P
+import qualified Data.ByteString.Builder.Prim.Internal as P
+
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Monoid
+import Control.Applicative ((<$>))
+#endif
+
+import Foreign.C.Types (CFloat, CDouble, CInt, CUInt, CULong, CUChar)
+
+#if MIN_VERSION_base(4,5,0) || __GLASGOW_HASKELL__ >= 703
+import Foreign.C.Types (CFloat(..), CDouble(..), CInt(..), CUInt(..), CULong(..), CUChar(..))
+#else
+import Foreign.C.Types (CFloat, CDouble, CInt, CUInt, CULong, CUChar)
+#endif
+
+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr (Ptr, plusPtr)
+import Foreign.Storable (peek)
+import GHC.Word (Word8, Word32, Word64(..))
+import GHC.Int (Int32)
+import GHC.Float (FFFormat(..), roundTo)
+import GHC.Prim
+import GHC.Show (intToDigit)
+
+#if MIN_VERSION_base(4,4,0)
+import System.IO.Unsafe (unsafeDupablePerformIO)
+#else
+import           GHC.IO (unsafeDupablePerformIO)
+#endif
+
+{-# INLINABLE floatDec #-}
+floatDec :: Float -> Builder
+floatDec = formatFloat FFGeneric Nothing
+
+{-# INLINABLE doubleDec #-}
+doubleDec :: Double -> Builder
+doubleDec = formatDouble FFGeneric Nothing
+
+{-# INLINABLE formatFloat #-}
+formatFloat :: FFFormat -> Maybe Int -> Float -> Builder
+formatFloat fmt prec f =
+  case fmt of
+      FFGeneric ->
+        case specialStr f of
+          Just b -> b
+          Nothing ->
+            if e' >= 0 && e' <= 7
+               then sign f `mappend` showFixed (fromIntegral m) e' prec
+               else P.primBounded (ryu_f2s_to_chars m e (f < 0)) ()
+        where (FD32 m e) = ryu_f2s_fd f
+              e' = fromIntegral e + decimalLength9 m
+      FFExponent -> P.primBounded ryu_f2s f
+      FFFixed -> ryu_d2fixed (realToFrac f) prec
+
+{-# INLINABLE formatDouble #-}
+formatDouble :: FFFormat -> Maybe Int -> Double -> Builder
+formatDouble fmt prec f =
+  case fmt of
+      FFGeneric ->
+        case specialStr f of
+          Just b -> b
+          Nothing ->
+            if e' >= 0 && e' <= 7
+               then sign f `mappend` showFixed m e' prec
+               else P.primBounded (ryu_d2s_to_chars m e (f < 0)) ()
+        where (FD64 m e) = ryu_d2s_fd f
+              e' = fromIntegral e + decimalLength17 m
+      FFExponent -> P.primBounded ryu_d2s f
+      FFFixed -> ryu_d2fixed f prec
+
+
+-- C calls and wrappers
+foreign import ccall unsafe "static f2s_buffered_n"
+    c_ryu_f2s :: CFloat -> Ptr Word8 -> IO CInt
+
+foreign import ccall unsafe "static d2s_buffered_n"
+    c_ryu_d2s :: CDouble -> Ptr Word8 -> IO CInt
+
+foreign import ccall unsafe "static f2s_floating_decimal"
+    c_ryu_f2s_fd :: CFloat -> Ptr Word32 -> Ptr Int32 -> IO ()
+
+foreign import ccall unsafe "static d2s_floating_decimal"
+    c_ryu_d2s_fd :: CDouble -> Ptr Word64 -> Ptr Int32 -> IO ()
+
+foreign import ccall unsafe "static f2s_to_chars"
+    c_ryu_f2s_to_chars :: CUInt -> CInt -> CUChar -> Ptr Word8 -> IO CInt
+
+foreign import ccall unsafe "static d2s_to_chars"
+    c_ryu_d2s_to_chars :: CULong -> CInt -> CUChar -> Ptr Word8 -> IO CInt
+
+#include "ryu.h"
+
+{-# INLINABLE f2s_max_digits #-}
+f2s_max_digits :: Int
+f2s_max_digits = #const F2S_MAX_DIGITS
+
+{-# INLINABLE d2s_max_digits #-}
+d2s_max_digits :: Int
+d2s_max_digits = #const D2S_MAX_DIGITS
+
+{-# INLINE ryu_f2s #-}
+ryu_f2s :: P.BoundedPrim Float
+ryu_f2s = P.boundedPrim f2s_max_digits $ \f p -> do
+  plusPtr p . fromIntegral <$> c_ryu_f2s (realToFrac f) p
+
+{-# INLINE ryu_d2s #-}
+ryu_d2s :: P.BoundedPrim Double
+ryu_d2s = P.boundedPrim d2s_max_digits $ \f p -> do
+  plusPtr p . fromIntegral <$> c_ryu_d2s (realToFrac f) p
+
+data FloatingDecimal64 = FD64 !Word64 !Int32
+data FloatingDecimal32 = FD32 !Word32 !Int32
+
+instance Show FloatingDecimal64 where
+  showsPrec p (FD64 m e) = showsPrec p m `mappend` showsPrec p '.' `mappend` showsPrec p e
+
+instance Show FloatingDecimal32 where
+  showsPrec p (FD32 m e) = showsPrec p m `mappend` showsPrec p '.' `mappend` showsPrec p e
+
+-- extracts base-10 converted mantissa and exponent for floats using ryu
+-- algorithm
+-- NB: only valid if not NaN, +/-0, or +/-Inf. In practice, all calls should
+--     guarded by `specialStr`
+{-# INLINE ryu_f2s_fd #-}
+ryu_f2s_fd :: Float -> FloatingDecimal32
+ryu_f2s_fd f = unsafeDupablePerformIO $
+    alloca $ \mOut -> do
+      alloca $ \eOut -> do
+        c_ryu_f2s_fd (realToFrac f) mOut eOut
+        m <- peek mOut
+        e <- peek eOut
+        return $ FD32 m e
+
+-- extracts base-10 converted mantissa and exponent for doubles using ryu
+-- algorithm
+-- NB: only valid if not NaN, +/-0, or +/-Inf. In practice, all calls should
+--     guarded by `specialStr`
+{-# INLINE ryu_d2s_fd #-}
+ryu_d2s_fd :: Double -> FloatingDecimal64
+ryu_d2s_fd f = unsafeDupablePerformIO $
+    alloca $ \mOut -> do
+      alloca $ \eOut -> do
+        c_ryu_d2s_fd (realToFrac f) mOut eOut
+        m <- peek mOut
+        e <- peek eOut
+        return $ FD64 m e
+
+asCBool :: Bool -> CUChar
+asCBool x = if x then 1 else 0
+
+{-# INLINE ryu_f2s_to_chars #-}
+ryu_f2s_to_chars :: Word32 -> Int32 -> Bool -> P.BoundedPrim ()
+ryu_f2s_to_chars m e s = P.boundedPrim f2s_max_digits $ \_ p -> do
+  plusPtr p . fromIntegral <$> c_ryu_f2s_to_chars (fromIntegral m) (fromIntegral e) (asCBool s) p
+
+{-# INLINE ryu_d2s_to_chars #-}
+ryu_d2s_to_chars :: Word64 -> Int32 -> Bool -> P.BoundedPrim ()
+ryu_d2s_to_chars m e s = P.boundedPrim d2s_max_digits $ \_ p -> do
+  plusPtr p . fromIntegral <$> c_ryu_d2s_to_chars (fromIntegral m) (fromIntegral e) (asCBool s) p
+
+
+-- auxiliary fixed format printing functions
+decimalLength9 :: Word32 -> Int
+decimalLength9 v
+  | v >= 100000000 = 9
+  | v >= 10000000 = 8
+  | v >= 1000000 = 7
+  | v >= 100000 = 6
+  | v >= 10000 = 5
+  | v >= 1000 = 4
+  | v >= 100 = 3
+  | v >= 10 = 2
+  | otherwise = 1
+
+decimalLength17 :: Word64 -> Int
+decimalLength17 v
+  | v >= 10000000000000000 = 17
+  | v >= 1000000000000000 = 16
+  | v >= 100000000000000 = 15
+  | v >= 10000000000000 = 14
+  | v >= 1000000000000 = 13
+  | v >= 100000000000 = 12
+  | v >= 10000000000 = 11
+  | v >= 1000000000 = 10
+  | v >= 100000000 = 9
+  | v >= 10000000 = 8
+  | v >= 1000000 = 7
+  | v >= 100000 = 6
+  | v >= 10000 = 5
+  | v >= 1000 = 4
+  | v >= 100 = 3
+  | v >= 10 = 2
+  | otherwise = 1
+
+-- | 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
+
+sign :: RealFloat a => a -> Builder
+sign f = if f < 0 then char7 '-' else mempty
+
+specialStr :: RealFloat a => a -> Maybe Builder
+specialStr f
+  | isNaN f          = Just $ string7 "NaN"
+  | isInfinite f     = Just $ sign f `mappend` string7 "Infinity"
+  | isNegativeZero f = Just $ string7 "-0.0"
+  | f == 0           = Just $ string7 "0.0"
+  | otherwise        = Nothing
+
+-- show fixed floating point matching show / showFFloat output by dropping
+-- digits after exponentiation precision
+ryu_d2fixed :: Double -> Maybe Int -> Builder
+ryu_d2fixed f prec =
+  case specialStr f of
+    Just b -> b
+    Nothing -> sign f `mappend` showFixed m e' prec
+  where (FD64 m e) = ryu_d2s_fd f
+        olength = decimalLength17 m
+        -- NB: exponent in exponential format is e' - 1
+        e' = fromIntegral e + olength
+
+showFixed :: Word64 -> Int -> Maybe Int -> Builder
+showFixed m e prec =
+    case prec of
+       Nothing
+         | e <= 0 -> char7 '0'
+                  `mappend` char7 '.'
+                  `mappend` string7 (replicate (-e) '0')
+                  `mappend` mconcat (digitsToBuilder ds)
+         | otherwise ->
+           let f 0 s     rs = mk0 (reverse s) `mappend` char7 '.' `mappend` mk0 rs
+               f n s     [] = f (n-1) (char7 '0':s) []
+               f n s (r:rs) = f (n-1) (r:s) rs
+            in f e [] (digitsToBuilder ds)
+       Just p
+         | e >= 0 ->
+           let (ei, is') = roundTo 10 (p' + e) ds
+               (ls, rs) = splitAt (e + ei) (digitsToBuilder is')
+            in mk0 ls `mappend` mkDot rs
+         | otherwise ->
+           let (ei, is') = roundTo 10 p' (replicate (-e) 0 ++ ds)
+               (b:bs) = digitsToBuilder (if ei > 0 then is' else 0:is')
+            in b `mappend` mkDot bs
+           where p' = max p 0
+    where
+        mk0 ls = case ls of [] -> char7 '0'; _ -> mconcat ls
+        mkDot rs = if null rs then mempty else char7 '.' `mappend` mconcat rs
+        ds = digits m
+        digitsToBuilder = fmap (char7 . intToDigit)
+
+#if MIN_VERSION_base(4,6,0) && !defined(RYU_32_BIT_PLATFORM)
+dquot10 :: Word## -> Word##
+dquot10 w
+  = let !(## rdx, _ ##) = w `timesWord2##` 0xCCCCCCCCCCCCCCCD####
+     in rdx `uncheckedShiftRL##` 3##
+
+dquotRem10 :: Word## -> (## Word##, Word## ##)
+dquotRem10 w = let w' = dquot10 w
+               in (## w', w `minusWord##` (w' `timesWord##` 10####) ##)
+
+dquotRem10Boxed :: Word64 -> (Word64, Word64)
+dquotRem10Boxed (W64## w) = let !(## q, r ##) = dquotRem10 w in (W64## q, W64## r)
+#else
+dquotRem10Boxed :: Word64 -> (Word64, Word64)
+dquotRem10Boxed w = w `quotRem` 10
+#endif
+
+digits :: Word64 -> [Int]
+digits w = go [] w
+  where go ds 0 = ds
+        go ds c = let (q, r) = dquotRem10Boxed c
+                   in go (fromIntegral r:ds) q

bench/BenchAll.hs

@@ -285,7 +285,9 @@ main = do
         [ benchB "byteStringHex"           byteStringData     $ byteStringHex
         , benchB "lazyByteStringHex"       lazyByteStringData $ lazyByteStringHex
         , benchB "foldMap floatDec"        floatData          $ foldMap floatDec
+        , benchB "foldMap show float"      floatData          $ foldMap (string7 . show)
         , benchB "foldMap doubleDec"       doubleData         $ foldMap doubleDec
+        , benchB "foldMap show double"     doubleData         $ foldMap (string7 . show)
           -- Note that the small data corresponds to the intData pre-converted
           -- to Integer.
         , benchB "foldMap integerDec (small)"                     smallIntegerData        $ foldMap integerDec

bench/bench-bytestring.cabal

@@ -58,6 +58,7 @@ benchmark bench-bytestring-builder
         Data.ByteString.Builder.Prim.Internal.Base16
         Data.ByteString.Builder.Prim.Internal.Floating
         Data.ByteString.Builder.Prim.Internal.UncheckedShifts
+        Data.ByteString.Builder.RealFloat
         Data.ByteString.Internal
         Data.ByteString.Lazy
         Data.ByteString.Lazy.Internal
@@ -69,7 +70,10 @@ benchmark bench-bytestring-builder
   -- which probably don't work on windows.
   c-sources:         ../cbits/fpstring.c
                      ../cbits/itoa.c
+                     ../cbits/ftoa.c
+                     ../cbits/dtoa.c
   include-dirs:      ../include
+                     ../cbits
   includes:          fpstring.h
   install-includes:  fpstring.h
 
@@ -153,7 +157,10 @@ benchmark bench-builder-boundscheck
                     gauge
   c-sources:        ../cbits/fpstring.c
                     ../cbits/itoa.c
+                    ../cbits/ftoa.c
+                    ../cbits/dtoa.c
   include-dirs:     ../include
+                    ../cbits
   ghc-options:      -O2
                     -fmax-simplifier-iterations=10
                     -fdicts-cheap
@@ -172,6 +179,7 @@ benchmark bench-builder-boundscheck
         Data.ByteString.Builder.Prim.Internal.Base16
         Data.ByteString.Builder.Prim.Internal.Floating
         Data.ByteString.Builder.Prim.Internal.UncheckedShifts
+        Data.ByteString.Builder.RealFloat
         Data.ByteString.Internal
         Data.ByteString.Lazy
         Data.ByteString.Lazy.Internal