Skip to content

Commit

Permalink
Improve Double encoding performance by a further 5%
Browse files Browse the repository at this point in the history
  • Loading branch information
@bos
bos committed Mar 22, 2011
1 parent 5cf7460 commit 53cc010
Show file tree
Hide file tree
Showing 3 changed files with 103 additions and 80 deletions.
175 changes: 99 additions & 76 deletions Data/Aeson/Encode/Double.hs
View file
Expand Up @@ -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 #-}
2 changes: 1 addition & 1 deletion Data/Aeson/Encode/Int.hs
View file
Expand Up @@ -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
Expand Down
6 changes: 3 additions & 3 deletions Data/Aeson/Encode/Number.hs
View file
Expand Up @@ -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
Expand Down Expand Up @@ -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.