Overhaul realfloat

Data/ByteString/Builder/RealFloat.hs

@@ -1,3 +1,13 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE NamedFieldPuns #-}
 -- |
 -- Module      : Data.ByteString.Builder.RealFloat
 -- Copyright   : (c) Lawrence Wu 2021
@@ -72,12 +82,18 @@
 
 import Data.ByteString.Builder.Internal (Builder)
 import qualified Data.ByteString.Builder.RealFloat.Internal as R
+import Data.ByteString.Builder.RealFloat.Internal (FloatFormat(..), fScientific, fGeneric)
+import Data.ByteString.Builder.RealFloat.Internal (positiveZero, negativeZero)
 import qualified Data.ByteString.Builder.RealFloat.F2S as RF
 import qualified Data.ByteString.Builder.RealFloat.D2S as RD
 import qualified Data.ByteString.Builder.Prim as BP
 import GHC.Float (roundTo)
-import GHC.Word (Word64)
+import GHC.Word (Word32, Word64)
 import GHC.Show (intToDigit)
+import Data.Bits (Bits)
+import Data.Proxy (Proxy(Proxy))
+import Data.Maybe (fromMaybe)
+import Data.Monoid ((<>))
 
 -- | Returns a rendered Float. Matches `show` in displaying in standard or
 -- scientific notation
