Permalink
Browse files

Improve Double encoding performance by a further 5%

  • Loading branch information...
1 parent 5cf7460 commit 53cc0101b8b7895a5e5bcffc1a899184047d3f87 @bos bos committed Mar 22, 2011
Showing with 103 additions and 80 deletions.
  1. +99 −76 Data/Aeson/Encode/Double.hs
  2. +1 −1 Data/Aeson/Encode/Int.hs
  3. +3 −3 Data/Aeson/Encode/Number.hs
View
@@ -14,86 +14,109 @@ module Data.Aeson.Encode.Double
double
) where
-import GHC.Float
-
+import Blaze.ByteString.Builder (Builder, fromByteString)
+import Blaze.ByteString.Builder.Char8 (fromChar)
+import Data.Aeson.Encode.Int (digit, int, minus)
import Data.ByteString.Char8 ()
-import Data.Monoid
-import Data.Aeson.Encode.Int
-import Blaze.ByteString.Builder
-import Blaze.ByteString.Builder.Char8
+import Data.Monoid (mappend, mconcat, mempty)
+import qualified Data.Vector as V
-double :: Double -> Builder
-double = showpGFloat Nothing
+-- The code below is originally from GHC.Float, but has been optimised
+-- in quite a few ways.
--- | Show a signed RealFloat value using decimal notation when the
--- absolute value lies between 0.1 and 9,999,999, and scientific
--- notation otherwise. The optional integer can be used to specify
--- precision.
-showpGFloat :: RealFloat a => Maybe Int -> a -> Builder
-showpGFloat = putFormattedFloat FFGeneric
+data T = T [Int] {-# UNPACK #-} !Int
--- | Show a signed RealFloat value using decimal notation. The optional
--- integer can be used to specify precision.
-showpFFloat :: RealFloat a => Maybe Int -> a -> Builder
-showpFFloat = putFormattedFloat FFFixed
+double :: Double -> Builder
+double f
+ | isNaN f = fromByteString "NaN"
+ | isInfinite f = fromByteString $
+ if f < 0 then "-Infinity" else "Infinity"
+ | f < 0 || isNegativeZero f = minus `mappend` goGeneric (floatToDigits (-f))
+ | otherwise = goGeneric (floatToDigits f)
+ where
+ goGeneric p@(T _ e)
+ | e < 0 || e > 7 = goExponent p
+ | otherwise = goFixed p
+ goExponent (T is e) =
+ case is of
+ [] -> error "putFormattedFloat"
+ [0] -> fromByteString "0.0e0"
+ [d] -> digit d `mappend` fromByteString ".0e" `mappend` int (e-1)
+ (d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend`
+ fromChar 'e' `mappend` int (e-1)
+ goFixed (T is e)
+ | e <= 0 = fromChar '0' `mappend` fromChar '.' `mappend`
+ mconcat (replicate (-e) (fromChar '0')) `mappend`
+ digits is
+ | otherwise = let g 0 rs = fromChar '.' `mappend` mk0 rs
+ g n [] = fromChar '0' `mappend` g (n-1) []
+ g n (r:rs) = digit r `mappend` g (n-1) rs
+ in g e is
+ mk0 [] = fromChar '0'
+ mk0 rs = digits rs
--- | Show a signed RealFloat value using scientific (exponential) notation.
--- The optional integer can be used to specify precision.
-showpEFloat :: RealFloat a => Maybe Int -> a -> Builder
-showpEFloat = putFormattedFloat FFExponent
+digits :: [Int] -> Builder
+digits (d:ds) = digit d `mappend` digits ds
+digits _ = mempty
+{-# INLINE digits #-}
-putFormattedFloat :: RealFloat a => FFFormat -> Maybe Int -> a -> Builder
-putFormattedFloat fmt decs f
- | isNaN f = fromChar 'N' `mappend` fromChar 'a' `mappend` fromChar 'N'
- | isInfinite f = fromByteString (if f < 0 then "-Infinity" else "Infinity")
- | f < 0 || isNegativeZero f = fromChar '-' `mappend` go fmt (floatToDigits (toInteger base) (-f))
- | otherwise = go fmt (floatToDigits (toInteger base) f)
+floatToDigits :: Double -> T
+floatToDigits 0 = T [0] 0
+floatToDigits x = T (reverse rds) k
where
- base = 10
-
- go FFGeneric p@(_,e)
- | e < 0 || e > 7 = go FFExponent p
- | otherwise = go FFFixed p
- go FFExponent (is, e) =
- case decs of
- Nothing -> case is of
- [] -> error "putFormattedFloat"
- [0] -> fromByteString "0.0e0"
- [d] -> digit d `mappend` fromByteString ".0e" `mappend` int (e-1)
- (d:ds) -> digit d `mappend` fromChar '.' `mappend` mconcat (map digit ds)
- `mappend` fromChar 'e' `mappend` int (e-1)
- Just dec ->
- let dec' = max dec 1 in
- case is of
- [0] -> fromChar '0' `mappend` fromChar '.' `mappend` mconcat (replicate dec' (fromChar '0'))
- `mappend` fromChar 'e' `mappend` fromChar '0'
- _ ->
- let (ei, is') = roundTo base (dec'+1) is
- (d:ds) = if ei > 0 then init is' else is'
- in digit d `mappend` fromChar '.' `mappend` mconcat (map digit ds)
- `mappend` fromChar 'e' `mappend` int (e - 1 + ei)
- go FFFixed (is, e) = case decs of
- Nothing
- | e <= 0 -> fromChar '0' `mappend` fromChar '.' `mappend` mconcat (replicate (-e) (fromChar '0'))
- `mappend` mconcat (map digit is)
- | otherwise -> let g 0 rs = fromChar '.' `mappend` mk0 rs
- g n [] = fromChar '0' `mappend` g (n-1) []
- g n (r:rs) = digit r `mappend` g (n-1) rs
- in g e is
- Just dec ->
- let dec' = max dec 0 in
- if e >= 0 then
- let (ei, is') = roundTo base (dec' + e) is
- (ls,rs) = splitAt (e+ei) is'
- in if null ls
- then mk0 ls
- else mk0 ls `mappend` (fromChar '.' `mappend` mconcat (map digit rs))
- else
- let (ei, is') = roundTo base dec' (replicate (-e) 0 ++ is)
- d:ds = if ei > 0 then is' else 0:is'
- in if null ds
- then digit d
- else digit d `mappend` (fromChar '.' `mappend` mconcat (map digit ds))
-
- mk0 [] = fromChar '0'
- mk0 rs = mconcat (map digit rs)
+ (f0, e0) = decodeFloat x
+ (minExp0, _) = floatRange (undefined::Double)
+ p = floatDigits x
+ b = floatRadix x
+ minExp = minExp0 - p -- the real minimum exponent
+ -- Haskell requires that f be adjusted so denormalized numbers
+ -- will have an impossibly low exponent. Adjust for this.
+ (# f, e #) =
+ let n = minExp - e0 in
+ if n > 0 then (# f0 `div` (b^n), e0+n #) else (# f0, e0 #)
+ (# r, s, mUp, mDn #) =
+ if e >= 0
+ then let be = b^ e
+ in if f == b^(p-1)
+ then (# f*be*b*2, 2*b, be*b, b #)
+ else (# f*be*2, 2, be, be #)
+ else if e > minExp && f == b^(p-1)
+ then (# f*b*2, b^(-e+1)*2, b, 1 #)
+ else (# f*2, b^(-e)*2, 1, 1 #)
+ k = fixup k0
+ where
+ k0 | b == 2 = (p - 1 + e0) * 3 `div` 10
+ -- logBase 10 2 is slightly bigger than 3/10 so the following
+ -- will err on the low side. Ignoring the fraction will make
+ -- it err even more. Haskell promises that p-1 <= logBase b f
+ -- < p.
+ | otherwise = ceiling ((log (fromInteger (f+1) :: Double) +
+ fromIntegral e * log (fromInteger b)) / log 10)
+ fixup n
+ | n >= 0 = if r + mUp <= exp10 n * s then n else fixup (n+1)
+ | otherwise = if exp10 (-n) * (r + mUp) <= s then n else fixup (n+1)
+
+ gen ds !rn !sN !mUpN !mDnN =
+ let (dn0, rn') = (rn * 10) `divMod` sN
+ mUpN' = mUpN * 10
+ mDnN' = mDnN * 10
+ !dn = fromInteger dn0
+ !dn' = dn + 1
+ in case (# rn' < mDnN', rn' + mUpN' > sN #) of
+ (# True, False #) -> dn : ds
+ (# False, True #) -> dn' : ds
+ (# True, True #) -> if rn' * 2 < sN then dn : ds else dn' : ds
+ (# False, False #) -> gen (dn:ds) rn' sN mUpN' mDnN'
+
+ rds | k >= 0 = gen [] r (s * exp10 k) mUp mDn
+ | otherwise = gen [] (r * bk) s (mUp * bk) (mDn * bk)
+ where bk = exp10 (-k)
+
+exp10 :: Int -> Integer
+exp10 n
+ | n >= 0 && n < maxExpt = V.unsafeIndex expts n
+ | otherwise = 10 ^ n
+ where expts = V.generate maxExpt (10^)
+ {-# NOINLINE expts #-}
+ maxExpt = 17
+{-# INLINE exp10 #-}
View
@@ -16,7 +16,7 @@ module Data.Aeson.Encode.Int
, minus
) where
-import Blaze.ByteString.Builder
+import Blaze.ByteString.Builder (Builder, fromWord8)
import Data.Monoid (mappend)
int :: Int -> Builder
@@ -19,9 +19,9 @@ import Data.Attoparsec.Number (Number(..))
import Data.Aeson.Encode.Double
import Data.Aeson.Encode.Int
import Blaze.ByteString.Builder
+import GHC.Base (quotInt, remInt)
import GHC.Num (quotRemInteger)
import GHC.Types (Int(..))
-import qualified Text.Show.ByteString as S
#ifdef __GLASGOW_HASKELL__
# if __GLASGOW_HASKELL__ < 611
@@ -96,5 +96,5 @@ pblock = go maxDigits
go !d !n
| d == 1 = digit n
| otherwise = go (d-1) q `mappend` digit r
- where q = n `quot` 10
- r = n `rem` 10
+ where q = n `quotInt` 10
+ r = n `remInt` 10

0 comments on commit 53cc010

Please sign in to comment.