Commits

Bryan O'Sullivan committed 0086277

Improve Double encoding performance by a further 5%

Comments (0)

Files changed (3)

Data/Aeson/Encode/Double.hs

       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 (mappend, mconcat, mempty)
+import qualified Data.Vector as V
 
-import Data.ByteString.Char8 ()
-import Data.Monoid
-import Data.Aeson.Encode.Int
-import Blaze.ByteString.Builder
-import Blaze.ByteString.Builder.Char8
+-- The code below is originally from GHC.Float, but has been optimised
+-- in quite a few ways.
+
+data T = T [Int] {-# UNPACK #-} !Int
 
 double :: Double -> Builder
-double = showpGFloat Nothing
+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 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
+digits :: [Int] -> Builder
+digits (d:ds) = digit d `mappend` digits ds
+digits _      = mempty
+{-# INLINE digits #-}
 
--- | 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
+floatToDigits :: Double -> T
+floatToDigits 0 = T [0] 0
+floatToDigits x = T (reverse rds) k
+ where
+  (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)
 
--- | 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
+  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'
 
-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)
- 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)
+  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 #-}

Data/Aeson/Encode/Int.hs

     , minus
     ) where
 
-import Blaze.ByteString.Builder
+import Blaze.ByteString.Builder (Builder, fromWord8)
 import Data.Monoid (mappend)
 
 int :: Int -> Builder

Data/Aeson/Encode/Number.hs

 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
     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