@@ -87,7 +103,7 @@
 -- @
 {-# INLINABLE floatDec #-}
 floatDec :: Float -> Builder
-floatDec = formatFloat generic
+floatDec = formatFloating generic
 
 -- | Returns a rendered Double. Matches `show` in displaying in standard or
 -- scientific notation
@@ -97,43 +113,55 @@
 -- @
 {-# INLINABLE doubleDec #-}
 doubleDec :: Double -> Builder
-doubleDec = formatDouble generic
-
--- | Format type for use with `formatFloat` and `formatDouble`.
---
--- @since 0.11.2.0
-data FloatFormat = MkFloatFormat FormatMode (Maybe Int)
+doubleDec = formatFloating generic
 
 -- | Standard notation with `n` decimal places
 --
 -- @since 0.11.2.0
 standard :: Int -> FloatFormat
-standard n = MkFloatFormat FStandard (Just n)
+standard n = FStandard
+  { precision = Just n
+  , specials = standardSpecialStrings {positiveZero, negativeZero}
+  }
+  where
+  positiveZero = if n == 0
+    then "0"
+    else "0." <> replicate n '0'
+  negativeZero = "-" <> positiveZero
 
 -- | Standard notation with the \'default precision\' (decimal places matching `show`)
 --
 -- @since 0.11.2.0
 standardDefaultPrecision :: FloatFormat
-standardDefaultPrecision = MkFloatFormat FStandard Nothing
+standardDefaultPrecision = FStandard
+  { precision = Nothing
+  , specials = standardSpecialStrings
+  }
 
 -- | Scientific notation with \'default precision\' (decimal places matching `show`)
 --
 -- @since 0.11.2.0
 scientific :: FloatFormat
-scientific = MkFloatFormat FScientific Nothing
+scientific = fScientific 'e' scientificSpecialStrings
+
+scientificSpecialStrings, standardSpecialStrings :: R.SpecialStrings
+scientificSpecialStrings = R.SpecialStrings
+  { R.nan = "NaN"
+  , R.positiveInfinity = "Infinity"
+  , R.negativeInfinity = "-Infinity"
+  , R.positiveZero = "0.0e0"
+  , R.negativeZero = "-0.0e0"
+  }
+standardSpecialStrings = scientificSpecialStrings
+  { R.positiveZero = "0.0"
+  , R.negativeZero = "-0.0"
+  }
 
 -- | Standard or scientific notation depending on the exponent. Matches `show`
 --
 -- @since 0.11.2.0
 generic :: FloatFormat
-generic = MkFloatFormat FGeneric Nothing
-
--- | ByteString float-to-string format
-data FormatMode
-  = FScientific     -- ^ scientific notation
-  | FStandard       -- ^ standard notation with `Maybe Int` digits after the decimal
-  | FGeneric        -- ^ dispatches to scientific or standard notation based on the exponent
-  deriving Show
+generic = fGeneric 'e' Nothing (0,7) standardSpecialStrings
 
 -- TODO: support precision argument for FGeneric and FScientific
 -- | Returns a rendered Float. Returns the \'shortest\' representation in
@@ -161,22 +189,7 @@
 -- @since 0.11.2.0
 {-# INLINABLE formatFloat #-}
 formatFloat :: FloatFormat -> Float -> Builder
-formatFloat (MkFloatFormat fmt prec) = \f ->
-  let (RF.FloatingDecimal m e) = RF.f2Intermediate f
-      e' = R.int32ToInt e + R.decimalLength9 m in
-  case fmt of
-    FGeneric ->
-      case specialStr f of
-        Just b -> b
-        Nothing ->
-          if e' >= 0 && e' <= 7
-             then sign f `mappend` showStandard (R.word32ToWord64 m) e' prec
-             else BP.primBounded (R.toCharsScientific (f < 0) m e) ()
-    FScientific -> RF.f2s f
-    FStandard ->
-      case specialStr f of
-        Just b -> b
-        Nothing -> sign f `mappend` showStandard (R.word32ToWord64 m) e' prec
+formatFloat = formatFloating
 
 -- TODO: support precision argument for FGeneric and FScientific
 -- | Returns a rendered Double. Returns the \'shortest\' representation in
@@ -204,46 +217,65 @@
 -- @since 0.11.2.0
 {-# INLINABLE formatDouble #-}
 formatDouble :: FloatFormat -> Double -> Builder
-formatDouble (MkFloatFormat fmt prec) = \f ->
-  let (RD.FloatingDecimal m e) = RD.d2Intermediate f
-      e' = R.int32ToInt e + R.decimalLength17 m in
-  case fmt of
-    FGeneric ->
-      case specialStr f of
-        Just b -> b
-        Nothing ->
-          if e' >= 0 && e' <= 7
-             then sign f `mappend` showStandard m e' prec
-             else BP.primBounded (R.toCharsScientific (f < 0) m e) ()
-    FScientific -> RD.d2s f
-    FStandard ->
-      case specialStr f of
-        Just b -> b
-        Nothing -> sign f `mappend` showStandard m e' prec
+formatDouble = formatFloating
+
+{-# INLINABLE formatFloating #-}
+{-# SPECIALIZE formatFloating :: FloatFormat -> Float -> Builder #-}
+{-# SPECIALIZE formatFloating :: FloatFormat -> Double -> Builder #-}
+formatFloating :: forall a mw ew ei.
+  -- a
+  --( ToS a
+  ( ToD a
+  , RealFloat a
+  , R.ExponentBits a
+  , R.MantissaBits a
+  , R.CastToWord a
+  , R.MaxEncodedLength a
+  -- mantissa
+  , mw ~ R.MantissaWord a
+  , R.Mantissa mw
+  , ToWord64 mw
+  , R.DecimalLength mw
+  -- exponent
+  , ew ~ R.ExponentWord a
+  , Integral ew
+  , Bits ew
+  , ei ~ R.ExponentInt a
+  , R.ToInt ei
+  , Integral ei
+  , R.FromInt ei
+  ) => FloatFormat -> a -> Builder
+formatFloating fmt f = case fmt of
+  FGeneric {stdExpoRange = (minExpo,maxExpo), ..} -> specialsOr specials
+    if e' >= minExpo && e' <= maxExpo
+       then std precision
+       else sci eE
+  FScientific {..} -> specialsOr specials $ sci eE
+  FStandard {..} -> specialsOr specials $ std precision
+  where
+  sci eE = BP.primBounded (R.toCharsScientific @a Proxy eE sign m e) ()
+  std precision = printSign f <> showStandard (toWord64 m) e' precision
+  e' = R.toInt e + R.decimalLength m
+  R.FloatingDecimal m e = toD @a mantissa expo
+  (sign, mantissa, expo) = R.breakdown f
+  specialsOr specials = flip fromMaybe $ R.toCharsNonNumbersAndZero specials f
+
+class ToWord64 a where toWord64 :: a -> Word64
+instance ToWord64 Word32 where toWord64 = R.word32ToWord64
+instance ToWord64 Word64 where toWord64 = id
+
+class ToD a where toD :: R.MantissaWord a -> R.ExponentWord a -> R.FloatingDecimal a
+instance ToD Float where toD = RF.f2d
+instance ToD Double where toD = RD.d2d
 
 -- | Char7 encode a 'Char'.
 {-# INLINE char7 #-}
 char7 :: Char -> Builder
 char7 = BP.primFixed BP.char7
 
--- | Char7 encode a 'String'.
-{-# INLINE string7 #-}
-string7 :: String -> Builder
-string7 = BP.primMapListFixed BP.char7
-
 -- | Encodes a `-` if input is negative
-sign :: RealFloat a => a -> Builder
-sign f = if f < 0 then char7 '-' else mempty
-
--- | Special rendering for Nan, Infinity, and 0. See
--- RealFloat.Internal.NonNumbersAndZero
-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
+printSign :: RealFloat a => a -> Builder
+printSign f = if f < 0 then char7 '-' else mempty
 
 -- | Returns a list of decimal digits in a Word64
 digits :: Word64 -> [Int]
@@ -259,7 +291,7 @@
     Nothing
       | e <= 0 -> char7 '0'
                `mappend` char7 '.'
-               `mappend` string7 (replicate (-e) '0')
+               `mappend` R.string7 (replicate (-e) '0')
                `mappend` mconcat (digitsToBuilder ds)
       | otherwise ->
           let f 0 s     rs = mk0 (reverse s) `mappend` char7 '.' `mappend` mk0 rs

Data/ByteString/Builder/RealFloat/D2S.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NamedFieldPuns #-}
 -- |
 -- Module      : Data.ByteString.Builder.RealFloat.D2S
 -- Copyright   : (c) Lawrence Wu 2021
@@ -10,15 +12,11 @@
 -- Implementation of double-to-string conversion
 
 module Data.ByteString.Builder.RealFloat.D2S
-    ( FloatingDecimal(..)
-    , d2s
-    , d2Intermediate
+    ( d2d
     ) where
 
 import Control.Arrow (first)
 import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR)
-import Data.ByteString.Builder.Internal (Builder)
-import Data.ByteString.Builder.Prim (primBounded)
 import Data.ByteString.Builder.RealFloat.Internal
 import Data.Maybe (fromMaybe)
 import GHC.Int (Int32(..))
@@ -40,27 +38,17 @@ foreign import ccall "&hs_bytestring_double_pow5_inv_split"
 foreign import ccall "&hs_bytestring_double_pow5_split"
   double_pow5_split :: Ptr Word64
 
--- | Number of mantissa bits of a 64-bit float. The number of significant bits
--- (floatDigits (undefined :: Double)) is 53 since we have a leading 1 for
--- normal floats and 0 for subnormal floats
 double_mantissa_bits :: Int
-double_mantissa_bits = 52
-
--- | Number of exponent bits of a 64-bit float
-double_exponent_bits :: Int
-double_exponent_bits = 11
+double_mantissa_bits = mantissaBits @Double
 
 -- | Bias in encoded 64-bit float representation (2^10 - 1)
 double_bias :: Int
 double_bias = 1023
 
-data FloatingDecimal = FloatingDecimal
-  { dmantissa :: !Word64
-  , dexponent :: !Int32
-  } deriving (Show, Eq)
+type FD = FloatingDecimal Double
 
 -- | Quick check for small integers
-d2dSmallInt :: Word64 -> Word64 -> Maybe FloatingDecimal
+d2dSmallInt :: Word64 -> Word64 -> Maybe FD
 d2dSmallInt m e =
   let m2 = (1 `unsafeShiftL` double_mantissa_bits) .|. m
       e2 = word64ToInt e - (double_bias + double_mantissa_bits)
@@ -83,7 +71,7 @@ d2dSmallInt m e =
 
 
 -- | Removes trailing (decimal) zeros for small integers in the range [1, 2^53)
-unifySmallTrailing :: FloatingDecimal -> FloatingDecimal
+unifySmallTrailing :: FD -> FD
 unifySmallTrailing fd@(FloatingDecimal m e) =
   let !(q, r) = dquotRem10 m
    in if r == 0
@@ -170,8 +158,8 @@ d2dLT e2' u v w =
 
 -- | Returns the decimal representation of the given mantissa and exponent of a
 -- 64-bit Double using the ryu algorithm.
-d2d :: Word64 -> Word64 -> FloatingDecimal
-d2d m e =
+d2dGeneral :: Word64 -> Word64 -> FD
+d2dGeneral m e =
   let !mf = if e == 0
               then m
               else (1 `unsafeShiftL` double_mantissa_bits) .|. m
@@ -184,48 +172,20 @@ d2d m e =
       !v = 4 * mf
       !w = 4 * mf + 2
       -- Step 3. convert to decimal power base
-      !(state, e10) =
+      !(state@BoundsState{vvIsTrailingZeros, vuIsTrailingZeros}, e10) =
         if e2 >= 0
            then d2dGT e2 u v w
            else d2dLT e2 u v w
       -- Step 4: Find the shortest decimal representation in the interval of
       -- valid representations.
       !(output, removed) =
         let rounded = closestCorrectlyRounded (acceptBounds v)
-         in first rounded $ if vvIsTrailingZeros state || vuIsTrailingZeros state
+         in first rounded $ if vvIsTrailingZeros || vuIsTrailingZeros
            then trimTrailing state
            else trimNoTrailing state
       !e' = e10 + removed
    in FloatingDecimal output e'
 
--- | Split a Double into (sign, mantissa, exponent)
-breakdown :: Double -> (Bool, Word64, Word64)
-breakdown f =
-  let bits = castDoubleToWord64 f
-      sign = ((bits `unsafeShiftR` (double_mantissa_bits + double_exponent_bits)) .&. 1) /= 0
-      mantissa = bits .&. mask double_mantissa_bits
-      expo = (bits `unsafeShiftR` double_mantissa_bits) .&. mask double_exponent_bits
-   in (sign, mantissa, expo)
-
--- | Dispatches to `d2d` or `d2dSmallInt` and applies the given formatters
-{-# INLINE d2s' #-}
-d2s' :: (Bool -> Word64 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Double -> a
-d2s' formatter specialFormatter d =
-  let (sign, mantissa, expo) = breakdown d
-   in if (expo == mask double_exponent_bits) || (expo == 0 && mantissa == 0)
-         then specialFormatter NonNumbersAndZero
-                  { negative=sign
-                  , exponent_all_one=expo > 0
-                  , mantissa_non_zero=mantissa > 0 }
-         else let v = unifySmallTrailing <$> d2dSmallInt mantissa expo
-                  FloatingDecimal m e = fromMaybe (d2d mantissa expo) v
-               in formatter sign m e
-
--- | Render a Double in scientific notation
-d2s :: Double -> Builder
-d2s d = primBounded (d2s' toCharsScientific toCharsNonNumbersAndZero d) ()
-
--- | Returns the decimal representation of a Double. NaN and Infinity will
--- return `FloatingDecimal 0 0`
-d2Intermediate :: Double -> FloatingDecimal
-d2Intermediate = d2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0)
+-- TODO: Determine if this actually speeds things up. The benchmarks may not run many numbers in this range.
+d2d :: Word64 -> Word64 -> FD
+d2d mantissa expo = fromMaybe (d2dGeneral mantissa expo) $ unifySmallTrailing <$> d2dSmallInt mantissa expo