Skip to content
Browse files

Add a "-fnative" option to build with native double conversion code.

This is slower than the double-conversion package by a factor of 10, but
it doesn't have double-conversion's problems with GHCi.

--HG--
rename : Blaze/Text/Double.hs => Blaze/Text/Double/Native.hs
  • Loading branch information...
2 parents 9b87e98 + 9b1400a commit 9d770bddf5782c31b28adb5e14831800aa206044 @bos committed Aug 6, 2011
Showing with 144 additions and 1 deletion.
  1. +6 −0 Blaze/Text/Double.hs
  2. +124 −0 Blaze/Text/Double/Native.hs
  3. +14 −1 blaze-textual.cabal
View
6 Blaze/Text/Double.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
-- Module: Blaze.Text.Double
-- Copyright: (c) 2011 MailRank, Inc.
-- License: BSD3
@@ -13,6 +15,9 @@ module Blaze.Text.Double
, double
) where
+#ifdef NATIVE
+import Blaze.Text.Double.Native
+#else
import Blaze.ByteString.Builder (Builder, fromByteString)
import Data.Double.Conversion.ByteString (toShortest)
@@ -21,3 +26,4 @@ float = double . realToFrac
double :: Double -> Builder
double f = fromByteString (toShortest f)
+#endif
View
124 Blaze/Text/Double/Native.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-}
+
+-- Module: Blaze.Text.Double.Native
+-- Copyright: (c) 2011 MailRank, Inc.
+-- License: BSD3
+-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>
+-- Stability: experimental
+-- Portability: portable
+--
+-- Efficiently serialize a Double as a lazy 'L.ByteString'.
+
+module Blaze.Text.Double.Native
+ (
+ float
+ , double
+ ) where
+
+import Blaze.ByteString.Builder (Builder, fromByteString)
+import Blaze.ByteString.Builder.Char8 (fromChar)
+import Blaze.Text.Int (digit, integral, minus)
+import Data.ByteString.Char8 ()
+import Data.Monoid (mappend, mconcat, mempty)
+import qualified Data.Vector as V
+
+-- The code below is originally from GHC.Float, but has been optimised
+-- in quite a few ways.
+
+data T = T [Int] {-# UNPACK #-} !Int
+
+float :: Float -> Builder
+float = double . realToFrac
+
+double :: Double -> Builder
+double f
+ | isNaN f || isInfinite f = fromByteString "null"
+ | 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` integral (e-1)
+ (d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend`
+ fromChar 'e' `mappend` integral (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
+
+digits :: [Int] -> Builder
+digits (d:ds) = digit d `mappend` digits ds
+digits _ = mempty
+{-# INLINE digits #-}
+
+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)
+
+ 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
15 blaze-textual.cabal
@@ -23,27 +23,40 @@ flag developer
description: operate in developer mode
default: False
+flag native
+ description: use slow native code for double conversion
+ default: False
+
library
exposed-modules:
Blaze.Text
Blaze.Text.Double
Blaze.Text.Int
+ if flag(native)
+ other-modules: Blaze.Text.Double.Native
+
build-depends:
base == 4.*,
blaze-builder >= 0.2.1.4,
bytestring,
- double-conversion >= 0.2.0.1,
ghc-prim,
old-locale,
text >= 0.11.0.2,
time,
vector
+ if !flag(native)
+ build-depends:
+ double-conversion >= 0.2.0.1
+
if flag(developer)
ghc-options: -Werror
ghc-prof-options: -auto-all
+ if flag(native)
+ cpp-options: -DNATIVE
+
ghc-options: -Wall
if impl(ghc >= 6.11)

0 comments on commit 9d770bd

Please sign in to comment.
Something went wrong with that request. Please try again.