From 332bcf61d6477fade6168779a36b59982252ea40 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Mon, 8 Jan 2024 20:27:16 -0500 Subject: [PATCH 01/34] improved RealFloat benchmarks --- bench/BenchAll.hs | 162 +++++++++++++++++++++++++++++++++++++++++++--- bytestring.cabal | 3 +- 2 files changed, 155 insertions(+), 10 deletions(-) diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index 3daa09463..1783839e6 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -11,6 +11,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} module Main (main) where @@ -20,6 +21,12 @@ import Data.Semigroup import Data.String import Test.Tasty.Bench import Prelude hiding (words) +import Numeric.IEEE +import GHC.Float (powerFloat, + castWord32ToFloat, + castWord64ToDouble, + castFloatToWord32, + castDoubleToWord64) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -65,7 +72,7 @@ countToZero n = Just (n, n - 1) -- | Few-enough repetitions to avoid making GC too expensive. nRepl :: Int -nRepl = 10000 +nRepl = 1000000 {-# NOINLINE intData #-} intData :: [Int] @@ -79,14 +86,69 @@ smallIntegerData = map fromIntegral intData largeIntegerData :: [Integer] largeIntegerData = map (* (10 ^ (100 :: Integer))) smallIntegerData +{-# NOINLINE floatPosData #-} +floatPosData :: [Float] +floatPosData = map evenlyDistribute intData + where + evenlyDistribute :: Int -> Float + evenlyDistribute x = castWord32ToFloat $ increment * fromIntegral x + increment = castFloatToWord32 maxFinite `div` fromIntegral nRepl + +{-# NOINLINE floatNegData #-} +floatNegData :: [Float] +floatNegData = map negate floatPosData + +{-# NOINLINE floatNaN #-} +floatNaN :: [Float] +floatNaN = map (const nan) intData + +{-# NOINLINE floatPosInf #-} +floatPosInf :: [Float] +floatPosInf = map (const infinity) intData + +{-# NOINLINE floatNegInf #-} +floatNegInf :: [Float] +floatNegInf = map (const (negate infinity)) intData + +{-# NOINLINE floatPosZero #-} +floatPosZero :: [Float] +floatPosZero = map (const 0) intData + +{-# NOINLINE floatNegZero #-} +floatNegZero :: [Float] +floatNegZero = map (const (-0)) intData + +{-# NOINLINE doublePosData #-} +doublePosData :: [Double] +doublePosData = map evenlyDistribute intData + where + evenlyDistribute :: Int -> Double + evenlyDistribute x = castWord64ToDouble $ increment * fromIntegral x + increment = castDoubleToWord64 maxFinite `div` fromIntegral nRepl + +{-# NOINLINE doubleNegData #-} +doubleNegData :: [Double] +doubleNegData = map negate doublePosData + +{-# NOINLINE doubleNaN #-} +doubleNaN :: [Double] +doubleNaN = map (const nan) intData + +{-# NOINLINE doublePosInf #-} +doublePosInf :: [Double] +doublePosInf = map (const infinity) intData -{-# NOINLINE floatData #-} -floatData :: [Float] -floatData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData +{-# NOINLINE doubleNegInf #-} +doubleNegInf :: [Double] +doubleNegInf = map (const (negate infinity)) intData -{-# NOINLINE doubleData #-} -doubleData :: [Double] -doubleData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData +{-# NOINLINE doublePosZero #-} +doublePosZero :: [Double] +doublePosZero = map (const 0) intData + +{-# NOINLINE doubleNegZero #-} +doubleNegZero :: [Double] +doubleNegZero = map (const (-0)) intData {-# NOINLINE byteStringData #-} byteStringData :: S.ByteString @@ -285,12 +347,94 @@ main = do , bgroup "Non-bounded encodings" [ benchB "byteStringHex" byteStringData $ byteStringHex , benchB "lazyByteStringHex" lazyByteStringData $ lazyByteStringHex - , benchB "foldMap floatDec" floatData $ foldMap floatDec - , benchB "foldMap doubleDec" doubleData $ foldMap doubleDec -- Note that the small data corresponds to the intData pre-converted -- to Integer. , benchB "foldMap integerDec (small)" smallIntegerData $ foldMap integerDec , benchB "foldMap integerDec (large)" largeIntegerData $ foldMap integerDec + , bgroup "RealFloat" + [ bgroup "FGeneric" + [ bgroup "Positive" + [ benchB "foldMap (formatFloat generic)" floatPosData $ foldMap (formatFloat generic) + , benchB "foldMap (formatDouble generic)" doublePosData $ foldMap (formatDouble generic) + ] + , bgroup "Negative" + [ benchB "foldMap (formatFloat generic)" floatNegData $ foldMap (formatFloat generic) + , benchB "foldMap (formatDouble generic)" doubleNegData $ foldMap (formatDouble generic) + ] + , bgroup "Special" + [ benchB "foldMap (formatFloat generic)" floatNaN $ foldMap (formatFloat generic) + , benchB "foldMap (formatDouble generic)" doubleNaN $ foldMap (formatDouble generic) + , benchB "foldMap (formatFloat generic)" floatPosInf $ foldMap (formatFloat generic) + , benchB "foldMap (formatDouble generic)" doublePosInf $ foldMap (formatDouble generic) + , benchB "foldMap (formatFloat generic)" floatNegInf $ foldMap (formatFloat generic) + , benchB "foldMap (formatDouble generic)" doubleNegInf $ foldMap (formatDouble generic) + , benchB "foldMap (formatFloat generic)" floatPosZero $ foldMap (formatFloat generic) + , benchB "foldMap (formatDouble generic)" doublePosZero $ foldMap (formatDouble generic) + , benchB "foldMap (formatFloat generic)" floatNegZero $ foldMap (formatFloat generic) + , benchB "foldMap (formatDouble generic)" doubleNegZero $ foldMap (formatDouble generic) + ] + ] + , bgroup "FScientific" + [ bgroup "Positive" + [ benchB "foldMap (formatFloat scientific)" floatPosData $ foldMap (formatFloat scientific) + , benchB "foldMap (formatDouble scientific)" doublePosData $ foldMap (formatDouble scientific) + ] + , bgroup "Negative" + [ benchB "foldMap (formatFloat scientific)" floatNegData $ foldMap (formatFloat scientific) + , benchB "foldMap (formatDouble scientific)" doubleNegData $ foldMap (formatDouble scientific) + ] + , bgroup "Special" + [ benchB "foldMap (formatFloat scientific)" floatNaN $ foldMap (formatFloat scientific) + , benchB "foldMap (formatDouble scientific)" doubleNaN $ foldMap (formatDouble scientific) + , benchB "foldMap (formatFloat scientific)" floatPosInf $ foldMap (formatFloat scientific) + , benchB "foldMap (formatDouble scientific)" doublePosInf $ foldMap (formatDouble scientific) + , benchB "foldMap (formatFloat scientific)" floatNegInf $ foldMap (formatFloat scientific) + , benchB "foldMap (formatDouble scientific)" doubleNegInf $ foldMap (formatDouble scientific) + , benchB "foldMap (formatFloat scientific)" floatPosZero $ foldMap (formatFloat scientific) + , benchB "foldMap (formatDouble scientific)" doublePosZero $ foldMap (formatDouble scientific) + , benchB "foldMap (formatFloat scientific)" floatNegZero $ foldMap (formatFloat scientific) + , benchB "foldMap (formatDouble scientific)" doubleNegZero $ foldMap (formatDouble scientific) + ] + ] + , bgroup "FStandard" + [ bgroup "Positive" + [ bgroup "without" + [ benchB "foldMap (formatFloat standardDefaultPrecision)" floatPosData $ foldMap (formatFloat standardDefaultPrecision) + , benchB "foldMap (formatDouble standardDefaultPrecision)" doublePosData $ foldMap (formatDouble standardDefaultPrecision) + ] + , bgroup "precision" + [ benchB "foldMap (formatFloat (standard 1))" floatPosData $ foldMap (formatFloat (standard 1)) + , benchB "foldMap (formatDouble (standard 1))" doublePosData $ foldMap (formatDouble (standard 1)) + , benchB "foldMap (formatFloat (standard 6))" floatPosData $ foldMap (formatFloat (standard 6)) + , benchB "foldMap (formatDouble (standard 6))" doublePosData $ foldMap (formatDouble (standard 6)) + ] + ] + , bgroup "Negative" + [ bgroup "without" + [ benchB "foldMap (formatFloat standardDefaultPrecision)" floatNegData $ foldMap (formatFloat standardDefaultPrecision) + , benchB "foldMap (formatDouble standardDefaultPrecision)" doubleNegData $ foldMap (formatDouble standardDefaultPrecision) + ] + , bgroup "precision" + [ benchB "foldMap (formatFloat (standard 1))" floatNegData $ foldMap (formatFloat (standard 1)) + , benchB "foldMap (formatDouble (standard 1))" doubleNegData $ foldMap (formatDouble (standard 1)) + , benchB "foldMap (formatFloat (standard 6))" floatNegData $ foldMap (formatFloat (standard 6)) + , benchB "foldMap (formatDouble (standard 6))" doubleNegData $ foldMap (formatDouble (standard 6)) + ] + ] + , bgroup "Special" + [ benchB "foldMap (formatFloat standard)" floatNaN $ foldMap (formatFloat standardDefaultPrecision) + , benchB "foldMap (formatDouble standard)" doubleNaN $ foldMap (formatDouble standardDefaultPrecision) + , benchB "foldMap (formatFloat standard)" floatPosInf $ foldMap (formatFloat standardDefaultPrecision) + , benchB "foldMap (formatDouble standard)" doublePosInf $ foldMap (formatDouble standardDefaultPrecision) + , benchB "foldMap (formatFloat standard)" floatNegInf $ foldMap (formatFloat standardDefaultPrecision) + , benchB "foldMap (formatDouble standard)" doubleNegInf $ foldMap (formatDouble standardDefaultPrecision) + , benchB "foldMap (formatFloat standard)" floatPosZero $ foldMap (formatFloat standardDefaultPrecision) + , benchB "foldMap (formatDouble standard)" doublePosZero $ foldMap (formatDouble standardDefaultPrecision) + , benchB "foldMap (formatFloat standard)" floatNegZero $ foldMap (formatFloat standardDefaultPrecision) + , benchB "foldMap (formatDouble standard)" doubleNegZero $ foldMap (formatDouble standardDefaultPrecision) + ] + ] + ] ] ] diff --git a/bytestring.cabal b/bytestring.cabal index eea29d17b..69e541213 100644 --- a/bytestring.cabal +++ b/bytestring.cabal @@ -208,4 +208,5 @@ benchmark bytestring-bench bytestring, deepseq, tasty-bench, - random + random, + ieee754 From 36241cca9a0786615b89a2814295f23c41dade9d Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Mon, 8 Jan 2024 21:46:04 -0500 Subject: [PATCH 02/34] better names for RealFloat tests --- bench/BenchAll.hs | 84 +++++++++++++++++++++++------------------------ 1 file changed, 42 insertions(+), 42 deletions(-) diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index 1783839e6..bec0fefc6 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -354,53 +354,53 @@ main = do , bgroup "RealFloat" [ bgroup "FGeneric" [ bgroup "Positive" - [ benchB "foldMap (formatFloat generic)" floatPosData $ foldMap (formatFloat generic) - , benchB "foldMap (formatDouble generic)" doublePosData $ foldMap (formatDouble generic) + [ benchB "Float" floatPosData $ foldMap (formatFloat generic) + , benchB "Double" doublePosData $ foldMap (formatDouble generic) ] , bgroup "Negative" - [ benchB "foldMap (formatFloat generic)" floatNegData $ foldMap (formatFloat generic) - , benchB "foldMap (formatDouble generic)" doubleNegData $ foldMap (formatDouble generic) + [ benchB "Float" floatNegData $ foldMap (formatFloat generic) + , benchB "Double" doubleNegData $ foldMap (formatDouble generic) ] , bgroup "Special" - [ benchB "foldMap (formatFloat generic)" floatNaN $ foldMap (formatFloat generic) - , benchB "foldMap (formatDouble generic)" doubleNaN $ foldMap (formatDouble generic) - , benchB "foldMap (formatFloat generic)" floatPosInf $ foldMap (formatFloat generic) - , benchB "foldMap (formatDouble generic)" doublePosInf $ foldMap (formatDouble generic) - , benchB "foldMap (formatFloat generic)" floatNegInf $ foldMap (formatFloat generic) - , benchB "foldMap (formatDouble generic)" doubleNegInf $ foldMap (formatDouble generic) - , benchB "foldMap (formatFloat generic)" floatPosZero $ foldMap (formatFloat generic) - , benchB "foldMap (formatDouble generic)" doublePosZero $ foldMap (formatDouble generic) - , benchB "foldMap (formatFloat generic)" floatNegZero $ foldMap (formatFloat generic) - , benchB "foldMap (formatDouble generic)" doubleNegZero $ foldMap (formatDouble generic) + [ benchB "Float NaN" floatNaN $ foldMap (formatFloat generic) + , benchB "Double NaN" doubleNaN $ foldMap (formatDouble generic) + , benchB "Float PosInf" floatPosInf $ foldMap (formatFloat generic) + , benchB "Double PosInf" doublePosInf $ foldMap (formatDouble generic) + , benchB "Float NegInf" floatNegInf $ foldMap (formatFloat generic) + , benchB "Double NegInf" doubleNegInf $ foldMap (formatDouble generic) + , benchB "Float PosZero" floatPosZero $ foldMap (formatFloat generic) + , benchB "Double PosZero" doublePosZero $ foldMap (formatDouble generic) + , benchB "Float NegZero" floatNegZero $ foldMap (formatFloat generic) + , benchB "Double NegZero" doubleNegZero $ foldMap (formatDouble generic) ] ] , bgroup "FScientific" [ bgroup "Positive" - [ benchB "foldMap (formatFloat scientific)" floatPosData $ foldMap (formatFloat scientific) - , benchB "foldMap (formatDouble scientific)" doublePosData $ foldMap (formatDouble scientific) + [ benchB "Float" floatPosData $ foldMap (formatFloat scientific) + , benchB "Double" doublePosData $ foldMap (formatDouble scientific) ] , bgroup "Negative" - [ benchB "foldMap (formatFloat scientific)" floatNegData $ foldMap (formatFloat scientific) - , benchB "foldMap (formatDouble scientific)" doubleNegData $ foldMap (formatDouble scientific) + [ benchB "Float" floatNegData $ foldMap (formatFloat scientific) + , benchB "Double" doubleNegData $ foldMap (formatDouble scientific) ] , bgroup "Special" - [ benchB "foldMap (formatFloat scientific)" floatNaN $ foldMap (formatFloat scientific) - , benchB "foldMap (formatDouble scientific)" doubleNaN $ foldMap (formatDouble scientific) - , benchB "foldMap (formatFloat scientific)" floatPosInf $ foldMap (formatFloat scientific) - , benchB "foldMap (formatDouble scientific)" doublePosInf $ foldMap (formatDouble scientific) - , benchB "foldMap (formatFloat scientific)" floatNegInf $ foldMap (formatFloat scientific) - , benchB "foldMap (formatDouble scientific)" doubleNegInf $ foldMap (formatDouble scientific) - , benchB "foldMap (formatFloat scientific)" floatPosZero $ foldMap (formatFloat scientific) - , benchB "foldMap (formatDouble scientific)" doublePosZero $ foldMap (formatDouble scientific) - , benchB "foldMap (formatFloat scientific)" floatNegZero $ foldMap (formatFloat scientific) - , benchB "foldMap (formatDouble scientific)" doubleNegZero $ foldMap (formatDouble scientific) + [ benchB "Float NaN" floatNaN $ foldMap (formatFloat scientific) + , benchB "Double NaN" doubleNaN $ foldMap (formatDouble scientific) + , benchB "Float PosInf" floatPosInf $ foldMap (formatFloat scientific) + , benchB "Double PosInf" doublePosInf $ foldMap (formatDouble scientific) + , benchB "Float NegInf" floatNegInf $ foldMap (formatFloat scientific) + , benchB "Double NegInf" doubleNegInf $ foldMap (formatDouble scientific) + , benchB "Float PosZero" floatPosZero $ foldMap (formatFloat scientific) + , benchB "Double PosZero" doublePosZero $ foldMap (formatDouble scientific) + , benchB "Float NegZero" floatNegZero $ foldMap (formatFloat scientific) + , benchB "Double NegZero" doubleNegZero $ foldMap (formatDouble scientific) ] ] , bgroup "FStandard" [ bgroup "Positive" [ bgroup "without" - [ benchB "foldMap (formatFloat standardDefaultPrecision)" floatPosData $ foldMap (formatFloat standardDefaultPrecision) - , benchB "foldMap (formatDouble standardDefaultPrecision)" doublePosData $ foldMap (formatDouble standardDefaultPrecision) + [ benchB "Float" floatPosData $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double" doublePosData $ foldMap (formatDouble standardDefaultPrecision) ] , bgroup "precision" [ benchB "foldMap (formatFloat (standard 1))" floatPosData $ foldMap (formatFloat (standard 1)) @@ -411,8 +411,8 @@ main = do ] , bgroup "Negative" [ bgroup "without" - [ benchB "foldMap (formatFloat standardDefaultPrecision)" floatNegData $ foldMap (formatFloat standardDefaultPrecision) - , benchB "foldMap (formatDouble standardDefaultPrecision)" doubleNegData $ foldMap (formatDouble standardDefaultPrecision) + [ benchB "Float" floatNegData $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double" doubleNegData $ foldMap (formatDouble standardDefaultPrecision) ] , bgroup "precision" [ benchB "foldMap (formatFloat (standard 1))" floatNegData $ foldMap (formatFloat (standard 1)) @@ -422,16 +422,16 @@ main = do ] ] , bgroup "Special" - [ benchB "foldMap (formatFloat standard)" floatNaN $ foldMap (formatFloat standardDefaultPrecision) - , benchB "foldMap (formatDouble standard)" doubleNaN $ foldMap (formatDouble standardDefaultPrecision) - , benchB "foldMap (formatFloat standard)" floatPosInf $ foldMap (formatFloat standardDefaultPrecision) - , benchB "foldMap (formatDouble standard)" doublePosInf $ foldMap (formatDouble standardDefaultPrecision) - , benchB "foldMap (formatFloat standard)" floatNegInf $ foldMap (formatFloat standardDefaultPrecision) - , benchB "foldMap (formatDouble standard)" doubleNegInf $ foldMap (formatDouble standardDefaultPrecision) - , benchB "foldMap (formatFloat standard)" floatPosZero $ foldMap (formatFloat standardDefaultPrecision) - , benchB "foldMap (formatDouble standard)" doublePosZero $ foldMap (formatDouble standardDefaultPrecision) - , benchB "foldMap (formatFloat standard)" floatNegZero $ foldMap (formatFloat standardDefaultPrecision) - , benchB "foldMap (formatDouble standard)" doubleNegZero $ foldMap (formatDouble standardDefaultPrecision) + [ benchB "Float NaN" floatNaN $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double NaN" doubleNaN $ foldMap (formatDouble standardDefaultPrecision) + , benchB "Float PosInf" floatPosInf $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double PosInf" doublePosInf $ foldMap (formatDouble standardDefaultPrecision) + , benchB "Float NegInf" floatNegInf $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double NegInf" doubleNegInf $ foldMap (formatDouble standardDefaultPrecision) + , benchB "Float PosZero" floatPosZero $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double PosZero" doublePosZero $ foldMap (formatDouble standardDefaultPrecision) + , benchB "Float NegZero" floatNegZero $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double NegZero" doubleNegZero $ foldMap (formatDouble standardDefaultPrecision) ] ] ] From b3a2276e0a6678cbc63ad9395341874c1b867bc9 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Thu, 11 Jan 2024 21:29:11 -0500 Subject: [PATCH 03/34] averaged realfloat specal strings instead of checking each special value since order changes the bench mark --- bench/BenchAll.hs | 86 ++++++++++------------------------------------- 1 file changed, 17 insertions(+), 69 deletions(-) diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index bec0fefc6..af0d0f0ae 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -72,7 +72,7 @@ countToZero n = Just (n, n - 1) -- | Few-enough repetitions to avoid making GC too expensive. nRepl :: Int -nRepl = 1000000 +nRepl = 100000 {-# NOINLINE intData #-} intData :: [Int] @@ -98,25 +98,11 @@ floatPosData = map evenlyDistribute intData floatNegData :: [Float] floatNegData = map negate floatPosData -{-# NOINLINE floatNaN #-} -floatNaN :: [Float] -floatNaN = map (const nan) intData - -{-# NOINLINE floatPosInf #-} -floatPosInf :: [Float] -floatPosInf = map (const infinity) intData - -{-# NOINLINE floatNegInf #-} -floatNegInf :: [Float] -floatNegInf = map (const (negate infinity)) intData - -{-# NOINLINE floatPosZero #-} -floatPosZero :: [Float] -floatPosZero = map (const 0) intData - -{-# NOINLINE floatNegZero #-} -floatNegZero :: [Float] -floatNegZero = map (const (-0)) intData +{-# NOINLINE floatSpecials #-} +floatSpecials :: [Float] +floatSpecials = foldMap (const specials) [1..nRepl `div` length specials] + where + specials = [nan, infinity, negate infinity, 0 -0] {-# NOINLINE doublePosData #-} doublePosData :: [Double] @@ -130,25 +116,11 @@ doublePosData = map evenlyDistribute intData doubleNegData :: [Double] doubleNegData = map negate doublePosData -{-# NOINLINE doubleNaN #-} -doubleNaN :: [Double] -doubleNaN = map (const nan) intData - -{-# NOINLINE doublePosInf #-} -doublePosInf :: [Double] -doublePosInf = map (const infinity) intData - -{-# NOINLINE doubleNegInf #-} -doubleNegInf :: [Double] -doubleNegInf = map (const (negate infinity)) intData - -{-# NOINLINE doublePosZero #-} -doublePosZero :: [Double] -doublePosZero = map (const 0) intData - -{-# NOINLINE doubleNegZero #-} -doubleNegZero :: [Double] -doubleNegZero = map (const (-0)) intData +{-# NOINLINE doubleSpecials #-} +doubleSpecials :: [Double] +doubleSpecials = foldMap (const specials) [1..nRepl `div` length specials] + where + specials = [nan, infinity, negate infinity, 0 -0] {-# NOINLINE byteStringData #-} byteStringData :: S.ByteString @@ -362,16 +334,8 @@ main = do , benchB "Double" doubleNegData $ foldMap (formatDouble generic) ] , bgroup "Special" - [ benchB "Float NaN" floatNaN $ foldMap (formatFloat generic) - , benchB "Double NaN" doubleNaN $ foldMap (formatDouble generic) - , benchB "Float PosInf" floatPosInf $ foldMap (formatFloat generic) - , benchB "Double PosInf" doublePosInf $ foldMap (formatDouble generic) - , benchB "Float NegInf" floatNegInf $ foldMap (formatFloat generic) - , benchB "Double NegInf" doubleNegInf $ foldMap (formatDouble generic) - , benchB "Float PosZero" floatPosZero $ foldMap (formatFloat generic) - , benchB "Double PosZero" doublePosZero $ foldMap (formatDouble generic) - , benchB "Float NegZero" floatNegZero $ foldMap (formatFloat generic) - , benchB "Double NegZero" doubleNegZero $ foldMap (formatDouble generic) + [ benchB "Float Average" floatSpecials $ foldMap (formatFloat generic) + , benchB "Double Average" doubleSpecials $ foldMap (formatDouble generic) ] ] , bgroup "FScientific" @@ -384,16 +348,8 @@ main = do , benchB "Double" doubleNegData $ foldMap (formatDouble scientific) ] , bgroup "Special" - [ benchB "Float NaN" floatNaN $ foldMap (formatFloat scientific) - , benchB "Double NaN" doubleNaN $ foldMap (formatDouble scientific) - , benchB "Float PosInf" floatPosInf $ foldMap (formatFloat scientific) - , benchB "Double PosInf" doublePosInf $ foldMap (formatDouble scientific) - , benchB "Float NegInf" floatNegInf $ foldMap (formatFloat scientific) - , benchB "Double NegInf" doubleNegInf $ foldMap (formatDouble scientific) - , benchB "Float PosZero" floatPosZero $ foldMap (formatFloat scientific) - , benchB "Double PosZero" doublePosZero $ foldMap (formatDouble scientific) - , benchB "Float NegZero" floatNegZero $ foldMap (formatFloat scientific) - , benchB "Double NegZero" doubleNegZero $ foldMap (formatDouble scientific) + [ benchB "Float Average" floatSpecials $ foldMap (formatFloat scientific) + , benchB "Double Average" doubleSpecials $ foldMap (formatDouble scientific) ] ] , bgroup "FStandard" @@ -422,16 +378,8 @@ main = do ] ] , bgroup "Special" - [ benchB "Float NaN" floatNaN $ foldMap (formatFloat standardDefaultPrecision) - , benchB "Double NaN" doubleNaN $ foldMap (formatDouble standardDefaultPrecision) - , benchB "Float PosInf" floatPosInf $ foldMap (formatFloat standardDefaultPrecision) - , benchB "Double PosInf" doublePosInf $ foldMap (formatDouble standardDefaultPrecision) - , benchB "Float NegInf" floatNegInf $ foldMap (formatFloat standardDefaultPrecision) - , benchB "Double NegInf" doubleNegInf $ foldMap (formatDouble standardDefaultPrecision) - , benchB "Float PosZero" floatPosZero $ foldMap (formatFloat standardDefaultPrecision) - , benchB "Double PosZero" doublePosZero $ foldMap (formatDouble standardDefaultPrecision) - , benchB "Float NegZero" floatNegZero $ foldMap (formatFloat standardDefaultPrecision) - , benchB "Double NegZero" doubleNegZero $ foldMap (formatDouble standardDefaultPrecision) + [ benchB "Float Average" floatSpecials $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double Average" doubleSpecials $ foldMap (formatDouble standardDefaultPrecision) ] ] ] From 9a86e45857e2fb267949ee3a0f1d5a84ca005066 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Fri, 12 Jan 2024 14:32:54 -0500 Subject: [PATCH 04/34] improved test and add bench for small doubles --- bench/BenchAll.hs | 69 +++++++++++++------ bytestring.cabal | 1 + .../builder/Data/ByteString/Builder/Tests.hs | 6 +- 3 files changed, 53 insertions(+), 23 deletions(-) diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index af0d0f0ae..41950dd35 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -15,6 +15,7 @@ module Main (main) where +import Control.Exception (assert) import Data.Foldable (foldMap) import Data.Monoid import Data.Semigroup @@ -110,12 +111,28 @@ doublePosData = map evenlyDistribute intData where evenlyDistribute :: Int -> Double evenlyDistribute x = castWord64ToDouble $ increment * fromIntegral x - increment = castDoubleToWord64 maxFinite `div` fromIntegral nRepl + increment = (maximum - minimum) `div` fromIntegral nRepl + minimum = castDoubleToWord64 $ succIEEE $ 2 ^ 53 + maximum = castDoubleToWord64 maxFinite {-# NOINLINE doubleNegData #-} doubleNegData :: [Double] doubleNegData = map negate doublePosData +-- f is an integer in the range [1, 2^53). +{-# NOINLINE doublePosSmallData #-} +doublePosSmallData :: [Double] +doublePosSmallData = map evenlyDistribute intData + where + evenlyDistribute = assert (increment > 0) $ \x -> castWord64ToDouble $ increment * fromIntegral x + minimum + increment = (maximum - minimum) `div` fromIntegral nRepl + minimum = castDoubleToWord64 1.0 + maximum = castDoubleToWord64 $ 2 ^ 53 + +{-# NOINLINE doubleNegSmallData #-} +doubleNegSmallData :: [Double] +doubleNegSmallData = map negate doublePosSmallData + {-# NOINLINE doubleSpecials #-} doubleSpecials :: [Double] doubleSpecials = foldMap (const specials) [1..nRepl `div` length specials] @@ -326,12 +343,14 @@ main = do , bgroup "RealFloat" [ bgroup "FGeneric" [ bgroup "Positive" - [ benchB "Float" floatPosData $ foldMap (formatFloat generic) - , benchB "Double" doublePosData $ foldMap (formatDouble generic) + [ benchB "Float" floatPosData $ foldMap (formatFloat generic) + , benchB "Double" doublePosData $ foldMap (formatDouble generic) + , benchB "DoubleSmall" doublePosSmallData $ foldMap (formatDouble generic) ] , bgroup "Negative" - [ benchB "Float" floatNegData $ foldMap (formatFloat generic) - , benchB "Double" doubleNegData $ foldMap (formatDouble generic) + [ benchB "Float" floatNegData $ foldMap (formatFloat generic) + , benchB "Double" doubleNegData $ foldMap (formatDouble generic) + , benchB "DoubleSmall" doubleNegData $ foldMap (formatDouble generic) ] , bgroup "Special" [ benchB "Float Average" floatSpecials $ foldMap (formatFloat generic) @@ -340,12 +359,14 @@ main = do ] , bgroup "FScientific" [ bgroup "Positive" - [ benchB "Float" floatPosData $ foldMap (formatFloat scientific) - , benchB "Double" doublePosData $ foldMap (formatDouble scientific) + [ benchB "Float" floatPosData $ foldMap (formatFloat scientific) + , benchB "Double" doublePosData $ foldMap (formatDouble scientific) + , benchB "DoubleSmall" doublePosSmallData $ foldMap (formatDouble scientific) ] , bgroup "Negative" - [ benchB "Float" floatNegData $ foldMap (formatFloat scientific) - , benchB "Double" doubleNegData $ foldMap (formatDouble scientific) + [ benchB "Float" floatNegData $ foldMap (formatFloat scientific) + , benchB "Double" doubleNegData $ foldMap (formatDouble scientific) + , benchB "DoubleSmall" doubleNegSmallData $ foldMap (formatDouble scientific) ] , bgroup "Special" [ benchB "Float Average" floatSpecials $ foldMap (formatFloat scientific) @@ -355,26 +376,32 @@ main = do , bgroup "FStandard" [ bgroup "Positive" [ bgroup "without" - [ benchB "Float" floatPosData $ foldMap (formatFloat standardDefaultPrecision) - , benchB "Double" doublePosData $ foldMap (formatDouble standardDefaultPrecision) + [ benchB "Float" floatPosData $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double" doublePosData $ foldMap (formatDouble standardDefaultPrecision) + , benchB "DoubleSmall" doublePosSmallData $ foldMap (formatDouble standardDefaultPrecision) ] , bgroup "precision" - [ benchB "foldMap (formatFloat (standard 1))" floatPosData $ foldMap (formatFloat (standard 1)) - , benchB "foldMap (formatDouble (standard 1))" doublePosData $ foldMap (formatDouble (standard 1)) - , benchB "foldMap (formatFloat (standard 6))" floatPosData $ foldMap (formatFloat (standard 6)) - , benchB "foldMap (formatDouble (standard 6))" doublePosData $ foldMap (formatDouble (standard 6)) + [ benchB "Float-Preciaion-1" floatPosData $ foldMap (formatFloat (standard 1)) + , benchB "Double-Preciaion-1" doublePosData $ foldMap (formatDouble (standard 1)) + , benchB "DoubleSmall-Preciaion-1" doublePosSmallData $ foldMap (formatDouble (standard 1)) + , benchB "Float-Preciaion-6" floatPosData $ foldMap (formatFloat (standard 6)) + , benchB "Double-Preciaion-6" doublePosData $ foldMap (formatDouble (standard 6)) + , benchB "DoubleSmall-Preciaion-6" doublePosSmallData $ foldMap (formatDouble (standard 6)) ] ] , bgroup "Negative" [ bgroup "without" - [ benchB "Float" floatNegData $ foldMap (formatFloat standardDefaultPrecision) - , benchB "Double" doubleNegData $ foldMap (formatDouble standardDefaultPrecision) + [ benchB "Float" floatNegData $ foldMap (formatFloat standardDefaultPrecision) + , benchB "Double" doubleNegData $ foldMap (formatDouble standardDefaultPrecision) + , benchB "DoubleSmall" doubleNegSmallData $ foldMap (formatDouble standardDefaultPrecision) ] , bgroup "precision" - [ benchB "foldMap (formatFloat (standard 1))" floatNegData $ foldMap (formatFloat (standard 1)) - , benchB "foldMap (formatDouble (standard 1))" doubleNegData $ foldMap (formatDouble (standard 1)) - , benchB "foldMap (formatFloat (standard 6))" floatNegData $ foldMap (formatFloat (standard 6)) - , benchB "foldMap (formatDouble (standard 6))" doubleNegData $ foldMap (formatDouble (standard 6)) + [ benchB "Float-Preciaion-1" floatNegData $ foldMap (formatFloat (standard 1)) + , benchB "Double-Preciaion-1" doubleNegData $ foldMap (formatDouble (standard 1)) + , benchB "DoubleSmall-Preciaion-1" doubleNegSmallData $ foldMap (formatDouble (standard 1)) + , benchB "Float-Preciaion-6" floatNegData $ foldMap (formatFloat (standard 6)) + , benchB "Double-Preciaion-6" doubleNegData $ foldMap (formatDouble (standard 6)) + , benchB "DoubleSmall-Preciaion-6" doubleNegSmallData $ foldMap (formatDouble (standard 6)) ] ] , bgroup "Special" diff --git a/bytestring.cabal b/bytestring.cabal index 69e541213..28a4d338a 100644 --- a/bytestring.cabal +++ b/bytestring.cabal @@ -182,6 +182,7 @@ test-suite bytestring-tests ghc-prim, QuickCheck, tasty, + tasty-hunit, tasty-quickcheck >= 0.8.1, template-haskell, transformers >= 0.3, diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index a7ab9131a..a41e439b3 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE BlockArguments #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -34,6 +35,7 @@ import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Short as Sh import Data.ByteString.Builder @@ -51,6 +53,7 @@ import Numeric (showFFloat) import System.Posix.Internals (c_unlink) import Test.Tasty (TestTree, TestName, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.QuickCheck ( Arbitrary(..), oneof, choose, listOf, elements, forAll , counterexample, ioProperty, Property, testProperty @@ -956,8 +959,7 @@ testsFloating = ] where testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree - testExpected name dec lst = testProperty name . conjoin $ - fmap (\(x, ref) -> L.unpack (toLazyByteString (dec x)) === encodeASCII ref) lst + testExpected name dec = testCase name . traverse_ \(x, ref) -> LC.unpack (toLazyByteString (dec x)) @?= ref singleMatches :: (a -> Builder) -> (a -> String) -> (a, String) -> Property singleMatches dec refdec (x, ref) = L.unpack (toLazyByteString (dec x)) === encodeASCII (refdec x) .&&. refdec x === ref From a0998bf98c4ce3bc9e301625c17af758b8c4a256 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 14 Jan 2024 20:36:55 -0500 Subject: [PATCH 05/34] improved tests for FStandard --- .../builder/Data/ByteString/Builder/Tests.hs | 33 +++++++++++++------ 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index a41e439b3..1058e9f1f 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -53,7 +54,7 @@ import Numeric (showFFloat) import System.Posix.Internals (c_unlink) import Test.Tasty (TestTree, TestName, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (testCase, (@?=), Assertion) import Test.Tasty.QuickCheck ( Arbitrary(..), oneof, choose, listOf, elements, forAll , counterexample, ioProperty, Property, testProperty @@ -777,12 +778,22 @@ testsFloating = , ( 4.294967294 , "4.294967294e0" ) , ( 4.294967295 , "4.294967295e0" ) ] - , testProperty "d2sStandard" $ conjoin - [ singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) - , singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) - , singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) - , singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) - ] + , testGroup "d2sStandard" + [ testCase "specific" do + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3 , "12.30" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3451 , "12.35" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.999 , "1000.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.199 , "999.20" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.999 , "1.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0056 , "0.006" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0096 , "0.010" ) + singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0 , "0.000" ) + , testProperty "standard N" \(NonNegative p, d :: Double) -> (LC.unpack . toLazyByteString) (formatDouble (standard p) d) === showFFloat (Just p) d "" + ] , testMatches "d2sLooksLikePowerOf5" doubleDec show [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) @@ -961,11 +972,13 @@ testsFloating = testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree testExpected name dec = testCase name . traverse_ \(x, ref) -> LC.unpack (toLazyByteString (dec x)) @?= ref - singleMatches :: (a -> Builder) -> (a -> String) -> (a, String) -> Property - singleMatches dec refdec (x, ref) = L.unpack (toLazyByteString (dec x)) === encodeASCII (refdec x) .&&. refdec x === ref + singleMatches :: (a -> Builder) -> (a -> String) -> (a, String) -> Assertion + singleMatches dec refdec (x, ref) = do + LC.unpack (toLazyByteString (dec x)) @?= refdec x + refdec x @?= ref testMatches :: TestName -> (a -> Builder) -> (a -> String) -> [(a, String)] -> TestTree - testMatches name dec refdec lst = testProperty name . conjoin $ fmap (singleMatches dec refdec) lst + testMatches name dec refdec = testCase name . traverse_ (singleMatches dec refdec) maxMantissa = (1 `shiftL` 53) - 1 :: Word64 From ce7d20ec905a43dd68d2e4bdb2711d4143beffbb Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 14 Jan 2024 20:56:18 -0500 Subject: [PATCH 06/34] added better labels to real float tests --- .../builder/Data/ByteString/Builder/Tests.hs | 646 +++++++++--------- 1 file changed, 325 insertions(+), 321 deletions(-) diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index 1058e9f1f..cd264250e 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -77,7 +77,7 @@ tests = testsEncodingToBuilder ++ testsBinary ++ testsASCII ++ - testsFloating ++ + testsFloating : testsChar8 ++ testsUtf8 @@ -642,327 +642,331 @@ testsASCII = enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) testsFloating :: [TestTree] -testsFloating = - [ testMatches "f2sBasic" floatDec show - [ ( 0.0 , "0.0" ) - , ( (-0.0) , "-0.0" ) - , ( 1.0 , "1.0" ) - , ( (-1.0) , "-1.0" ) - , ( (0/0) , "NaN" ) - , ( (1/0) , "Infinity" ) - , ( (-1/0) , "-Infinity" ) - ] - , testMatches "f2sSubnormal" floatDec show - [ ( 1.1754944e-38 , "1.1754944e-38" ) - ] - , testMatches "f2sMinAndMax" floatDec show - [ ( coerceWord32ToFloat 0x7f7fffff , "3.4028235e38" ) - , ( coerceWord32ToFloat 0x00000001 , "1.0e-45" ) - ] - , testMatches "f2sBoundaryRound" floatDec show - [ ( 3.355445e7 , "3.3554448e7" ) - , ( 8.999999e9 , "8.999999e9" ) - , ( 3.4366717e10 , "3.4366718e10" ) - ] - , testMatches "f2sExactValueRound" floatDec show - [ ( 3.0540412e5 , "305404.13" ) - , ( 8.0990312e3 , "8099.0313" ) - ] - , testMatches "f2sTrailingZeros" floatDec show - -- Pattern for the first test: 00111001100000000000000000000000 - [ ( 2.4414062e-4 , "2.4414063e-4" ) - , ( 2.4414062e-3 , "2.4414063e-3" ) - , ( 4.3945312e-3 , "4.3945313e-3" ) - , ( 6.3476562e-3 , "6.3476563e-3" ) - ] - , testMatches "f2sRegression" floatDec show - [ ( 4.7223665e21 , "4.7223665e21" ) - , ( 8388608.0 , "8388608.0" ) - , ( 1.6777216e7 , "1.6777216e7" ) - , ( 3.3554436e7 , "3.3554436e7" ) - , ( 6.7131496e7 , "6.7131496e7" ) - , ( 1.9310392e-38 , "1.9310392e-38" ) - , ( (-2.47e-43) , "-2.47e-43" ) - , ( 1.993244e-38 , "1.993244e-38" ) - , ( 4103.9003 , "4103.9004" ) - , ( 5.3399997e9 , "5.3399997e9" ) - , ( 6.0898e-39 , "6.0898e-39" ) - , ( 0.0010310042 , "1.0310042e-3" ) - , ( 2.8823261e17 , "2.882326e17" ) - , ( 7.0385309e-26 , "7.038531e-26" ) - , ( 9.2234038e17 , "9.223404e17" ) - , ( 6.7108872e7 , "6.710887e7" ) - , ( 1.0e-44 , "1.0e-44" ) - , ( 2.816025e14 , "2.816025e14" ) - , ( 9.223372e18 , "9.223372e18" ) - , ( 1.5846085e29 , "1.5846086e29" ) - , ( 1.1811161e19 , "1.1811161e19" ) - , ( 5.368709e18 , "5.368709e18" ) - , ( 4.6143165e18 , "4.6143166e18" ) - , ( 0.007812537 , "7.812537e-3" ) - , ( 1.4e-45 , "1.0e-45" ) - , ( 1.18697724e20 , "1.18697725e20" ) - , ( 1.00014165e-36 , "1.00014165e-36" ) - , ( 200.0 , "200.0" ) - , ( 3.3554432e7 , "3.3554432e7" ) - , ( 2.0019531 , "2.0019531" ) - , ( 2.001953 , "2.001953" ) - ] - , testExpected "f2sScientific" (formatFloat scientific) - [ ( 0.0 , "0.0e0" ) - , ( 8388608.0 , "8.388608e6" ) - , ( 1.6777216e7 , "1.6777216e7" ) - , ( 3.3554436e7 , "3.3554436e7" ) - , ( 6.7131496e7 , "6.7131496e7" ) - , ( 1.9310392e-38 , "1.9310392e-38" ) - , ( (-2.47e-43) , "-2.47e-43" ) - , ( 1.993244e-38 , "1.993244e-38" ) - , ( 4103.9003 , "4.1039004e3" ) - , ( 0.0010310042 , "1.0310042e-3" ) - , ( 0.007812537 , "7.812537e-3" ) - , ( 200.0 , "2.0e2" ) - , ( 2.0019531 , "2.0019531e0" ) - , ( 2.001953 , "2.001953e0" ) - ] - , testMatches "f2sLooksLikePowerOf5" floatDec show - [ ( coerceWord32ToFloat 0x5D1502F9 , "6.7108864e17" ) - , ( coerceWord32ToFloat 0x5D9502F9 , "1.3421773e18" ) - , ( coerceWord32ToFloat 0x5e1502F9 , "2.6843546e18" ) - ] - , testMatches "f2sOutputLength" floatDec show - [ ( 1.0 , "1.0" ) - , ( 1.2 , "1.2" ) - , ( 1.23 , "1.23" ) - , ( 1.234 , "1.234" ) - , ( 1.2345 , "1.2345" ) - , ( 1.23456 , "1.23456" ) - , ( 1.234567 , "1.234567" ) - , ( 1.2345678 , "1.2345678" ) - , ( 1.23456735e-36 , "1.23456735e-36" ) - ] - , testMatches "d2sBasic" doubleDec show - [ ( 0.0 , "0.0" ) - , ( (-0.0) , "-0.0" ) - , ( 1.0 , "1.0" ) - , ( (-1.0) , "-1.0" ) - , ( (0/0) , "NaN" ) - , ( (1/0) , "Infinity" ) - , ( (-1/0) , "-Infinity" ) - ] - , testMatches "d2sSubnormal" doubleDec show - [ ( 2.2250738585072014e-308 , "2.2250738585072014e-308" ) - ] - , testMatches "d2sMinAndMax" doubleDec show - [ ( (coerceWord64ToDouble 0x7fefffffffffffff) , "1.7976931348623157e308" ) - , ( (coerceWord64ToDouble 0x0000000000000001) , "5.0e-324" ) - ] - , testMatches "d2sTrailingZeros" doubleDec show - [ ( 2.98023223876953125e-8 , "2.9802322387695313e-8" ) - ] - , testMatches "d2sRegression" doubleDec show - [ ( (-2.109808898695963e16) , "-2.1098088986959632e16" ) - , ( 4.940656e-318 , "4.940656e-318" ) - , ( 1.18575755e-316 , "1.18575755e-316" ) - , ( 2.989102097996e-312 , "2.989102097996e-312" ) - , ( 9.0608011534336e15 , "9.0608011534336e15" ) - , ( 4.708356024711512e18 , "4.708356024711512e18" ) - , ( 9.409340012568248e18 , "9.409340012568248e18" ) - , ( 1.2345678 , "1.2345678" ) - , ( 1.9430376160308388e16 , "1.9430376160308388e16" ) - , ( (-6.9741824662760956e19), "-6.9741824662760956e19" ) - , ( 4.3816050601147837e18 , "4.3816050601147837e18" ) - ] - , testExpected "d2sScientific" (formatDouble scientific) - [ ( 0.0 , "0.0e0" ) - , ( 1.2345678 , "1.2345678e0" ) - , ( 4.294967294 , "4.294967294e0" ) - , ( 4.294967295 , "4.294967295e0" ) - ] - , testGroup "d2sStandard" - [ testCase "specific" do - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3 , "12.30" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3451 , "12.35" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.999 , "1000.00" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.199 , "999.20" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.999 , "1.00" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) - singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0056 , "0.006" ) - singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0096 , "0.010" ) - singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) - singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0 , "0.000" ) - , testProperty "standard N" \(NonNegative p, d :: Double) -> (LC.unpack . toLazyByteString) (formatDouble (standard p) d) === showFFloat (Just p) d "" - ] - , testMatches "d2sLooksLikePowerOf5" doubleDec show - [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) - , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) - , ( (coerceWord64ToDouble 0x4850F0CF064DD592) , "2.305843009213694e40" ) - , ( (coerceWord64ToDouble 0x4400000000000004) , "3.689348814741914e19" ) - - -- here v- is a power of 5 but since we don't accept bounds there is no - -- interesting trailing behavior - , ( (coerceWord64ToDouble 0x440000000000301d) , "3.6893488147520004e19" ) - ] - , testMatches "d2sOutputLength" doubleDec show - [ ( 1 , "1.0" ) - , ( 1.2 , "1.2" ) - , ( 1.23 , "1.23" ) - , ( 1.234 , "1.234" ) - , ( 1.2345 , "1.2345" ) - , ( 1.23456 , "1.23456" ) - , ( 1.234567 , "1.234567" ) - , ( 1.2345678 , "1.2345678" ) - , ( 1.23456789 , "1.23456789" ) - , ( 1.234567895 , "1.234567895" ) - , ( 1.2345678901 , "1.2345678901" ) - , ( 1.23456789012 , "1.23456789012" ) - , ( 1.234567890123 , "1.234567890123" ) - , ( 1.2345678901234 , "1.2345678901234" ) - , ( 1.23456789012345 , "1.23456789012345" ) - , ( 1.234567890123456 , "1.234567890123456" ) - , ( 1.2345678901234567 , "1.2345678901234567" ) - - -- Test 32-bit chunking - , ( 4.294967294 , "4.294967294" ) - , ( 4.294967295 , "4.294967295" ) - , ( 4.294967296 , "4.294967296" ) - , ( 4.294967297 , "4.294967297" ) - , ( 4.294967298 , "4.294967298" ) - ] - , testMatches "d2sMinMaxShift" doubleDec show - [ ( (ieeeParts2Double False 4 0) , "1.7800590868057611e-307" ) - -- 32-bit opt-size=0: 49 <= dist <= 49 - -- 32-bit opt-size=1: 28 <= dist <= 49 - -- 64-bit opt-size=0: 50 <= dist <= 50 - -- 64-bit opt-size=1: 28 <= dist <= 50 - , ( (ieeeParts2Double False 6 maxMantissa) , "2.8480945388892175e-306" ) - -- 32-bit opt-size=0: 52 <= dist <= 53 - -- 32-bit opt-size=1: 2 <= dist <= 53 - -- 64-bit opt-size=0: 53 <= dist <= 53 - -- 64-bit opt-size=1: 2 <= dist <= 53 - , ( (ieeeParts2Double False 41 0) , "2.446494580089078e-296" ) - -- 32-bit opt-size=0: 52 <= dist <= 52 - -- 32-bit opt-size=1: 2 <= dist <= 52 - -- 64-bit opt-size=0: 53 <= dist <= 53 - -- 64-bit opt-size=1: 2 <= dist <= 53 - , ( (ieeeParts2Double False 40 maxMantissa) , "4.8929891601781557e-296" ) - -- 32-bit opt-size=0: 57 <= dist <= 58 - -- 32-bit opt-size=1: 57 <= dist <= 58 - -- 64-bit opt-size=0: 58 <= dist <= 58 - -- 64-bit opt-size=1: 58 <= dist <= 58 - , ( (ieeeParts2Double False 1077 0) , "1.8014398509481984e16" ) - -- 32-bit opt-size=0: 57 <= dist <= 57 - -- 32-bit opt-size=1: 57 <= dist <= 57 - -- 64-bit opt-size=0: 58 <= dist <= 58 - -- 64-bit opt-size=1: 58 <= dist <= 58 - , ( (ieeeParts2Double False 1076 maxMantissa) , "3.6028797018963964e16" ) - -- 32-bit opt-size=0: 51 <= dist <= 52 - -- 32-bit opt-size=1: 51 <= dist <= 59 - -- 64-bit opt-size=0: 52 <= dist <= 52 - -- 64-bit opt-size=1: 52 <= dist <= 59 - , ( (ieeeParts2Double False 307 0) , "2.900835519859558e-216" ) - -- 32-bit opt-size=0: 51 <= dist <= 51 - -- 32-bit opt-size=1: 51 <= dist <= 59 - -- 64-bit opt-size=0: 52 <= dist <= 52 - -- 64-bit opt-size=1: 52 <= dist <= 59 - , ( (ieeeParts2Double False 306 maxMantissa) , "5.801671039719115e-216" ) - -- 32-bit opt-size=0: 49 <= dist <= 49 - -- 32-bit opt-size=1: 44 <= dist <= 49 - -- 64-bit opt-size=0: 50 <= dist <= 50 - -- 64-bit opt-size=1: 44 <= dist <= 50 - , ( (ieeeParts2Double False 934 0x000FA7161A4D6e0C) , "3.196104012172126e-27" ) - ] - , testMatches "d2sSmallIntegers" doubleDec show - [ ( 9007199254740991.0 , "9.007199254740991e15" ) - , ( 9007199254740992.0 , "9.007199254740992e15" ) - - , ( 1.0e+0 , "1.0" ) - , ( 1.2e+1 , "12.0" ) - , ( 1.23e+2 , "123.0" ) - , ( 1.234e+3 , "1234.0" ) - , ( 1.2345e+4 , "12345.0" ) - , ( 1.23456e+5 , "123456.0" ) - , ( 1.234567e+6 , "1234567.0" ) - , ( 1.2345678e+7 , "1.2345678e7" ) - , ( 1.23456789e+8 , "1.23456789e8" ) - , ( 1.23456789e+9 , "1.23456789e9" ) - , ( 1.234567895e+9 , "1.234567895e9" ) - , ( 1.2345678901e+10 , "1.2345678901e10" ) - , ( 1.23456789012e+11 , "1.23456789012e11" ) - , ( 1.234567890123e+12 , "1.234567890123e12" ) - , ( 1.2345678901234e+13 , "1.2345678901234e13" ) - , ( 1.23456789012345e+14 , "1.23456789012345e14" ) - , ( 1.234567890123456e+15 , "1.234567890123456e15" ) - - -- 10^i - , ( 1.0e+0 , "1.0" ) - , ( 1.0e+1 , "10.0" ) - , ( 1.0e+2 , "100.0" ) - , ( 1.0e+3 , "1000.0" ) - , ( 1.0e+4 , "10000.0" ) - , ( 1.0e+5 , "100000.0" ) - , ( 1.0e+6 , "1000000.0" ) - , ( 1.0e+7 , "1.0e7" ) - , ( 1.0e+8 , "1.0e8" ) - , ( 1.0e+9 , "1.0e9" ) - , ( 1.0e+10 , "1.0e10" ) - , ( 1.0e+11 , "1.0e11" ) - , ( 1.0e+12 , "1.0e12" ) - , ( 1.0e+13 , "1.0e13" ) - , ( 1.0e+14 , "1.0e14" ) - , ( 1.0e+15 , "1.0e15" ) - - -- 10^15 + 10^i - , ( (1.0e+15 + 1.0e+0) , "1.000000000000001e15" ) - , ( (1.0e+15 + 1.0e+1) , "1.00000000000001e15" ) - , ( (1.0e+15 + 1.0e+2) , "1.0000000000001e15" ) - , ( (1.0e+15 + 1.0e+3) , "1.000000000001e15" ) - , ( (1.0e+15 + 1.0e+4) , "1.00000000001e15" ) - , ( (1.0e+15 + 1.0e+5) , "1.0000000001e15" ) - , ( (1.0e+15 + 1.0e+6) , "1.000000001e15" ) - , ( (1.0e+15 + 1.0e+7) , "1.00000001e15" ) - , ( (1.0e+15 + 1.0e+8) , "1.0000001e15" ) - , ( (1.0e+15 + 1.0e+9) , "1.000001e15" ) - , ( (1.0e+15 + 1.0e+10) , "1.00001e15" ) - , ( (1.0e+15 + 1.0e+11) , "1.0001e15" ) - , ( (1.0e+15 + 1.0e+12) , "1.001e15" ) - , ( (1.0e+15 + 1.0e+13) , "1.01e15" ) - , ( (1.0e+15 + 1.0e+14) , "1.1e15" ) - - -- Largest power of 2 <= 10^(i+1) - , ( 8.0 , "8.0" ) - , ( 64.0 , "64.0" ) - , ( 512.0 , "512.0" ) - , ( 8192.0 , "8192.0" ) - , ( 65536.0 , "65536.0" ) - , ( 524288.0 , "524288.0" ) - , ( 8388608.0 , "8388608.0" ) - , ( 67108864.0 , "6.7108864e7" ) - , ( 536870912.0 , "5.36870912e8" ) - , ( 8589934592.0 , "8.589934592e9" ) - , ( 68719476736.0 , "6.8719476736e10" ) - , ( 549755813888.0 , "5.49755813888e11" ) - , ( 8796093022208.0 , "8.796093022208e12" ) - , ( 70368744177664.0 , "7.0368744177664e13" ) - , ( 562949953421312.0 , "5.62949953421312e14" ) - , ( 9007199254740992.0 , "9.007199254740992e15" ) - - -- 1000 * (Largest power of 2 <= 10^(i+1)) - , ( 8.0e+3 , "8000.0" ) - , ( 64.0e+3 , "64000.0" ) - , ( 512.0e+3 , "512000.0" ) - , ( 8192.0e+3 , "8192000.0" ) - , ( 65536.0e+3 , "6.5536e7" ) - , ( 524288.0e+3 , "5.24288e8" ) - , ( 8388608.0e+3 , "8.388608e9" ) - , ( 67108864.0e+3 , "6.7108864e10" ) - , ( 536870912.0e+3 , "5.36870912e11" ) - , ( 8589934592.0e+3 , "8.589934592e12" ) - , ( 68719476736.0e+3 , "6.8719476736e13" ) - , ( 549755813888.0e+3 , "5.49755813888e14" ) - , ( 8796093022208.0e+3 , "8.796093022208e15" ) +testsFloating = testGroup "RealFloat" + [ testGroup "Float" + [ testMatches "f2sBasic" floatDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "f2sSubnormal" floatDec show + [ ( 1.1754944e-38 , "1.1754944e-38" ) + ] + , testMatches "f2sMinAndMax" floatDec show + [ ( coerceWord32ToFloat 0x7f7fffff , "3.4028235e38" ) + , ( coerceWord32ToFloat 0x00000001 , "1.0e-45" ) + ] + , testMatches "f2sBoundaryRound" floatDec show + [ ( 3.355445e7 , "3.3554448e7" ) + , ( 8.999999e9 , "8.999999e9" ) + , ( 3.4366717e10 , "3.4366718e10" ) + ] + , testMatches "f2sExactValueRound" floatDec show + [ ( 3.0540412e5 , "305404.13" ) + , ( 8.0990312e3 , "8099.0313" ) + ] + , testMatches "f2sTrailingZeros" floatDec show + -- Pattern for the first test: 00111001100000000000000000000000 + [ ( 2.4414062e-4 , "2.4414063e-4" ) + , ( 2.4414062e-3 , "2.4414063e-3" ) + , ( 4.3945312e-3 , "4.3945313e-3" ) + , ( 6.3476562e-3 , "6.3476563e-3" ) + ] + , testMatches "f2sRegression" floatDec show + [ ( 4.7223665e21 , "4.7223665e21" ) + , ( 8388608.0 , "8388608.0" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4103.9004" ) + , ( 5.3399997e9 , "5.3399997e9" ) + , ( 6.0898e-39 , "6.0898e-39" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 2.8823261e17 , "2.882326e17" ) + , ( 7.0385309e-26 , "7.038531e-26" ) + , ( 9.2234038e17 , "9.223404e17" ) + , ( 6.7108872e7 , "6.710887e7" ) + , ( 1.0e-44 , "1.0e-44" ) + , ( 2.816025e14 , "2.816025e14" ) + , ( 9.223372e18 , "9.223372e18" ) + , ( 1.5846085e29 , "1.5846086e29" ) + , ( 1.1811161e19 , "1.1811161e19" ) + , ( 5.368709e18 , "5.368709e18" ) + , ( 4.6143165e18 , "4.6143166e18" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 1.4e-45 , "1.0e-45" ) + , ( 1.18697724e20 , "1.18697725e20" ) + , ( 1.00014165e-36 , "1.00014165e-36" ) + , ( 200.0 , "200.0" ) + , ( 3.3554432e7 , "3.3554432e7" ) + , ( 2.0019531 , "2.0019531" ) + , ( 2.001953 , "2.001953" ) + ] + , testExpected "f2sScientific" (formatFloat scientific) + [ ( 0.0 , "0.0e0" ) + , ( 8388608.0 , "8.388608e6" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4.1039004e3" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 200.0 , "2.0e2" ) + , ( 2.0019531 , "2.0019531e0" ) + , ( 2.001953 , "2.001953e0" ) + ] + , testMatches "f2sLooksLikePowerOf5" floatDec show + [ ( coerceWord32ToFloat 0x5D1502F9 , "6.7108864e17" ) + , ( coerceWord32ToFloat 0x5D9502F9 , "1.3421773e18" ) + , ( coerceWord32ToFloat 0x5e1502F9 , "2.6843546e18" ) + ] + , testMatches "f2sOutputLength" floatDec show + [ ( 1.0 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456735e-36 , "1.23456735e-36" ) + ] + ] + testGroup "Double" + [ testMatches "d2sBasic" doubleDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "d2sSubnormal" doubleDec show + [ ( 2.2250738585072014e-308 , "2.2250738585072014e-308" ) + ] + , testMatches "d2sMinAndMax" doubleDec show + [ ( (coerceWord64ToDouble 0x7fefffffffffffff) , "1.7976931348623157e308" ) + , ( (coerceWord64ToDouble 0x0000000000000001) , "5.0e-324" ) + ] + , testMatches "d2sTrailingZeros" doubleDec show + [ ( 2.98023223876953125e-8 , "2.9802322387695313e-8" ) + ] + , testMatches "d2sRegression" doubleDec show + [ ( (-2.109808898695963e16) , "-2.1098088986959632e16" ) + , ( 4.940656e-318 , "4.940656e-318" ) + , ( 1.18575755e-316 , "1.18575755e-316" ) + , ( 2.989102097996e-312 , "2.989102097996e-312" ) + , ( 9.0608011534336e15 , "9.0608011534336e15" ) + , ( 4.708356024711512e18 , "4.708356024711512e18" ) + , ( 9.409340012568248e18 , "9.409340012568248e18" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.9430376160308388e16 , "1.9430376160308388e16" ) + , ( (-6.9741824662760956e19), "-6.9741824662760956e19" ) + , ( 4.3816050601147837e18 , "4.3816050601147837e18" ) + ] + , testExpected "d2sScientific" (formatDouble scientific) + [ ( 0.0 , "0.0e0" ) + , ( 1.2345678 , "1.2345678e0" ) + , ( 4.294967294 , "4.294967294e0" ) + , ( 4.294967295 , "4.294967295e0" ) + ] + , testGroup "d2sStandard" + [ testCase "specific" do + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3 , "12.30" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3451 , "12.35" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.999 , "1000.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.199 , "999.20" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.999 , "1.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0056 , "0.006" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0096 , "0.010" ) + singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0 , "0.000" ) + , testProperty "standard N" \(NonNegative p, d :: Double) -> (LC.unpack . toLazyByteString) (formatDouble (standard p) d) === showFFloat (Just p) d "" ] + , testMatches "d2sLooksLikePowerOf5" doubleDec show + [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) + , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) + , ( (coerceWord64ToDouble 0x4850F0CF064DD592) , "2.305843009213694e40" ) + , ( (coerceWord64ToDouble 0x4400000000000004) , "3.689348814741914e19" ) + + -- here v- is a power of 5 but since we don't accept bounds there is no + -- interesting trailing behavior + , ( (coerceWord64ToDouble 0x440000000000301d) , "3.6893488147520004e19" ) + ] + , testMatches "d2sOutputLength" doubleDec show + [ ( 1 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456789 , "1.23456789" ) + , ( 1.234567895 , "1.234567895" ) + , ( 1.2345678901 , "1.2345678901" ) + , ( 1.23456789012 , "1.23456789012" ) + , ( 1.234567890123 , "1.234567890123" ) + , ( 1.2345678901234 , "1.2345678901234" ) + , ( 1.23456789012345 , "1.23456789012345" ) + , ( 1.234567890123456 , "1.234567890123456" ) + , ( 1.2345678901234567 , "1.2345678901234567" ) + + -- Test 32-bit chunking + , ( 4.294967294 , "4.294967294" ) + , ( 4.294967295 , "4.294967295" ) + , ( 4.294967296 , "4.294967296" ) + , ( 4.294967297 , "4.294967297" ) + , ( 4.294967298 , "4.294967298" ) + ] + , testMatches "d2sMinMaxShift" doubleDec show + [ ( (ieeeParts2Double False 4 0) , "1.7800590868057611e-307" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 28 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 28 <= dist <= 50 + , ( (ieeeParts2Double False 6 maxMantissa) , "2.8480945388892175e-306" ) + -- 32-bit opt-size=0: 52 <= dist <= 53 + -- 32-bit opt-size=1: 2 <= dist <= 53 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 41 0) , "2.446494580089078e-296" ) + -- 32-bit opt-size=0: 52 <= dist <= 52 + -- 32-bit opt-size=1: 2 <= dist <= 52 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 40 maxMantissa) , "4.8929891601781557e-296" ) + -- 32-bit opt-size=0: 57 <= dist <= 58 + -- 32-bit opt-size=1: 57 <= dist <= 58 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1077 0) , "1.8014398509481984e16" ) + -- 32-bit opt-size=0: 57 <= dist <= 57 + -- 32-bit opt-size=1: 57 <= dist <= 57 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1076 maxMantissa) , "3.6028797018963964e16" ) + -- 32-bit opt-size=0: 51 <= dist <= 52 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 307 0) , "2.900835519859558e-216" ) + -- 32-bit opt-size=0: 51 <= dist <= 51 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 306 maxMantissa) , "5.801671039719115e-216" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 44 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 44 <= dist <= 50 + , ( (ieeeParts2Double False 934 0x000FA7161A4D6e0C) , "3.196104012172126e-27" ) + ] + , testMatches "d2sSmallIntegers" doubleDec show + [ ( 9007199254740991.0 , "9.007199254740991e15" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + , ( 1.0e+0 , "1.0" ) + , ( 1.2e+1 , "12.0" ) + , ( 1.23e+2 , "123.0" ) + , ( 1.234e+3 , "1234.0" ) + , ( 1.2345e+4 , "12345.0" ) + , ( 1.23456e+5 , "123456.0" ) + , ( 1.234567e+6 , "1234567.0" ) + , ( 1.2345678e+7 , "1.2345678e7" ) + , ( 1.23456789e+8 , "1.23456789e8" ) + , ( 1.23456789e+9 , "1.23456789e9" ) + , ( 1.234567895e+9 , "1.234567895e9" ) + , ( 1.2345678901e+10 , "1.2345678901e10" ) + , ( 1.23456789012e+11 , "1.23456789012e11" ) + , ( 1.234567890123e+12 , "1.234567890123e12" ) + , ( 1.2345678901234e+13 , "1.2345678901234e13" ) + , ( 1.23456789012345e+14 , "1.23456789012345e14" ) + , ( 1.234567890123456e+15 , "1.234567890123456e15" ) + + -- 10^i + , ( 1.0e+0 , "1.0" ) + , ( 1.0e+1 , "10.0" ) + , ( 1.0e+2 , "100.0" ) + , ( 1.0e+3 , "1000.0" ) + , ( 1.0e+4 , "10000.0" ) + , ( 1.0e+5 , "100000.0" ) + , ( 1.0e+6 , "1000000.0" ) + , ( 1.0e+7 , "1.0e7" ) + , ( 1.0e+8 , "1.0e8" ) + , ( 1.0e+9 , "1.0e9" ) + , ( 1.0e+10 , "1.0e10" ) + , ( 1.0e+11 , "1.0e11" ) + , ( 1.0e+12 , "1.0e12" ) + , ( 1.0e+13 , "1.0e13" ) + , ( 1.0e+14 , "1.0e14" ) + , ( 1.0e+15 , "1.0e15" ) + + -- 10^15 + 10^i + , ( (1.0e+15 + 1.0e+0) , "1.000000000000001e15" ) + , ( (1.0e+15 + 1.0e+1) , "1.00000000000001e15" ) + , ( (1.0e+15 + 1.0e+2) , "1.0000000000001e15" ) + , ( (1.0e+15 + 1.0e+3) , "1.000000000001e15" ) + , ( (1.0e+15 + 1.0e+4) , "1.00000000001e15" ) + , ( (1.0e+15 + 1.0e+5) , "1.0000000001e15" ) + , ( (1.0e+15 + 1.0e+6) , "1.000000001e15" ) + , ( (1.0e+15 + 1.0e+7) , "1.00000001e15" ) + , ( (1.0e+15 + 1.0e+8) , "1.0000001e15" ) + , ( (1.0e+15 + 1.0e+9) , "1.000001e15" ) + , ( (1.0e+15 + 1.0e+10) , "1.00001e15" ) + , ( (1.0e+15 + 1.0e+11) , "1.0001e15" ) + , ( (1.0e+15 + 1.0e+12) , "1.001e15" ) + , ( (1.0e+15 + 1.0e+13) , "1.01e15" ) + , ( (1.0e+15 + 1.0e+14) , "1.1e15" ) + + -- Largest power of 2 <= 10^(i+1) + , ( 8.0 , "8.0" ) + , ( 64.0 , "64.0" ) + , ( 512.0 , "512.0" ) + , ( 8192.0 , "8192.0" ) + , ( 65536.0 , "65536.0" ) + , ( 524288.0 , "524288.0" ) + , ( 8388608.0 , "8388608.0" ) + , ( 67108864.0 , "6.7108864e7" ) + , ( 536870912.0 , "5.36870912e8" ) + , ( 8589934592.0 , "8.589934592e9" ) + , ( 68719476736.0 , "6.8719476736e10" ) + , ( 549755813888.0 , "5.49755813888e11" ) + , ( 8796093022208.0 , "8.796093022208e12" ) + , ( 70368744177664.0 , "7.0368744177664e13" ) + , ( 562949953421312.0 , "5.62949953421312e14" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + -- 1000 * (Largest power of 2 <= 10^(i+1)) + , ( 8.0e+3 , "8000.0" ) + , ( 64.0e+3 , "64000.0" ) + , ( 512.0e+3 , "512000.0" ) + , ( 8192.0e+3 , "8192000.0" ) + , ( 65536.0e+3 , "6.5536e7" ) + , ( 524288.0e+3 , "5.24288e8" ) + , ( 8388608.0e+3 , "8.388608e9" ) + , ( 67108864.0e+3 , "6.7108864e10" ) + , ( 536870912.0e+3 , "5.36870912e11" ) + , ( 8589934592.0e+3 , "8.589934592e12" ) + , ( 68719476736.0e+3 , "6.8719476736e13" ) + , ( 549755813888.0e+3 , "5.49755813888e14" ) + , ( 8796093022208.0e+3 , "8.796093022208e15" ) + ] + ] , testMatches "f2sPowersOf10" floatDec show $ fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] , testMatches "d2sPowersOf10" doubleDec show $ From b98fc5d80f9a2754d5a7c5849f433b7829189de5 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 14 Jan 2024 22:00:23 -0500 Subject: [PATCH 07/34] differencated special values from basic values and Float from Double --- .../builder/Data/ByteString/Builder/Tests.hs | 59 ++++++++++--------- 1 file changed, 32 insertions(+), 27 deletions(-) diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index cd264250e..637b5d54f 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -641,18 +641,20 @@ testsASCII = where enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) -testsFloating :: [TestTree] +testsFloating :: TestTree testsFloating = testGroup "RealFloat" [ testGroup "Float" - [ testMatches "f2sBasic" floatDec show + [ testMatches "f2sNonNumbersAndZero" floatDec show [ ( 0.0 , "0.0" ) , ( (-0.0) , "-0.0" ) - , ( 1.0 , "1.0" ) - , ( (-1.0) , "-1.0" ) , ( (0/0) , "NaN" ) , ( (1/0) , "Infinity" ) , ( (-1/0) , "-Infinity" ) ] + , testMatches "f2sBasic" floatDec show + [ ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + ] , testMatches "f2sSubnormal" floatDec show [ ( 1.1754944e-38 , "1.1754944e-38" ) ] @@ -742,12 +744,14 @@ testsFloating = testGroup "RealFloat" , ( 1.23456735e-36 , "1.23456735e-36" ) ] ] - testGroup "Double" + , testGroup "Double" [ testMatches "d2sBasic" doubleDec show + [ ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + ] + , testMatches "f2sNonNumbersAndZero" doubleDec show [ ( 0.0 , "0.0" ) , ( (-0.0) , "-0.0" ) - , ( 1.0 , "1.0" ) - , ( (-1.0) , "-1.0" ) , ( (0/0) , "NaN" ) , ( (1/0) , "Infinity" ) , ( (-1/0) , "-Infinity" ) @@ -781,22 +785,23 @@ testsFloating = testGroup "RealFloat" , ( 4.294967294 , "4.294967294e0" ) , ( 4.294967295 , "4.294967295e0" ) ] - , testGroup "d2sStandard" - [ testCase "specific" do - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3 , "12.30" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3451 , "12.35" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.999 , "1000.00" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.199 , "999.20" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.999 , "1.00" ) - singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) - singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0056 , "0.006" ) - singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0096 , "0.010" ) - singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) - singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0 , "0.000" ) - , testProperty "standard N" \(NonNegative p, d :: Double) -> (LC.unpack . toLazyByteString) (formatDouble (standard p) d) === showFFloat (Just p) d "" - ] + , testGroup "d2sStandard" + [ testCase "specific" do + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3 , "12.30" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3451 , "12.35" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.999 , "1000.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.199 , "999.20" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.999 , "1.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0056 , "0.006" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0096 , "0.010" ) + singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0 , "0.000" ) + , testProperty "standard N" \(NonNegative p, d :: Double) -> (LC.unpack . toLazyByteString) + (formatDouble (standard p) d) === showFFloat (Just p) d "" + ] , testMatches "d2sLooksLikePowerOf5" doubleDec show [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) @@ -966,11 +971,11 @@ testsFloating = testGroup "RealFloat" , ( 549755813888.0e+3 , "5.49755813888e14" ) , ( 8796093022208.0e+3 , "8.796093022208e15" ) ] + , testMatches "f2sPowersOf10" floatDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] + , testMatches "d2sPowersOf10" doubleDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] ] - , testMatches "f2sPowersOf10" floatDec show $ - fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] - , testMatches "d2sPowersOf10" doubleDec show $ - fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] ] where testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree From edd64cd86e8c38250d1c4d2a98693259861c2d2d Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 16 Jan 2024 07:32:50 -0500 Subject: [PATCH 08/34] put float test in the correct group --- tests/builder/Data/ByteString/Builder/Tests.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index 637b5d54f..f35bcfc3f 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -743,6 +743,8 @@ testsFloating = testGroup "RealFloat" , ( 1.2345678 , "1.2345678" ) , ( 1.23456735e-36 , "1.23456735e-36" ) ] + , testMatches "f2sPowersOf10" floatDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] ] , testGroup "Double" [ testMatches "d2sBasic" doubleDec show @@ -971,8 +973,6 @@ testsFloating = testGroup "RealFloat" , ( 549755813888.0e+3 , "5.49755813888e14" ) , ( 8796093022208.0e+3 , "8.796093022208e15" ) ] - , testMatches "f2sPowersOf10" floatDec show $ - fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] , testMatches "d2sPowersOf10" doubleDec show $ fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] ] From b20d7a64412610b375a66dbcc6b0c00b941432d0 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 13:04:33 -0500 Subject: [PATCH 09/34] combined FloatFormat and FormatMode --- Data/ByteString/Builder/RealFloat.hs | 33 +++++++++++++--------------- 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 1fef16a0b..b835186a8 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -102,38 +102,35 @@ doubleDec = formatDouble generic -- | Format type for use with `formatFloat` and `formatDouble`. -- -- @since 0.11.2.0 -data FloatFormat = MkFloatFormat FormatMode (Maybe Int) +data FloatFormat + = FScientific -- ^ scientific notation + | FStandard (Maybe Int) -- ^ standard notation with `Maybe Int` digits after the decimal + | FGeneric (Maybe Int) -- ^ dispatches to scientific or standard notation based on the exponent + deriving Show -- | Standard notation with `n` decimal places -- -- @since 0.11.2.0 standard :: Int -> FloatFormat -standard n = MkFloatFormat FStandard (Just n) +standard n = FStandard (Just n) -- | Standard notation with the \'default precision\' (decimal places matching `show`) -- -- @since 0.11.2.0 standardDefaultPrecision :: FloatFormat -standardDefaultPrecision = MkFloatFormat FStandard Nothing +standardDefaultPrecision = FStandard Nothing -- | Scientific notation with \'default precision\' (decimal places matching `show`) -- -- @since 0.11.2.0 scientific :: FloatFormat -scientific = MkFloatFormat FScientific Nothing +scientific = FScientific -- | 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 Nothing -- TODO: support precision argument for FGeneric and FScientific -- | Returns a rendered Float. Returns the \'shortest\' representation in @@ -161,11 +158,11 @@ data FormatMode -- @since 0.11.2.0 {-# INLINABLE formatFloat #-} formatFloat :: FloatFormat -> Float -> Builder -formatFloat (MkFloatFormat fmt prec) = \f -> +formatFloat fmt = \f -> let (RF.FloatingDecimal m e) = RF.f2Intermediate f e' = R.int32ToInt e + R.decimalLength9 m in case fmt of - FGeneric -> + FGeneric prec -> case specialStr f of Just b -> b Nothing -> @@ -173,7 +170,7 @@ formatFloat (MkFloatFormat fmt prec) = \f -> then sign f `mappend` showStandard (R.word32ToWord64 m) e' prec else BP.primBounded (R.toCharsScientific (f < 0) m e) () FScientific -> RF.f2s f - FStandard -> + FStandard prec -> case specialStr f of Just b -> b Nothing -> sign f `mappend` showStandard (R.word32ToWord64 m) e' prec @@ -204,11 +201,11 @@ formatFloat (MkFloatFormat fmt prec) = \f -> -- @since 0.11.2.0 {-# INLINABLE formatDouble #-} formatDouble :: FloatFormat -> Double -> Builder -formatDouble (MkFloatFormat fmt prec) = \f -> +formatDouble fmt = \f -> let (RD.FloatingDecimal m e) = RD.d2Intermediate f e' = R.int32ToInt e + R.decimalLength17 m in case fmt of - FGeneric -> + FGeneric prec -> case specialStr f of Just b -> b Nothing -> @@ -216,7 +213,7 @@ formatDouble (MkFloatFormat fmt prec) = \f -> then sign f `mappend` showStandard m e' prec else BP.primBounded (R.toCharsScientific (f < 0) m e) () FScientific -> RD.d2s f - FStandard -> + FStandard prec -> case specialStr f of Just b -> b Nothing -> sign f `mappend` showStandard m e' prec From b22b6b3459d2ed5637597870e81c460b4fe8e152 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 13:17:23 -0500 Subject: [PATCH 10/34] customized FGeneric exponent range --- Data/ByteString/Builder/RealFloat.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index b835186a8..1dd709995 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -105,7 +105,7 @@ doubleDec = formatDouble generic data FloatFormat = FScientific -- ^ scientific notation | FStandard (Maybe Int) -- ^ standard notation with `Maybe Int` digits after the decimal - | FGeneric (Maybe Int) -- ^ dispatches to scientific or standard notation based on the exponent + | FGeneric (Maybe Int) (Int,Int) -- ^ dispatches to scientific or standard notation based on the exponent deriving Show -- | Standard notation with `n` decimal places @@ -130,7 +130,7 @@ scientific = FScientific -- -- @since 0.11.2.0 generic :: FloatFormat -generic = FGeneric Nothing +generic = FGeneric Nothing (0,7) -- TODO: support precision argument for FGeneric and FScientific -- | Returns a rendered Float. Returns the \'shortest\' representation in @@ -162,11 +162,11 @@ formatFloat fmt = \f -> let (RF.FloatingDecimal m e) = RF.f2Intermediate f e' = R.int32ToInt e + R.decimalLength9 m in case fmt of - FGeneric prec -> + FGeneric prec (minExpo,maxExpo) -> case specialStr f of Just b -> b Nothing -> - if e' >= 0 && e' <= 7 + if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard (R.word32ToWord64 m) e' prec else BP.primBounded (R.toCharsScientific (f < 0) m e) () FScientific -> RF.f2s f @@ -205,11 +205,11 @@ formatDouble fmt = \f -> let (RD.FloatingDecimal m e) = RD.d2Intermediate f e' = R.int32ToInt e + R.decimalLength17 m in case fmt of - FGeneric prec -> + FGeneric prec (minExpo,maxExpo) -> case specialStr f of Just b -> b Nothing -> - if e' >= 0 && e' <= 7 + if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard m e' prec else BP.primBounded (R.toCharsScientific (f < 0) m e) () FScientific -> RD.d2s f From 37e8d22dda4e2285dedf6d3223f40df1fe624429 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 14:57:31 -0500 Subject: [PATCH 11/34] FScientific now has a selectable case E --- Data/ByteString/Builder/RealFloat.hs | 25 +++++++----- Data/ByteString/Builder/RealFloat/D2S.hs | 5 ++- Data/ByteString/Builder/RealFloat/F2S.hs | 5 ++- Data/ByteString/Builder/RealFloat/Internal.hs | 40 +++++++++---------- 4 files changed, 40 insertions(+), 35 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 1dd709995..c45a771a5 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -78,6 +79,8 @@ import qualified Data.ByteString.Builder.Prim as BP import GHC.Float (roundTo) import GHC.Word (Word64) import GHC.Show (intToDigit) +import Data.Char (ord) +import GHC.Prim (Word8#) -- | Returns a rendered Float. Matches `show` in displaying in standard or -- scientific notation @@ -103,10 +106,12 @@ doubleDec = formatDouble generic -- -- @since 0.11.2.0 data FloatFormat - = FScientific -- ^ scientific notation + = FScientific Word8# -- ^ scientific notation | FStandard (Maybe Int) -- ^ standard notation with `Maybe Int` digits after the decimal - | FGeneric (Maybe Int) (Int,Int) -- ^ dispatches to scientific or standard notation based on the exponent + | FGeneric Word8# (Maybe Int) (Int,Int) -- ^ dispatches to scientific or standard notation based on the exponent deriving Show +fScientific eE = FScientific (R.asciiRaw $ ord eE) +fGeneric eE = FGeneric (R.asciiRaw $ ord eE) -- | Standard notation with `n` decimal places -- @@ -124,13 +129,13 @@ standardDefaultPrecision = FStandard Nothing -- -- @since 0.11.2.0 scientific :: FloatFormat -scientific = FScientific +scientific = fScientific 'e' -- | Standard or scientific notation depending on the exponent. Matches `show` -- -- @since 0.11.2.0 generic :: FloatFormat -generic = FGeneric Nothing (0,7) +generic = fGeneric 'e' Nothing (0,7) -- TODO: support precision argument for FGeneric and FScientific -- | Returns a rendered Float. Returns the \'shortest\' representation in @@ -162,14 +167,14 @@ formatFloat fmt = \f -> let (RF.FloatingDecimal m e) = RF.f2Intermediate f e' = R.int32ToInt e + R.decimalLength9 m in case fmt of - FGeneric prec (minExpo,maxExpo) -> + FGeneric eE prec (minExpo,maxExpo) -> case specialStr f of Just b -> b Nothing -> if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard (R.word32ToWord64 m) e' prec - else BP.primBounded (R.toCharsScientific (f < 0) m e) () - FScientific -> RF.f2s f + else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () + FScientific eE -> RF.f2s eE f FStandard prec -> case specialStr f of Just b -> b @@ -205,14 +210,14 @@ formatDouble fmt = \f -> let (RD.FloatingDecimal m e) = RD.d2Intermediate f e' = R.int32ToInt e + R.decimalLength17 m in case fmt of - FGeneric prec (minExpo,maxExpo) -> + FGeneric eE prec (minExpo,maxExpo) -> case specialStr f of Just b -> b Nothing -> if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard m e' prec - else BP.primBounded (R.toCharsScientific (f < 0) m e) () - FScientific -> RD.d2s f + else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () + FScientific eE -> RD.d2s eE f FStandard prec -> case specialStr f of Just b -> b diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index fb5e8c008..78ba46919 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -24,6 +24,7 @@ import Data.Maybe (fromMaybe) import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word64(..)) +import GHC.Prim (Word8#) -- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level -- explanation of the ryu algorithm @@ -222,8 +223,8 @@ d2s' formatter specialFormatter d = in formatter sign m e -- | Render a Double in scientific notation -d2s :: Double -> Builder -d2s d = primBounded (d2s' toCharsScientific toCharsNonNumbersAndZero d) () +d2s :: Word8# -> Double -> Builder +d2s eE d = primBounded (d2s' (toCharsScientific eE) toCharsNonNumbersAndZero d) () -- | Returns the decimal representation of a Double. NaN and Infinity will -- return `FloatingDecimal 0 0` diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 1e64e83ff..a882bf442 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -22,6 +22,7 @@ import Data.ByteString.Builder.RealFloat.Internal import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word32(..), Word64(..)) +import GHC.Prim (Word8#) -- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level -- explanation of the ryu algorithm @@ -202,8 +203,8 @@ f2s' formatter specialFormatter f = in formatter sign m e -- | Render a Float in scientific notation -f2s :: Float -> Builder -f2s f = primBounded (f2s' toCharsScientific toCharsNonNumbersAndZero f) () +f2s :: Word8# -> Float -> Builder +f2s eE f = primBounded (f2s' (toCharsScientific eE) toCharsNonNumbersAndZero f) () -- | Returns the decimal representation of a Float. NaN and Infinity will -- return `FloatingDecimal 0 0` diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index ccfdc5cc0..c942ed7c9 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -38,6 +38,7 @@ module Data.ByteString.Builder.RealFloat.Internal , trimNoTrailing , closestCorrectlyRounded , toCharsScientific + , asciiRaw -- hand-rolled division and remainder for f2s and d2s , fquot10 , frem10 @@ -689,8 +690,8 @@ closestCorrectlyRounded acceptBound s = vv s + boolToWord roundUp roundUp = (vv s == vu s && outsideBounds) || lastRemovedDigit s >= 5 -- Wrappe around int2Word# -asciiRaw :: Int -> Word# -asciiRaw (I# i) = int2Word# i +asciiRaw :: Int -> Word8# +asciiRaw (I# i) = wordToWord8# (int2Word# i) asciiZero :: Int asciiZero = ord '0' @@ -701,12 +702,9 @@ asciiDot = ord '.' asciiMinus :: Int asciiMinus = ord '-' -ascii_e :: Int -ascii_e = ord 'e' - -- | Convert a single-digit number to the ascii ordinal e.g '1' -> 0x31 toAscii :: Word# -> Word# -toAscii a = a `plusWord#` asciiRaw asciiZero +toAscii a = a `plusWord#` word8ToWord# (asciiRaw asciiZero) -- | Index into the 64-bit word lookup table provided {-# INLINE getWord64At #-} @@ -735,12 +733,12 @@ packWord16 l h = #endif -- | Unpacks a 16-bit word into 2 bytes [lsb, msb] -unpackWord16 :: Word# -> (# Word#, Word# #) +unpackWord16 :: Word# -> (# Word8#, Word8# #) unpackWord16 w = #if defined(WORDS_BIGENDIAN) - (# w `and#` 0xff##, w `uncheckedShiftRL#` 8# #) + (# wordToWord8# (w `and#` 0xff##), wordToWord8# (w `uncheckedShiftRL#` 8#) #) #else - (# w `uncheckedShiftRL#` 8#, w `and#` 0xff## #) + (# wordToWord8# (w `uncheckedShiftRL#` 8#), wordToWord8# (w `and#` 0xff##) #) #endif @@ -772,12 +770,12 @@ copyWord16 w a s = let (# s', _ #) -> s' -- | Write an 8-bit word into the given address -poke :: Addr# -> Word# -> State# d -> State# d +poke :: Addr# -> Word8# -> State# d -> State# d poke a w s = #if __GLASGOW_HASKELL__ >= 902 - writeWord8OffAddr# a 0# (wordToWord8# w) s -#else writeWord8OffAddr# a 0# w s +#else + writeWord8OffAddr# a 0# (word8ToWord# w) s #endif -- | Write the mantissa into the given address. This function attempts to @@ -809,12 +807,12 @@ writeMantissa ptr olength = go (ptr `plusAddr#` olength) s4 = poke ptr msb s3 in (# ptr `plusAddr#` (olength +# 1#), s4 #) | (I# olength) > 1 = - let s2 = copyWord16 (packWord16 (asciiRaw asciiDot) (toAscii (unsafeRaw mantissa))) ptr s1 + let s2 = copyWord16 (packWord16 (word8ToWord# (asciiRaw asciiDot)) (toAscii (unsafeRaw mantissa))) ptr s1 in (# ptr `plusAddr#` (olength +# 1#), s2 #) | otherwise = let s2 = poke (ptr `plusAddr#` 2#) (asciiRaw asciiZero) s1 s3 = poke (ptr `plusAddr#` 1#) (asciiRaw asciiDot) s2 - s4 = poke ptr (toAscii (unsafeRaw mantissa)) s3 + s4 = poke ptr (wordToWord8# (toAscii (unsafeRaw mantissa))) s3 in (# ptr `plusAddr#` 3#, s4 #) -- | Write the exponent into the given address. @@ -823,13 +821,13 @@ writeExponent ptr !expo s1 | expo >= 100 = let !(e1, e0) = fquotRem10 (fromIntegral expo) -- TODO s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw e1)) ptr s1 - s3 = poke (ptr `plusAddr#` 2#) (toAscii (unsafeRaw e0)) s2 + s3 = poke (ptr `plusAddr#` 2#) (wordToWord8# (toAscii (unsafeRaw e0))) s2 in (# ptr `plusAddr#` 3#, s3 #) | expo >= 10 = let s2 = copyWord16 (digit_table `unsafeAt` e) ptr s1 in (# ptr `plusAddr#` 2#, s2 #) | otherwise = - let s2 = poke ptr (toAscii (int2Word# e)) s1 + let s2 = poke ptr (wordToWord8# (toAscii (int2Word# e))) s1 in (# ptr `plusAddr#` 1#, s2 #) where !(I# e) = int32ToInt expo @@ -843,16 +841,16 @@ writeSign ptr False s = (# ptr, s #) -- | Returns the decimal representation of a floating point number in -- scientific (exponential) notation {-# INLINABLE toCharsScientific #-} -{-# SPECIALIZE toCharsScientific :: Bool -> Word32 -> Int32 -> BoundedPrim () #-} -{-# SPECIALIZE toCharsScientific :: Bool -> Word64 -> Int32 -> BoundedPrim () #-} -toCharsScientific :: (Mantissa a) => Bool -> a -> Int32 -> BoundedPrim () -toCharsScientific !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do +{-# SPECIALIZE toCharsScientific :: Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} +{-# SPECIALIZE toCharsScientific :: Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} +toCharsScientific :: (Mantissa a) => Word8# -> Bool -> a -> Int32 -> BoundedPrim () +toCharsScientific !eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do let !olength@(I# ol) = decimalLength mantissa !expo' = expo + intToInt32 olength - 1 IO $ \s1 -> let !(# p1, s2 #) = writeSign p0 sign s1 !(# p2, s3 #) = writeMantissa p1 ol mantissa s2 - s4 = poke p2 (asciiRaw ascii_e) s3 + s4 = poke p2 eE s3 !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 !(# p4, s6 #) = writeExponent p3 (abs expo') s5 in (# s6, (Ptr p4) #) From 1b16c67f963617bf59b60f49cf854295e60dfd9e Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 15:18:08 -0500 Subject: [PATCH 12/34] generaized FloatingDecimal and intermediate --- Data/ByteString/Builder/RealFloat.hs | 8 +++++-- Data/ByteString/Builder/RealFloat/D2S.hs | 16 +++++--------- Data/ByteString/Builder/RealFloat/F2S.hs | 12 ++++------ Data/ByteString/Builder/RealFloat/Internal.hs | 22 +++++++++++++++++++ 4 files changed, 38 insertions(+), 20 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index c45a771a5..8ac118971 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -164,7 +164,7 @@ generic = fGeneric 'e' Nothing (0,7) {-# INLINABLE formatFloat #-} formatFloat :: FloatFormat -> Float -> Builder formatFloat fmt = \f -> - let (RF.FloatingDecimal m e) = RF.f2Intermediate f + let (R.FloatingDecimal m e) = intermediate f e' = R.int32ToInt e + R.decimalLength9 m in case fmt of FGeneric eE prec (minExpo,maxExpo) -> @@ -207,7 +207,7 @@ formatFloat fmt = \f -> {-# INLINABLE formatDouble #-} formatDouble :: FloatFormat -> Double -> Builder formatDouble fmt = \f -> - let (RD.FloatingDecimal m e) = RD.d2Intermediate f + let (R.FloatingDecimal m e) = intermediate f e' = R.int32ToInt e + R.decimalLength17 m in case fmt of FGeneric eE prec (minExpo,maxExpo) -> @@ -223,6 +223,10 @@ formatDouble fmt = \f -> Just b -> b Nothing -> sign f `mappend` showStandard m e' prec +class Intermediate a where intermediate :: a -> R.FloatingDecimal a +instance Intermediate Float where intermediate = RF.f2Intermediate +instance Intermediate Double where intermediate = RD.d2Intermediate + -- | Char7 encode a 'Char'. {-# INLINE char7 #-} char7 :: Char -> Builder diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index 78ba46919..6828bf606 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -10,8 +10,7 @@ -- Implementation of double-to-string conversion module Data.ByteString.Builder.RealFloat.D2S - ( FloatingDecimal(..) - , d2s + ( d2s , d2Intermediate ) where @@ -55,13 +54,10 @@ double_exponent_bits = 11 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) @@ -84,7 +80,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 @@ -171,7 +167,7 @@ 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 :: Word64 -> Word64 -> FD d2d m e = let !mf = if e == 0 then m @@ -228,5 +224,5 @@ d2s eE d = primBounded (d2s' (toCharsScientific eE) toCharsNonNumbersAndZero d) -- | Returns the decimal representation of a Double. NaN and Infinity will -- return `FloatingDecimal 0 0` -d2Intermediate :: Double -> FloatingDecimal +d2Intermediate :: Double -> FD d2Intermediate = d2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index a882bf442..78c350e4d 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -9,8 +9,7 @@ -- Implementation of float-to-string conversion module Data.ByteString.Builder.RealFloat.F2S - ( FloatingDecimal(..) - , f2s + ( f2s , f2Intermediate ) where @@ -53,10 +52,7 @@ float_exponent_bits = 8 float_bias :: Int float_bias = 127 -data FloatingDecimal = FloatingDecimal - { fmantissa :: !Word32 - , fexponent :: !Int32 - } deriving (Show, Eq) +type FD = FloatingDecimal Float -- | Multiply a 32-bit number with a 64-bit number while keeping the upper 64 -- bits. Then shift by specified amount minus 32 @@ -152,7 +148,7 @@ f2dLT e2' u v w = -- | Returns the decimal representation of the given mantissa and exponent of a -- 32-bit Float using the ryu algorithm. -f2d :: Word32 -> Word32 -> FloatingDecimal +f2d :: Word32 -> Word32 -> FD f2d m e = let !mf = if e == 0 then m @@ -208,5 +204,5 @@ f2s eE f = primBounded (f2s' (toCharsScientific eE) toCharsNonNumbersAndZero f) -- | Returns the decimal representation of a Float. NaN and Infinity will -- return `FloatingDecimal 0 0` -f2Intermediate :: Float -> FloatingDecimal +f2Intermediate :: Float -> FD f2Intermediate = f2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index c942ed7c9..5925e8973 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -2,6 +2,10 @@ {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.ByteString.Builder.RealFloat.Internal -- Copyright : (c) Lawrence Wu 2021 @@ -64,6 +68,8 @@ module Data.ByteString.Builder.RealFloat.Internal , word64ToInt , word32ToWord64 , word64ToWord32 + -- joining Float and Double logic + , FloatingDecimal(..) , module Data.ByteString.Builder.RealFloat.TableGenerator ) where @@ -854,3 +860,19 @@ toCharsScientific !eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 !(# p4, s6 #) = writeExponent p3 (abs expo') s5 in (# s6, (Ptr p4) #) + +data FloatingDecimal a = FloatingDecimal + { fmantissa :: !(MantissaWord a) + , fexponent :: !(ExponentInt a) + } +deriving instance (Show (MantissaWord a), Show (ExponentInt a)) => Show (FloatingDecimal a) +deriving instance (Eq (MantissaWord a), Eq (ExponentInt a)) => Eq (FloatingDecimal a) + +type family MantissaWord a +type instance MantissaWord Float = Word32 +type instance MantissaWord Double = Word64 + +type family ExponentInt a +type instance ExponentInt Float = Int32 +type instance ExponentInt Double = Int32 + From d3cdedc042a3ebcd068cd7835851ef8c276b77a4 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 15:26:08 -0500 Subject: [PATCH 13/34] generailized decimalLength --- Data/ByteString/Builder/RealFloat.hs | 4 ++-- Data/ByteString/Builder/RealFloat/Internal.hs | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 8ac118971..c8776303f 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -165,7 +165,7 @@ generic = fGeneric 'e' Nothing (0,7) formatFloat :: FloatFormat -> Float -> Builder formatFloat fmt = \f -> let (R.FloatingDecimal m e) = intermediate f - e' = R.int32ToInt e + R.decimalLength9 m in + e' = R.int32ToInt e + R.decimalLength m in case fmt of FGeneric eE prec (minExpo,maxExpo) -> case specialStr f of @@ -208,7 +208,7 @@ formatFloat fmt = \f -> formatDouble :: FloatFormat -> Double -> Builder formatDouble fmt = \f -> let (R.FloatingDecimal m e) = intermediate f - e' = R.int32ToInt e + R.decimalLength17 m in + e' = R.int32ToInt e + R.decimalLength m in case fmt of FGeneric eE prec (minExpo,maxExpo) -> case specialStr f of diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 5925e8973..2c516fedc 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -27,8 +27,7 @@ module Data.ByteString.Builder.RealFloat.Internal ( mask , NonNumbersAndZero(..) , toCharsNonNumbersAndZero - , decimalLength9 - , decimalLength17 + , DecimalLength(..) , Mantissa , pow5bits , log10pow2 @@ -184,6 +183,10 @@ decimalLength17 v | v >= 10 = 2 | otherwise = 1 +class DecimalLength a where decimalLength :: a -> Int +instance DecimalLength Word32 where decimalLength = decimalLength9 +instance DecimalLength Word64 where decimalLength = decimalLength17 + -- From 'In-and-Out Conversions' https://dl.acm.org/citation.cfm?id=362887, we -- have that a conversion from a base-b n-digit number to a base-v m-digit -- number such that the round-trip conversion is identity requires @@ -527,7 +530,6 @@ class (FiniteBits a, Integral a) => Mantissa a where unsafeRaw :: a -> Word# raw :: a -> WORD64 - decimalLength :: a -> Int boolToWord :: Bool -> a quotRem10 :: a -> (a, a) quot10 :: a -> a @@ -547,7 +549,6 @@ instance Mantissa Word32 where raw w = wordToWord64# (unsafeRaw w) #endif - decimalLength = decimalLength9 boolToWord = boolToWord32 {-# INLINE quotRem10 #-} @@ -573,7 +574,6 @@ instance Mantissa Word64 where #endif raw (W64# w) = w - decimalLength = decimalLength17 boolToWord = boolToWord64 {-# INLINE quotRem10 #-} @@ -849,7 +849,7 @@ writeSign ptr False s = (# ptr, s #) {-# INLINABLE toCharsScientific #-} {-# SPECIALIZE toCharsScientific :: Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} {-# SPECIALIZE toCharsScientific :: Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} -toCharsScientific :: (Mantissa a) => Word8# -> Bool -> a -> Int32 -> BoundedPrim () +toCharsScientific :: (Mantissa a, DecimalLength a) => Word8# -> Bool -> a -> Int32 -> BoundedPrim () toCharsScientific !eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do let !olength@(I# ol) = decimalLength mantissa !expo' = expo + intToInt32 olength - 1 From e11b30320d5f68c98a19c9756628a8eed4b3366d Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 15:30:11 -0500 Subject: [PATCH 14/34] generalized mantissa to Word64 --- Data/ByteString/Builder/RealFloat.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index c8776303f..40c90c68c 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -77,7 +77,7 @@ 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.Char (ord) import GHC.Prim (Word8#) @@ -172,7 +172,7 @@ formatFloat fmt = \f -> Just b -> b Nothing -> if e' >= minExpo && e' <= maxExpo - then sign f `mappend` showStandard (R.word32ToWord64 m) e' prec + then sign f `mappend` showStandard (toWord64 m) e' prec else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () FScientific eE -> RF.f2s eE f FStandard prec -> @@ -215,7 +215,7 @@ formatDouble fmt = \f -> Just b -> b Nothing -> if e' >= minExpo && e' <= maxExpo - then sign f `mappend` showStandard m e' prec + then sign f `mappend` showStandard (toWord64 m) e' prec else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () FScientific eE -> RD.d2s eE f FStandard prec -> @@ -227,6 +227,10 @@ class Intermediate a where intermediate :: a -> R.FloatingDecimal a instance Intermediate Float where intermediate = RF.f2Intermediate instance Intermediate Double where intermediate = RD.d2Intermediate +class ToWord64 a where toWord64 :: a -> Word64 +instance ToWord64 Word32 where toWord64 = R.word32ToWord64 +instance ToWord64 Word64 where toWord64 = id + -- | Char7 encode a 'Char'. {-# INLINE char7 #-} char7 :: Char -> Builder From aa15ac2034a853877520f1372dc60ffd587a4b8b Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 15:42:34 -0500 Subject: [PATCH 15/34] generalized f2s and d2s --- Data/ByteString/Builder/RealFloat.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 40c90c68c..78070ef5e 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -174,7 +174,7 @@ formatFloat fmt = \f -> if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard (toWord64 m) e' prec else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () - FScientific eE -> RF.f2s eE f + FScientific eE -> toS eE f FStandard prec -> case specialStr f of Just b -> b @@ -217,7 +217,7 @@ formatDouble fmt = \f -> if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard (toWord64 m) e' prec else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () - FScientific eE -> RD.d2s eE f + FScientific eE -> toS eE f FStandard prec -> case specialStr f of Just b -> b @@ -231,6 +231,10 @@ class ToWord64 a where toWord64 :: a -> Word64 instance ToWord64 Word32 where toWord64 = R.word32ToWord64 instance ToWord64 Word64 where toWord64 = id +class ToS a where toS :: Word8# -> a -> Builder +instance ToS Float where toS = RF.f2s +instance ToS Double where toS = RD.d2s + -- | Char7 encode a 'Char'. {-# INLINE char7 #-} char7 :: Char -> Builder From 053f87acbfe1fce062ff99e95fbd9fc9cd939312 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 16:10:12 -0500 Subject: [PATCH 16/34] added formatFloating which combines the logic of formatFlat and formatDouble --- Data/ByteString/Builder/RealFloat.hs | 43 +++++++++++-------- Data/ByteString/Builder/RealFloat/Internal.hs | 11 ++--- 2 files changed, 28 insertions(+), 26 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 78070ef5e..acaa7751b 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -78,6 +79,7 @@ import qualified Data.ByteString.Builder.RealFloat.D2S as RD import qualified Data.ByteString.Builder.Prim as BP import GHC.Float (roundTo) import GHC.Word (Word32, Word64) +import GHC.Int (Int32) import GHC.Show (intToDigit) import Data.Char (ord) import GHC.Prim (Word8#) @@ -163,22 +165,7 @@ generic = fGeneric 'e' Nothing (0,7) -- @since 0.11.2.0 {-# INLINABLE formatFloat #-} formatFloat :: FloatFormat -> Float -> Builder -formatFloat fmt = \f -> - let (R.FloatingDecimal m e) = intermediate f - e' = R.int32ToInt e + R.decimalLength m in - case fmt of - FGeneric eE prec (minExpo,maxExpo) -> - case specialStr f of - Just b -> b - Nothing -> - if e' >= minExpo && e' <= maxExpo - then sign f `mappend` showStandard (toWord64 m) e' prec - else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () - FScientific eE -> toS eE f - FStandard prec -> - 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 @@ -206,9 +193,24 @@ formatFloat fmt = \f -> -- @since 0.11.2.0 {-# INLINABLE formatDouble #-} formatDouble :: FloatFormat -> Double -> Builder -formatDouble fmt = \f -> +formatDouble = formatFloating + +formatFloating :: + -- a + ( ToS a + , Num a + , Ord a + , RealFloat a + , Intermediate a + -- mantissa + , mw ~ R.MantissaWord a + , R.Mantissa mw + , ToWord64 mw + , R.DecimalLength mw + ) => FloatFormat -> a -> Builder +formatFloating fmt f = let (R.FloatingDecimal m e) = intermediate f - e' = R.int32ToInt e + R.decimalLength m in + e' = toInt e + R.decimalLength m in case fmt of FGeneric eE prec (minExpo,maxExpo) -> case specialStr f of @@ -221,12 +223,15 @@ formatDouble fmt = \f -> FStandard prec -> case specialStr f of Just b -> b - Nothing -> sign f `mappend` showStandard m e' prec + Nothing -> sign f `mappend` showStandard (toWord64 m) e' prec class Intermediate a where intermediate :: a -> R.FloatingDecimal a instance Intermediate Float where intermediate = RF.f2Intermediate instance Intermediate Double where intermediate = RD.d2Intermediate +class ToInt a where toInt :: a -> Int +instance ToInt Int32 where toInt = R.int32ToInt + class ToWord64 a where toWord64 :: a -> Word64 instance ToWord64 Word32 where toWord64 = R.word32ToWord64 instance ToWord64 Word64 where toWord64 = id diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 2c516fedc..fb31827ca 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -69,6 +69,7 @@ module Data.ByteString.Builder.RealFloat.Internal , word64ToWord32 -- joining Float and Double logic , FloatingDecimal(..) + , MantissaWord , module Data.ByteString.Builder.RealFloat.TableGenerator ) where @@ -863,16 +864,12 @@ toCharsScientific !eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ data FloatingDecimal a = FloatingDecimal { fmantissa :: !(MantissaWord a) - , fexponent :: !(ExponentInt a) + , fexponent :: !Int32 } -deriving instance (Show (MantissaWord a), Show (ExponentInt a)) => Show (FloatingDecimal a) -deriving instance (Eq (MantissaWord a), Eq (ExponentInt a)) => Eq (FloatingDecimal a) +deriving instance Show (MantissaWord a) => Show (FloatingDecimal a) +deriving instance Eq (MantissaWord a) => Eq (FloatingDecimal a) type family MantissaWord a type instance MantissaWord Float = Word32 type instance MantissaWord Double = Word64 -type family ExponentInt a -type instance ExponentInt Float = Int32 -type instance ExponentInt Double = Int32 - From 40f90a4008f9fe73035329d38a4f1399fb758004 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 16:42:37 -0500 Subject: [PATCH 17/34] added SpecialStrings for scientific non-normal float values --- Data/ByteString/Builder/RealFloat.hs | 17 +++++++++++---- Data/ByteString/Builder/RealFloat/D2S.hs | 4 ++-- Data/ByteString/Builder/RealFloat/F2S.hs | 4 ++-- Data/ByteString/Builder/RealFloat/Internal.hs | 21 +++++++++++++------ 4 files changed, 32 insertions(+), 14 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index acaa7751b..ff0ba1731 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -108,7 +108,7 @@ doubleDec = formatDouble generic -- -- @since 0.11.2.0 data FloatFormat - = FScientific Word8# -- ^ scientific notation + = FScientific Word8# R.SpecialStrings -- ^ scientific notation | FStandard (Maybe Int) -- ^ standard notation with `Maybe Int` digits after the decimal | FGeneric Word8# (Maybe Int) (Int,Int) -- ^ dispatches to scientific or standard notation based on the exponent deriving Show @@ -131,7 +131,16 @@ standardDefaultPrecision = FStandard Nothing -- -- @since 0.11.2.0 scientific :: FloatFormat -scientific = fScientific 'e' +scientific = fScientific 'e' scientificSpecialStrings + +scientificSpecialStrings :: R.SpecialStrings +scientificSpecialStrings = R.SpecialStrings + { R.nan = "NaN" + , R.positiveInfinity = "Infinity" + , R.negativeInfinity = "-Infinity" + , R.positiveZero = "0.0e0" + , R.negativeZero = "-0.0e0" + } -- | Standard or scientific notation depending on the exponent. Matches `show` -- @@ -219,7 +228,7 @@ formatFloating fmt f = if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard (toWord64 m) e' prec else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () - FScientific eE -> toS eE f + FScientific eE ss -> toS eE ss f FStandard prec -> case specialStr f of Just b -> b @@ -236,7 +245,7 @@ class ToWord64 a where toWord64 :: a -> Word64 instance ToWord64 Word32 where toWord64 = R.word32ToWord64 instance ToWord64 Word64 where toWord64 = id -class ToS a where toS :: Word8# -> a -> Builder +class ToS a where toS :: Word8# -> R.SpecialStrings -> a -> Builder instance ToS Float where toS = RF.f2s instance ToS Double where toS = RD.d2s diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index 6828bf606..66605fb2b 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -219,8 +219,8 @@ d2s' formatter specialFormatter d = in formatter sign m e -- | Render a Double in scientific notation -d2s :: Word8# -> Double -> Builder -d2s eE d = primBounded (d2s' (toCharsScientific eE) toCharsNonNumbersAndZero d) () +d2s :: Word8# -> SpecialStrings -> Double -> Builder +d2s eE ss d = primBounded (d2s' (toCharsScientific eE) (toCharsNonNumbersAndZero ss) d) () -- | Returns the decimal representation of a Double. NaN and Infinity will -- return `FloatingDecimal 0 0` diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 78c350e4d..2f865d240 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -199,8 +199,8 @@ f2s' formatter specialFormatter f = in formatter sign m e -- | Render a Float in scientific notation -f2s :: Word8# -> Float -> Builder -f2s eE f = primBounded (f2s' (toCharsScientific eE) toCharsNonNumbersAndZero f) () +f2s :: Word8# -> SpecialStrings -> Float -> Builder +f2s eE ss f = primBounded (f2s' (toCharsScientific eE) (toCharsNonNumbersAndZero ss) f) () -- | Returns the decimal representation of a Float. NaN and Infinity will -- return `FloatingDecimal 0 0` diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index fb31827ca..9a31a9820 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -27,6 +27,7 @@ module Data.ByteString.Builder.RealFloat.Internal ( mask , NonNumbersAndZero(..) , toCharsNonNumbersAndZero + , SpecialStrings(..) , DecimalLength(..) , Mantissa , pow5bits @@ -258,12 +259,20 @@ data NonNumbersAndZero = NonNumbersAndZero } -- | Renders NonNumbersAndZero into bounded primitive -toCharsNonNumbersAndZero :: NonNumbersAndZero -> BoundedPrim () -toCharsNonNumbersAndZero NonNumbersAndZero{..} - | mantissa_non_zero = boundString "NaN" - | exponent_all_one = boundString $ signStr ++ "Infinity" - | otherwise = boundString $ signStr ++ "0.0e0" - where signStr = if negative then "-" else "" +toCharsNonNumbersAndZero :: SpecialStrings -> NonNumbersAndZero -> BoundedPrim () +toCharsNonNumbersAndZero SpecialStrings{..} NonNumbersAndZero{..} + | mantissa_non_zero = boundString nan + | exponent_all_one = if negative then boundString negativeInfinity else boundString positiveInfinity + | negative = boundString negativeZero + | otherwise = boundString positiveZero + +data SpecialStrings = SpecialStrings + { nan :: String + , positiveInfinity :: String + , negativeInfinity :: String + , positiveZero :: String + , negativeZero :: String + } deriving Show -- | Part of the calculation on whether to round up the decimal representation. -- This is currently a constant function to match behavior in Base `show` and From b1e3e30d08ff5b84618539be97a27d3e3ddd48c5 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 7 Jan 2024 17:02:50 -0500 Subject: [PATCH 18/34] added SpecialStrings to standard floating point non-normal values --- Data/ByteString/Builder/RealFloat.hs | 37 ++++++++++++++++------------ 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index ff0ba1731..848a82383 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -109,8 +110,8 @@ doubleDec = formatDouble generic -- @since 0.11.2.0 data FloatFormat = FScientific Word8# R.SpecialStrings -- ^ scientific notation - | FStandard (Maybe Int) -- ^ standard notation with `Maybe Int` digits after the decimal - | FGeneric Word8# (Maybe Int) (Int,Int) -- ^ dispatches to scientific or standard notation based on the exponent + | FStandard (Maybe Int) R.SpecialStrings -- ^ standard notation with `Maybe Int` digits after the decimal + | FGeneric Word8# (Maybe Int) (Int,Int) R.SpecialStrings -- ^ dispatches to scientific or standard notation based on the exponent deriving Show fScientific eE = FScientific (R.asciiRaw $ ord eE) fGeneric eE = FGeneric (R.asciiRaw $ ord eE) @@ -119,13 +120,13 @@ fGeneric eE = FGeneric (R.asciiRaw $ ord eE) -- -- @since 0.11.2.0 standard :: Int -> FloatFormat -standard n = FStandard (Just n) +standard n = FStandard (Just n) standardSpecialStrings -- | Standard notation with the \'default precision\' (decimal places matching `show`) -- -- @since 0.11.2.0 standardDefaultPrecision :: FloatFormat -standardDefaultPrecision = FStandard Nothing +standardDefaultPrecision = FStandard Nothing standardSpecialStrings -- | Scientific notation with \'default precision\' (decimal places matching `show`) -- @@ -133,7 +134,7 @@ standardDefaultPrecision = FStandard Nothing scientific :: FloatFormat scientific = fScientific 'e' scientificSpecialStrings -scientificSpecialStrings :: R.SpecialStrings +scientificSpecialStrings, standardSpecialStrings :: R.SpecialStrings scientificSpecialStrings = R.SpecialStrings { R.nan = "NaN" , R.positiveInfinity = "Infinity" @@ -141,12 +142,16 @@ scientificSpecialStrings = R.SpecialStrings , 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 = fGeneric 'e' Nothing (0,7) +generic = fGeneric 'e' Nothing (0,7) standardSpecialStrings -- TODO: support precision argument for FGeneric and FScientific -- | Returns a rendered Float. Returns the \'shortest\' representation in @@ -221,16 +226,16 @@ formatFloating fmt f = let (R.FloatingDecimal m e) = intermediate f e' = toInt e + R.decimalLength m in case fmt of - FGeneric eE prec (minExpo,maxExpo) -> - case specialStr f of + FGeneric eE prec (minExpo,maxExpo) ss -> + case specialStr ss f of Just b -> b Nothing -> if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard (toWord64 m) e' prec else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () FScientific eE ss -> toS eE ss f - FStandard prec -> - case specialStr f of + FStandard prec ss -> + case specialStr ss f of Just b -> b Nothing -> sign f `mappend` showStandard (toWord64 m) e' prec @@ -265,12 +270,12 @@ 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" +specialStr :: RealFloat a => R.SpecialStrings -> a -> Maybe Builder +specialStr R.SpecialStrings{..} f + | isNaN f = Just $ string7 nan + | isInfinite f = Just $ if f < 0 then string7 negativeInfinity else string7 positiveInfinity + | isNegativeZero f = Just $ string7 negativeZero + | f == 0 = Just $ string7 positiveZero | otherwise = Nothing -- | Returns a list of decimal digits in a Word64 From 945916ba7fcbd1cc4df45763587b3c7971d211d7 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 9 Jan 2024 05:33:05 -0500 Subject: [PATCH 19/34] RealFloat optimizations --- Data/ByteString/Builder/RealFloat.hs | 19 ++++++++++--------- Data/ByteString/Builder/RealFloat/D2S.hs | 1 + Data/ByteString/Builder/RealFloat/F2S.hs | 1 + Data/ByteString/Builder/RealFloat/Internal.hs | 12 +++++++----- 4 files changed, 19 insertions(+), 14 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 848a82383..285c506e5 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -93,7 +94,7 @@ import GHC.Prim (Word8#) -- @ {-# INLINABLE floatDec #-} floatDec :: Float -> Builder -floatDec = formatFloat generic +floatDec = formatFloating generic -- | Returns a rendered Double. Matches `show` in displaying in standard or -- scientific notation @@ -103,7 +104,7 @@ floatDec = formatFloat generic -- @ {-# INLINABLE doubleDec #-} doubleDec :: Double -> Builder -doubleDec = formatDouble generic +doubleDec = formatFloating generic -- | Format type for use with `formatFloat` and `formatDouble`. -- @@ -209,6 +210,9 @@ formatFloat = formatFloating formatDouble :: FloatFormat -> Double -> Builder formatDouble = formatFloating +{-# INLINABLE formatFloating #-} +{-# SPECIALIZE formatFloating :: FloatFormat -> Float -> Builder #-} +{-# SPECIALIZE formatFloating :: FloatFormat -> Double -> Builder #-} formatFloating :: -- a ( ToS a @@ -222,19 +226,16 @@ formatFloating :: , ToWord64 mw , R.DecimalLength mw ) => FloatFormat -> a -> Builder -formatFloating fmt f = - let (R.FloatingDecimal m e) = intermediate f - e' = toInt e + R.decimalLength m in - case fmt of - FGeneric eE prec (minExpo,maxExpo) ss -> +formatFloating = \case + FGeneric eE prec (minExpo,maxExpo) ss -> \f -> let (R.FloatingDecimal m e) = intermediate f; e' = toInt e + R.decimalLength m in case specialStr ss f of Just b -> b Nothing -> if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard (toWord64 m) e' prec else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () - FScientific eE ss -> toS eE ss f - FStandard prec ss -> + FScientific eE ss -> toS eE ss + FStandard prec ss -> \f -> let (R.FloatingDecimal m e) = intermediate f; e' = toInt e + R.decimalLength m in case specialStr ss f of Just b -> b Nothing -> sign f `mappend` showStandard (toWord64 m) e' prec diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index 66605fb2b..000e3d4c2 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -224,5 +224,6 @@ d2s eE ss d = primBounded (d2s' (toCharsScientific eE) (toCharsNonNumbersAndZero -- | Returns the decimal representation of a Double. NaN and Infinity will -- return `FloatingDecimal 0 0` +{-# INLINE d2Intermediate #-} d2Intermediate :: Double -> FD d2Intermediate = d2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 2f865d240..4ab79f821 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -204,5 +204,6 @@ f2s eE ss f = primBounded (f2s' (toCharsScientific eE) (toCharsNonNumbersAndZero -- | Returns the decimal representation of a Float. NaN and Infinity will -- return `FloatingDecimal 0 0` +{-# INLINE f2Intermediate #-} f2Intermediate :: Float -> FD f2Intermediate = f2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 9a31a9820..3e24dfd8f 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -6,6 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiWayIf #-} -- | -- Module : Data.ByteString.Builder.RealFloat.Internal -- Copyright : (c) Lawrence Wu 2021 @@ -259,12 +260,13 @@ data NonNumbersAndZero = NonNumbersAndZero } -- | Renders NonNumbersAndZero into bounded primitive +{-# INLINE toCharsNonNumbersAndZero #-} toCharsNonNumbersAndZero :: SpecialStrings -> NonNumbersAndZero -> BoundedPrim () -toCharsNonNumbersAndZero SpecialStrings{..} NonNumbersAndZero{..} - | mantissa_non_zero = boundString nan - | exponent_all_one = if negative then boundString negativeInfinity else boundString positiveInfinity - | negative = boundString negativeZero - | otherwise = boundString positiveZero +toCharsNonNumbersAndZero SpecialStrings{..} = boundString . \(NonNumbersAndZero{..}) -> if + | mantissa_non_zero -> nan + | exponent_all_one -> if negative then negativeInfinity else positiveInfinity + | negative -> negativeZero + | otherwise -> positiveZero data SpecialStrings = SpecialStrings { nan :: String From 08c5050dfe2a576dca8195ee92ba59ac083476fc Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 9 Jan 2024 10:46:19 -0500 Subject: [PATCH 20/34] generalized breakdown --- Data/ByteString/Builder/RealFloat/D2S.hs | 22 ++------- Data/ByteString/Builder/RealFloat/F2S.hs | 25 ++-------- Data/ByteString/Builder/RealFloat/Internal.hs | 46 +++++++++++++++++++ 3 files changed, 53 insertions(+), 40 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index 000e3d4c2..6eeedc768 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Builder.RealFloat.D2S -- Copyright : (c) Lawrence Wu 2021 @@ -40,15 +41,7 @@ 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 @@ -195,21 +188,12 @@ d2d m e = !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) + in if (expo == mask (exponentBits @Double)) || (expo == 0 && mantissa == 0) then specialFormatter NonNumbersAndZero { negative=sign , exponent_all_one=expo > 0 diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 4ab79f821..6f7d6ebee 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns, MagicHash #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Builder.RealFloat.F2S -- Copyright : (c) Lawrence Wu 2021 @@ -38,16 +39,6 @@ foreign import ccall "&hs_bytestring_float_pow5_inv_split" foreign import ccall "&hs_bytestring_float_pow5_split" float_pow5_split :: Ptr Word64 --- | Number of mantissa bits of a 32-bit float. The number of significant bits --- (floatDigits (undefined :: Float)) is 24 since we have a leading 1 for --- normal floats and 0 for subnormal floats -float_mantissa_bits :: Int -float_mantissa_bits = 23 - --- | Number of exponent bits of a 32-bit float -float_exponent_bits :: Int -float_exponent_bits = 8 - -- | Bias in encoded 32-bit float representation (2^7 - 1) float_bias :: Int float_bias = 127 @@ -150,7 +141,8 @@ f2dLT e2' u v w = -- 32-bit Float using the ryu algorithm. f2d :: Word32 -> Word32 -> FD f2d m e = - let !mf = if e == 0 + let float_mantissa_bits = mantissaBits @Float + !mf = if e == 0 then m else (1 `unsafeShiftL` float_mantissa_bits) .|. m !ef = intToInt32 $ if e == 0 @@ -176,21 +168,12 @@ f2d m e = !e' = e10 + removed in FloatingDecimal output e' --- | Split a Float into (sign, mantissa, exponent) -breakdown :: Float -> (Bool, Word32, Word32) -breakdown f = - let bits = castFloatToWord32 f - sign = ((bits `unsafeShiftR` (float_mantissa_bits + float_exponent_bits)) .&. 1) /= 0 - mantissa = bits .&. mask float_mantissa_bits - expo = (bits `unsafeShiftR` float_mantissa_bits) .&. mask float_exponent_bits - in (sign, mantissa, expo) - -- | Dispatches to `f2d` and applies the given formatters {-# INLINE f2s' #-} f2s' :: (Bool -> Word32 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Float -> a f2s' formatter specialFormatter f = let (sign, mantissa, expo) = breakdown f - in if (expo == mask float_exponent_bits) || (expo == 0 && mantissa == 0) + in if (expo == mask (exponentBits @Float)) || (expo == 0 && mantissa == 0) then specialFormatter NonNumbersAndZero { negative=sign , exponent_all_one=expo > 0 diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 3e24dfd8f..ac4381e37 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -7,6 +7,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -- | -- Module : Data.ByteString.Builder.RealFloat.Internal -- Copyright : (c) Lawrence Wu 2021 @@ -72,6 +74,9 @@ module Data.ByteString.Builder.RealFloat.Internal -- joining Float and Double logic , FloatingDecimal(..) , MantissaWord + , breakdown + , MantissaBits(..) + , ExponentBits(..) , module Data.ByteString.Builder.RealFloat.TableGenerator ) where @@ -884,3 +889,44 @@ type family MantissaWord a type instance MantissaWord Float = Word32 type instance MantissaWord Double = Word64 +-- | Split a Double into (sign, mantissa, exponent) +{-# INLINABLE breakdown #-} +{-# SPECIALIZE breakdown :: Float -> (Bool, MantissaWord Float, ExponentWord Float) #-} +{-# SPECIALIZE breakdown :: Double -> (Bool, MantissaWord Double, ExponentWord Double) #-} +breakdown :: forall a mw ew. + ( ExponentBits a + , MantissaBits a + , CastToWord a + , mw ~ MantissaWord a + , Bits mw + , Eq mw + , Integral mw + , ew ~ ExponentWord a + , Num ew + ) => a -> (Bool, mw, ew) +breakdown f = (sign, mantissa, expo) + where + bits = castToWord f + sign = (bits .&. 1 `rotateR` 1) /= 0 + mantissa = bits .&. mask (mantissaBits @a) + expo = fromIntegral $ (bits `unsafeShiftR` mantissaBits @a) .&. mask (exponentBits @a) + +type family ExponentWord a +type instance ExponentWord Float = Word32 +type instance ExponentWord Double = Word64 + +class CastToWord a where castToWord :: a -> MantissaWord a +instance CastToWord Float where castToWord = castFloatToWord32 +instance CastToWord Double where castToWord = castDoubleToWord64 + +-- | Number of mantissa bits. The number of significant bits +-- is one more than defined since we have a leading 1 for +-- normal and 0 for subnormal. +class MantissaBits a where mantissaBits :: Int +instance MantissaBits Float where mantissaBits = 23 +instance MantissaBits Double where mantissaBits = 52 + +-- | Number of exponent bits. +class ExponentBits a where exponentBits :: Int +instance ExponentBits Float where exponentBits = 8 +instance ExponentBits Double where exponentBits = 11 From d87507b9452b310551c407a4833f3d770385b6c1 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 9 Jan 2024 14:49:21 -0500 Subject: [PATCH 21/34] added some INLINABLE to RealFloat.Internal --- Data/ByteString/Builder/RealFloat/Internal.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index ac4381e37..fc1ab381f 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -533,10 +533,12 @@ pow5_factor w count = _ -> pow5_factor q (count +# 1#) -- | Returns @True@ if value is divisible by @5^p@ +{-# INLINABLE multipleOfPowerOf5 #-} multipleOfPowerOf5 :: Mantissa a => a -> Int -> Bool multipleOfPowerOf5 value (I# p) = isTrue# (pow5_factor (raw value) 0# >=# p) -- | Returns @True@ if value is divisible by @2^p@ +{-# INLINABLE multipleOfPowerOf2 #-} multipleOfPowerOf2 :: Mantissa a => a -> Int -> Bool multipleOfPowerOf2 value p = (value .&. mask p) == 0 @@ -630,7 +632,8 @@ data BoundsState a = BoundsState -- places where vuTrailing can possible be True, we must have acceptBounds be -- True (accept_smaller) -- - The final result doesn't change the lastRemovedDigit for rounding anyway -trimTrailing :: (Show a, Mantissa a) => BoundsState a -> (BoundsState a, Int32) +{-# INLINABLE trimTrailing #-} +trimTrailing :: Mantissa a => BoundsState a -> (BoundsState a, Int32) trimTrailing !initial = (res, r + r') where !(d', r) = trimTrailing' initial @@ -674,6 +677,7 @@ trimTrailing !initial = (res, r + r') -- | Trim digits and update bookkeeping state when the table-computed -- step results has no trailing zeros (common case) +{-# INLINABLE trimNoTrailing #-} trimNoTrailing :: Mantissa a => BoundsState a -> (BoundsState a, Int32) trimNoTrailing !(BoundsState u v w ld _ _) = (BoundsState ru' rv' 0 ld' False False, c) @@ -867,7 +871,7 @@ writeSign ptr False s = (# ptr, s #) {-# SPECIALIZE toCharsScientific :: Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} {-# SPECIALIZE toCharsScientific :: Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} toCharsScientific :: (Mantissa a, DecimalLength a) => Word8# -> Bool -> a -> Int32 -> BoundedPrim () -toCharsScientific !eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do +toCharsScientific eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do let !olength@(I# ol) = decimalLength mantissa !expo' = expo + intToInt32 olength - 1 IO $ \s1 -> From 0ea0a352bbcebf5da57f93ac1d0d48b685c30103 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 9 Jan 2024 13:48:58 -0500 Subject: [PATCH 22/34] toCharsNonNumbersAndZero now accepts the sign, mantissa, and exponent parameters and returns a maybe --- Data/ByteString/Builder/RealFloat/D2S.hs | 16 +- Data/ByteString/Builder/RealFloat/F2S.hs | 16 +- Data/ByteString/Builder/RealFloat/Internal.hs | 38 +- .../Data/ByteString/Builder/Tests.hs.orig | 1001 +++++++++++++++++ .../Data/ByteString/Builder/Tests.hs.rej | 31 + 5 files changed, 1067 insertions(+), 35 deletions(-) create mode 100644 tests/builder/Data/ByteString/Builder/Tests.hs.orig create mode 100644 tests/builder/Data/ByteString/Builder/Tests.hs.rej diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index 6eeedc768..ffe8793c3 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -21,6 +21,7 @@ import Data.ByteString.Builder.Internal (Builder) import Data.ByteString.Builder.Prim (primBounded) import Data.ByteString.Builder.RealFloat.Internal import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy(Proxy)) import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word64(..)) @@ -190,24 +191,19 @@ d2d m e = -- | Dispatches to `d2d` or `d2dSmallInt` and applies the given formatters {-# INLINE d2s' #-} -d2s' :: (Bool -> Word64 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Double -> a +d2s' :: (Bool -> Word64 -> Int32 -> a) -> (Bool -> MantissaWord Double -> ExponentWord Double -> Maybe a) -> Double -> a d2s' formatter specialFormatter d = let (sign, mantissa, expo) = breakdown d - in if (expo == mask (exponentBits @Double)) || (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 flip fromMaybe (specialFormatter sign mantissa expo) $ + let FloatingDecimal m e = d2d mantissa expo in formatter sign m e -- | Render a Double in scientific notation d2s :: Word8# -> SpecialStrings -> Double -> Builder -d2s eE ss d = primBounded (d2s' (toCharsScientific eE) (toCharsNonNumbersAndZero ss) d) () +d2s eE ss d = primBounded (d2s' (toCharsScientific eE) (toCharsNonNumbersAndZero @Double Proxy ss) d) () -- | Returns the decimal representation of a Double. NaN and Infinity will -- return `FloatingDecimal 0 0` {-# INLINE d2Intermediate #-} d2Intermediate :: Double -> FD -d2Intermediate = d2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) +d2Intermediate = d2s' (const FloatingDecimal) (\_ _ _ -> Nothing) diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 6f7d6ebee..da68aa727 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -19,6 +19,8 @@ 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 Data.Proxy (Proxy(Proxy)) import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word32(..), Word64(..)) @@ -170,23 +172,19 @@ f2d m e = -- | Dispatches to `f2d` and applies the given formatters {-# INLINE f2s' #-} -f2s' :: (Bool -> Word32 -> Int32 -> a) -> (NonNumbersAndZero -> a) -> Float -> a +f2s' :: (Bool -> Word32 -> Int32 -> a) -> (Bool -> MantissaWord Float -> ExponentWord Float -> Maybe a) -> Float -> a f2s' formatter specialFormatter f = let (sign, mantissa, expo) = breakdown f - in if (expo == mask (exponentBits @Float)) || (expo == 0 && mantissa == 0) - then specialFormatter NonNumbersAndZero - { negative=sign - , exponent_all_one=expo > 0 - , mantissa_non_zero=mantissa > 0 } - else let FloatingDecimal m e = f2d mantissa expo + in flip fromMaybe (specialFormatter sign mantissa expo) $ + let FloatingDecimal m e = f2d mantissa expo in formatter sign m e -- | Render a Float in scientific notation f2s :: Word8# -> SpecialStrings -> Float -> Builder -f2s eE ss f = primBounded (f2s' (toCharsScientific eE) (toCharsNonNumbersAndZero ss) f) () +f2s eE ss f = primBounded (f2s' (toCharsScientific eE) (toCharsNonNumbersAndZero @Float Proxy ss) f) () -- | Returns the decimal representation of a Float. NaN and Infinity will -- return `FloatingDecimal 0 0` {-# INLINE f2Intermediate #-} f2Intermediate :: Float -> FD -f2Intermediate = f2s' (const FloatingDecimal) (const $ FloatingDecimal 0 0) +f2Intermediate = f2s' (const FloatingDecimal) (\_ _ _ -> Nothing) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index fc1ab381f..7ce4dd306 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -28,7 +28,6 @@ module Data.ByteString.Builder.RealFloat.Internal ( mask - , NonNumbersAndZero(..) , toCharsNonNumbersAndZero , SpecialStrings(..) , DecimalLength(..) @@ -74,6 +73,7 @@ module Data.ByteString.Builder.RealFloat.Internal -- joining Float and Double logic , FloatingDecimal(..) , MantissaWord + , ExponentWord , breakdown , MantissaBits(..) , ExponentBits(..) @@ -88,6 +88,7 @@ import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) import Data.ByteString.Builder.RealFloat.TableGenerator import Data.ByteString.Utils.UnalignedWrite import Data.Char (ord) +import Data.Proxy (Proxy) import Foreign.C.Types import GHC.Int (Int(..), Int32(..)) import GHC.IO (IO(..), unIO) @@ -258,20 +259,26 @@ boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) -- * sign = either 0 or 1. -- * biased exponent = all 0 bits. -- * fraction = all 0 bits. -data NonNumbersAndZero = NonNumbersAndZero - { negative :: Bool - , exponent_all_one :: Bool - , mantissa_non_zero :: Bool - } - --- | Renders NonNumbersAndZero into bounded primitive -{-# INLINE toCharsNonNumbersAndZero #-} -toCharsNonNumbersAndZero :: SpecialStrings -> NonNumbersAndZero -> BoundedPrim () -toCharsNonNumbersAndZero SpecialStrings{..} = boundString . \(NonNumbersAndZero{..}) -> if - | mantissa_non_zero -> nan - | exponent_all_one -> if negative then negativeInfinity else positiveInfinity - | negative -> negativeZero - | otherwise -> positiveZero +{-# INLINABLE toCharsNonNumbersAndZero #-} +{-# SPECIALIZE toCharsNonNumbersAndZero :: Proxy Float -> SpecialStrings -> Bool -> MantissaWord Float -> ExponentWord Float -> Maybe (BoundedPrim ()) #-} +{-# SPECIALIZE toCharsNonNumbersAndZero :: Proxy Double -> SpecialStrings -> Bool -> MantissaWord Double -> ExponentWord Double -> Maybe (BoundedPrim ()) #-} +toCharsNonNumbersAndZero :: forall a mw ew. + ( ExponentBits a + , Ord mw + , Num mw + , Ord ew + , Num ew + , Bits ew + , Integral ew + ) => Proxy a -> SpecialStrings -> Bool -> mw -> ew -> Maybe (BoundedPrim ()) +toCharsNonNumbersAndZero _ SpecialStrings{..} sign mantissa expo = + if (expo == mask (exponentBits @a)) || (expo == 0 && mantissa == 0) + then Just $ boundString $ if + | mantissa > 0 -> nan + | expo > 0 -> if sign then negativeInfinity else positiveInfinity + | sign -> negativeZero + | otherwise -> positiveZero + else Nothing data SpecialStrings = SpecialStrings { nan :: String @@ -905,7 +912,6 @@ breakdown :: forall a mw ew. , Bits mw , Eq mw , Integral mw - , ew ~ ExponentWord a , Num ew ) => a -> (Bool, mw, ew) breakdown f = (sign, mantissa, expo) diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs.orig b/tests/builder/Data/ByteString/Builder/Tests.hs.orig new file mode 100644 index 000000000..1058e9f1f --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Tests.hs.orig @@ -0,0 +1,1001 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Testing composition of 'Builders'. + +module Data.ByteString.Builder.Tests (tests) where + +import Prelude hiding (writeFile) + +import Control.Applicative +import Control.Monad (unless, void) +import Control.Monad.Trans.State (StateT, evalStateT, evalState, put, get) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Writer (WriterT, execWriterT, tell) + +import Foreign (minusPtr) + +import Data.Char (chr) +import Data.Bits ((.|.), shiftL) +import Data.Foldable +import Data.Semigroup (Semigroup(..)) +import Data.Word + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.ByteString.Short as Sh + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra +import Data.ByteString.Builder.Internal (Put, putBuilder, fromPut) +import qualified Data.ByteString.Builder.Internal as BI +import qualified Data.ByteString.Builder.Prim as BP +import Data.ByteString.Builder.Prim.TestUtils + +import Control.Exception (evaluate) +import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode, hSetEncoding, utf8, hSetNewlineMode, noNewlineTranslation) +import Foreign (ForeignPtr, withForeignPtr, castPtr) +import Foreign.C.String (withCString) +import Numeric (showFFloat) +import System.Posix.Internals (c_unlink) + +import Test.Tasty (TestTree, TestName, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), Assertion) +import Test.Tasty.QuickCheck + ( Arbitrary(..), oneof, choose, listOf, elements, forAll + , counterexample, ioProperty, Property, testProperty + , (===), (.&&.), conjoin + , UnicodeString(..), NonNegative(..) + ) +import QuickCheckUtils + + +tests :: [TestTree] +tests = + [ testBuilderRecipe + , testHandlePutBuilder + , testHandlePutBuilderChar8 + , testPut + , testRunBuilder + , testWriteFile + , testStimes + ] ++ + testsEncodingToBuilder ++ + testsBinary ++ + testsASCII ++ + testsFloating ++ + testsChar8 ++ + testsUtf8 + + +------------------------------------------------------------------------------ +-- Testing 'Builder' execution +------------------------------------------------------------------------------ + +testBuilderRecipe :: TestTree +testBuilderRecipe = + testProperty "toLazyByteStringWith" $ testRecipe <$> arbitrary + where + testRecipe r = + counterexample msg $ x1 == x2 + where + x1 = renderRecipe r + x2 = buildRecipe r + toString = map (chr . fromIntegral) + msg = unlines + [ "recipe: " ++ show r + , "render: " ++ toString x1 + , "build : " ++ toString x2 + , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + +testHandlePutBuilder :: TestTree +testHandlePutBuilder = + testProperty "hPutBuilder" testRecipe + where + testRecipe :: (UnicodeString, UnicodeString, UnicodeString, Recipe) -> Property + testRecipe args = + ioProperty $ do + let { ( UnicodeString before + , UnicodeString between + , UnicodeString after + , recipe) = args } + (tempFile, tempH) <- openTempFile "." "test-builder.tmp" + -- switch to UTF-8 encoding + hSetEncoding tempH utf8 + hSetNewlineMode tempH noNewlineTranslation + -- output recipe with intermediate direct writing to handle + let b = fst $ recipeComponents recipe + hPutStr tempH before + hPutBuilder tempH b + hPutStr tempH between + hPutBuilder tempH b + hPutStr tempH after + hClose tempH + -- read file + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + -- compare to pure builder implementation + let lbsRef = toLazyByteString $ fold + [stringUtf8 before, b, stringUtf8 between, b, stringUtf8 after] + -- report + let msg = unlines + [ "task: " ++ show args + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testHandlePutBuilderChar8 :: TestTree +testHandlePutBuilderChar8 = + testProperty "char8 hPutBuilder" testRecipe + where + testRecipe :: (String, String, String, Recipe) -> Property + testRecipe args@(before, between, after, recipe) = ioProperty $ do + (tempFile, tempH) <- openTempFile "." "TestBuilder" + -- switch to binary / latin1 encoding + hSetBinaryMode tempH True + -- output recipe with intermediate direct writing to handle + let b = fst $ recipeComponents recipe + hPutStr tempH before + hPutBuilder tempH b + hPutStr tempH between + hPutBuilder tempH b + hPutStr tempH after + hClose tempH + -- read file + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + -- compare to pure builder implementation + let lbsRef = toLazyByteString $ fold + [string8 before, b, string8 between, b, string8 after] + -- report + let msg = unlines + [ "task: " ++ show args + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testWriteFile :: TestTree +testWriteFile = + testProperty "writeFile" testRecipe + where + testRecipe :: Recipe -> Property + testRecipe recipe = + ioProperty $ do + (tempFile, tempH) <- openTempFile "." "test-builder-writeFile.tmp" + hClose tempH + let b = fst $ recipeComponents recipe + writeFile tempFile b + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + let lbsRef = toLazyByteString b + -- report + let msg = + unlines + [ "recipe: " ++ show recipe + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + ] + success = lbs == lbsRef + unless success (error msg) + return success + +testStimes :: TestTree +testStimes = testProperty "stimes" $ + \(Sqrt (NonNegative n)) (Sqrt x) -> + stimes (n :: Int) x === toLazyByteString (stimes n (lazyByteString x)) + +removeFile :: String -> IO () +removeFile fn = void $ withCString fn c_unlink + +-- Recipes with which to test the builder functions +--------------------------------------------------- + +data Mode = + Threshold Int + | Insert + | Copy + | Smart + | Hex + deriving( Eq, Ord, Show ) + +data Action = + SBS Mode S.ByteString + | LBS Mode L.ByteString + | ShBS Sh.ShortByteString + | W8 Word8 + | W8S [Word8] + | String String + | FDec Float + | DDec Double + | Flush + | EnsureFree Word + | ModState Int + deriving( Eq, Ord, Show ) + +data Strategy = Safe | Untrimmed + deriving( Eq, Ord, Show ) + +data Recipe = Recipe Strategy Int Int L.ByteString [Action] + deriving( Eq, Ord, Show ) + +newtype DList a = DList ([a] -> [a]) + +instance Semigroup (DList a) where + DList f <> DList g = DList (f . g) + +instance Monoid (DList a) where + mempty = DList id + mappend = (<>) + +fromDList :: DList a -> [a] +fromDList (DList f) = f [] + +toDList :: [a] -> DList a +toDList xs = DList (xs <>) + +renderRecipe :: Recipe -> [Word8] +renderRecipe (Recipe _ firstSize _ cont as) = + fromDList $ evalState (execWriterT (traverse_ renderAction as)) firstSize <> renderLBS cont + where + renderAction :: Monad m => Action -> WriterT (DList Word8) (StateT Int m) () + renderAction (SBS Hex bs) = tell $ foldMap hexWord8 $ S.unpack bs + renderAction (SBS _ bs) = tell $ toDList $ S.unpack bs + renderAction (LBS Hex lbs) = tell $ foldMap hexWord8 $ L.unpack lbs + renderAction (LBS _ lbs) = tell $ renderLBS lbs + renderAction (ShBS sbs) = tell $ toDList $ Sh.unpack sbs + renderAction (W8 w) = tell $ toDList [w] + renderAction (W8S ws) = tell $ toDList ws + renderAction (String cs) = tell $ foldMap (toDList . charUtf8_list) cs + renderAction Flush = tell $ mempty + renderAction (EnsureFree _) = tell $ mempty + renderAction (FDec f) = tell $ toDList $ encodeASCII $ show f + renderAction (DDec d) = tell $ toDList $ encodeASCII $ show d + renderAction (ModState i) = do + s <- lift get + tell (toDList $ encodeASCII $ show s) + lift $ put (s - i) + + renderLBS = toDList . L.unpack + hexWord8 = toDList . wordHexFixed_list + +buildAction :: Action -> StateT Int Put () +buildAction (SBS Hex bs) = lift $ putBuilder $ byteStringHex bs +buildAction (SBS Smart bs) = lift $ putBuilder $ byteString bs +buildAction (SBS Copy bs) = lift $ putBuilder $ byteStringCopy bs +buildAction (SBS Insert bs) = lift $ putBuilder $ byteStringInsert bs +buildAction (SBS (Threshold i) bs) = lift $ putBuilder $ byteStringThreshold i bs +buildAction (LBS Hex lbs) = lift $ putBuilder $ lazyByteStringHex lbs +buildAction (LBS Smart lbs) = lift $ putBuilder $ lazyByteString lbs +buildAction (LBS Copy lbs) = lift $ putBuilder $ lazyByteStringCopy lbs +buildAction (LBS Insert lbs) = lift $ putBuilder $ lazyByteStringInsert lbs +buildAction (LBS (Threshold i) lbs) = lift $ putBuilder $ lazyByteStringThreshold i lbs +buildAction (ShBS sbs) = lift $ putBuilder $ shortByteString sbs +buildAction (W8 w) = lift $ putBuilder $ word8 w +buildAction (W8S ws) = lift $ putBuilder $ BP.primMapListFixed BP.word8 ws +buildAction (String cs) = lift $ putBuilder $ stringUtf8 cs +buildAction (FDec f) = lift $ putBuilder $ floatDec f +buildAction (DDec d) = lift $ putBuilder $ doubleDec d +buildAction Flush = lift $ putBuilder $ flush +buildAction (EnsureFree minFree) = lift $ putBuilder $ ensureFree $ fromIntegral minFree +buildAction (ModState i) = do + s <- get + lift $ putBuilder $ intDec s + put (s - i) + +buildRecipe :: Recipe -> [Word8] +buildRecipe recipe = + L.unpack $ toLBS b + where + (b, toLBS) = recipeComponents recipe + + +recipeComponents :: Recipe -> (Builder, Builder -> L.ByteString) +recipeComponents (Recipe how firstSize otherSize cont as) = + (b, toLBS) + where + toLBS = toLazyByteStringWith (strategy how firstSize otherSize) cont + where + strategy Safe = safeStrategy + strategy Untrimmed = untrimmedStrategy + + b = fromPut $ evalStateT (traverse_ buildAction as) firstSize + + +-- 'Arbitary' instances +----------------------- + +instance Arbitrary Mode where + arbitrary = oneof + [Threshold <$> arbitrary, pure Smart, pure Insert, pure Copy, pure Hex] + + shrink (Threshold i) = Threshold <$> shrink i + shrink _ = [] + +instance Arbitrary Action where + arbitrary = oneof + [ SBS <$> arbitrary <*> arbitrary + , LBS <$> arbitrary <*> arbitrary + , ShBS . Sh.toShort <$> arbitrary + , W8 <$> arbitrary + , W8S <$> listOf arbitrary + -- ensure that larger character codes are also tested + , String . getUnicodeString <$> arbitrary + , pure Flush + -- never request more than 64kb free space + , (EnsureFree . (`mod` 0xffff)) <$> arbitrary + , FDec <$> arbitrary + , DDec <$> arbitrary + , ModState <$> arbitrary + ] + where + + shrink (SBS m bs) = + (SBS <$> shrink m <*> pure bs) <|> + (SBS <$> pure m <*> shrink bs) + shrink (LBS m lbs) = + (LBS <$> shrink m <*> pure lbs) <|> + (LBS <$> pure m <*> shrink lbs) + shrink (ShBS sbs) = + ShBS . Sh.toShort <$> shrink (Sh.fromShort sbs) + shrink (W8 w) = W8 <$> shrink w + shrink (W8S ws) = W8S <$> shrink ws + shrink (String cs) = String <$> shrink cs + shrink Flush = [] + shrink (EnsureFree i) = EnsureFree <$> shrink i + shrink (FDec f) = FDec <$> shrink f + shrink (DDec d) = DDec <$> shrink d + shrink (ModState i) = ModState <$> shrink i + +instance Arbitrary Strategy where + arbitrary = elements [Safe, Untrimmed] + shrink _ = [] + +instance Arbitrary Recipe where + arbitrary = + Recipe <$> arbitrary + <*> ((`mod` 33333) <$> arbitrary) -- bound max chunk-sizes + <*> ((`mod` 33337) <$> arbitrary) + <*> arbitrary + <*> listOf arbitrary + + -- shrinking the actions first is desirable + shrink (Recipe a b c d e) = asum + [ (\x -> Recipe a b c d x) <$> shrink e + , (\x -> Recipe a b c x e) <$> shrink d + , (\x -> Recipe a b x d e) <$> shrink c + , (\x -> Recipe a x c d e) <$> shrink b + , (\x -> Recipe x b c d e) <$> shrink a + ] + + +------------------------------------------------------------------------------ +-- Creating Builders from basic encodings +------------------------------------------------------------------------------ + +testsEncodingToBuilder :: [TestTree] +testsEncodingToBuilder = + [ test_encodeUnfoldrF + , test_encodeUnfoldrB + ] + + +-- Unfoldr fused with encoding +------------------------------ + +test_encodeUnfoldrF :: TestTree +test_encodeUnfoldrF = + compareImpls "encodeUnfoldrF word8" id encode + where + toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty + encode = + L.unpack . toLBS . BP.primUnfoldrFixed BP.word8 go + where + go [] = Nothing + go (w:ws) = Just (w, ws) + + +test_encodeUnfoldrB :: TestTree +test_encodeUnfoldrB = + compareImpls "encodeUnfoldrB charUtf8" (foldMap charUtf8_list) encode + where + toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty + encode = + L.unpack . toLBS . BP.primUnfoldrBounded BP.charUtf8 go + where + go [] = Nothing + go (c:cs) = Just (c, cs) + + +------------------------------------------------------------------------------ +-- Testing the Put monad +------------------------------------------------------------------------------ + +testPut :: TestTree +testPut = testGroup "Put monad" + [ testLaw "identity" (\v -> (pure id <*> putInt v) `eqPut` (putInt v)) + + , testLaw "composition" $ \(u, v, w) -> + (pure (.) <*> minusInt u <*> minusInt v <*> putInt w) `eqPut` + (minusInt u <*> (minusInt v <*> putInt w)) + + , testLaw "homomorphism" $ \(f, x) -> + (pure (f -) <*> pure x) `eqPut` (pure (f - x)) + + , testLaw "interchange" $ \(u, y) -> + (minusInt u <*> pure y) `eqPut` (pure ($ y) <*> minusInt u) + + , testLaw "ignore left value" $ \(u, v) -> + (putInt u *> putInt v) `eqPut` (pure (const id) <*> putInt u <*> putInt v) + + , testLaw "ignore right value" $ \(u, v) -> + (putInt u <* putInt v) `eqPut` (pure const <*> putInt u <*> putInt v) + + , testLaw "functor" $ \(f, x) -> + (fmap (f -) (putInt x)) `eqPut` (pure (f -) <*> putInt x) + + ] + where + putInt i = putBuilder (integerDec i) >> return i + minusInt i = (-) <$> putInt i + run p = toLazyByteString $ fromPut (do i <- p; _ <- putInt i; return ()) + eqPut p1 p2 = (run p1, run p2) + + testLaw name f = compareImpls name (fst . f) (snd . f) + + +------------------------------------------------------------------------------ +-- Testing the Driver <-> Builder protocol +------------------------------------------------------------------------------ + +-- | Ensure that there are at least 'n' free bytes for the following 'Builder'. +{-# INLINE ensureFree #-} +ensureFree :: Int -> Builder +ensureFree minFree = + BI.builder step + where + step k br@(BI.BufferRange op ope) + | ope `minusPtr` op < minFree = return $ BI.bufferFull minFree op next + | otherwise = k br + where + next br'@(BI.BufferRange op' ope') + | freeSpace < minFree = + error $ "ensureFree: requested " ++ show minFree ++ " bytes, " ++ + "but got only " ++ show freeSpace ++ " bytes" + | otherwise = k br' + where + freeSpace = ope' `minusPtr` op' + + +------------------------------------------------------------------------------ +-- Testing the Builder runner +------------------------------------------------------------------------------ + +testRunBuilder :: TestTree +testRunBuilder = + testProperty "runBuilder" prop + where + prop actions = + ioProperty $ do + let (builder, _) = recipeComponents recipe + expected = renderRecipe recipe + actual <- bufferWriterOutput (runBuilder builder) + return (S.unpack actual == expected) + where + recipe = Recipe Safe 0 0 L.empty actions + +bufferWriterOutput :: BufferWriter -> IO S.ByteString +bufferWriterOutput bwrite0 = do + let len0 = 8 + buf <- S.mallocByteString len0 + bss <- go [] buf len0 bwrite0 + return (S.concat (reverse bss)) + where + go :: [S.ByteString] -> ForeignPtr Word8 -> Int -> BufferWriter -> IO [S.ByteString] + go bss !buf !len bwrite = do + (wc, next) <- withForeignPtr buf $ \ptr -> bwrite ptr len + bs <- getBuffer buf wc + case next of + Done -> return (bs:bss) + More m bwrite' | m <= len -> go (bs:bss) buf len bwrite' + | otherwise -> do let len' = m + buf' <- S.mallocByteString len' + go (bs:bss) buf' len' bwrite' + Chunk c bwrite' -> go (c:bs:bss) buf len bwrite' + + getBuffer :: ForeignPtr Word8 -> Int -> IO S.ByteString + getBuffer buf len = withForeignPtr buf $ \ptr -> + S.packCStringLen (castPtr ptr, len) + + +------------------------------------------------------------------------------ +-- Testing the pre-defined builders +------------------------------------------------------------------------------ + +testBuilderConstr :: (Arbitrary a, Show a) + => TestName -> (a -> [Word8]) -> (a -> Builder) -> TestTree +testBuilderConstr name ref mkBuilder = + testProperty name check + where + check x = forAll (choose (0, maxPaddingAmount)) $ \paddingAmount -> let + -- use padding to make sure we test at unaligned positions + ws = ref x + b1 = mkBuilder x + b2 = byteStringCopy (S.take paddingAmount padBuf) <> b1 <> b1 + in (replicate paddingAmount (S.c2w ' ') ++ ws ++ ws) === + (L.unpack $ toLazyByteString b2) + + maxPaddingAmount = 15 + padBuf = S.replicate maxPaddingAmount (S.c2w ' ') + + +testsBinary :: [TestTree] +testsBinary = + [ testBuilderConstr "word8" bigEndian_list word8 + , testBuilderConstr "int8" bigEndian_list int8 + + -- big-endian + , testBuilderConstr "int16BE" bigEndian_list int16BE + , testBuilderConstr "int32BE" bigEndian_list int32BE + , testBuilderConstr "int64BE" bigEndian_list int64BE + + , testBuilderConstr "word16BE" bigEndian_list word16BE + , testBuilderConstr "word32BE" bigEndian_list word32BE + , testBuilderConstr "word64BE" bigEndian_list word64BE + + , testBuilderConstr "floatLE" (float_list littleEndian_list) floatLE + , testBuilderConstr "doubleLE" (double_list littleEndian_list) doubleLE + + -- little-endian + , testBuilderConstr "int16LE" littleEndian_list int16LE + , testBuilderConstr "int32LE" littleEndian_list int32LE + , testBuilderConstr "int64LE" littleEndian_list int64LE + + , testBuilderConstr "word16LE" littleEndian_list word16LE + , testBuilderConstr "word32LE" littleEndian_list word32LE + , testBuilderConstr "word64LE" littleEndian_list word64LE + + , testBuilderConstr "floatBE" (float_list bigEndian_list) floatBE + , testBuilderConstr "doubleBE" (double_list bigEndian_list) doubleBE + + -- host dependent + , testBuilderConstr "int16Host" hostEndian_list int16Host + , testBuilderConstr "int32Host" hostEndian_list int32Host + , testBuilderConstr "int64Host" hostEndian_list int64Host + , testBuilderConstr "intHost" hostEndian_list intHost + + , testBuilderConstr "word16Host" hostEndian_list word16Host + , testBuilderConstr "word32Host" hostEndian_list word32Host + , testBuilderConstr "word64Host" hostEndian_list word64Host + , testBuilderConstr "wordHost" hostEndian_list wordHost + + , testBuilderConstr "floatHost" (float_list hostEndian_list) floatHost + , testBuilderConstr "doubleHost" (double_list hostEndian_list) doubleHost + ] + +testsASCII :: [TestTree] +testsASCII = + [ testBuilderConstr "char7" char7_list char7 + , testBuilderConstr "string7" (foldMap char7_list) string7 + + , testBuilderConstr "int8Dec" dec_list int8Dec + , testBuilderConstr "int16Dec" dec_list int16Dec + , testBuilderConstr "int32Dec" dec_list int32Dec + , testBuilderConstr "int64Dec" dec_list int64Dec + , testBuilderConstr "intDec" dec_list intDec + + , testBuilderConstr "word8Dec" dec_list word8Dec + , testBuilderConstr "word16Dec" dec_list word16Dec + , testBuilderConstr "word32Dec" dec_list word32Dec + , testBuilderConstr "word64Dec" dec_list word64Dec + , testBuilderConstr "wordDec" dec_list wordDec + + , testBuilderConstr "integerDec" (dec_list . enlarge) (integerDec . enlarge) + , testBuilderConstr "floatDec" dec_list floatDec + , testBuilderConstr "doubleDec" dec_list doubleDec + + , testBuilderConstr "word8Hex" hex_list word8Hex + , testBuilderConstr "word16Hex" hex_list word16Hex + , testBuilderConstr "word32Hex" hex_list word32Hex + , testBuilderConstr "word64Hex" hex_list word64Hex + , testBuilderConstr "wordHex" hex_list wordHex + + , testBuilderConstr "word8HexFixed" wordHexFixed_list word8HexFixed + , testBuilderConstr "word16HexFixed" wordHexFixed_list word16HexFixed + , testBuilderConstr "word32HexFixed" wordHexFixed_list word32HexFixed + , testBuilderConstr "word64HexFixed" wordHexFixed_list word64HexFixed + + , testBuilderConstr "int8HexFixed" int8HexFixed_list int8HexFixed + , testBuilderConstr "int16HexFixed" int16HexFixed_list int16HexFixed + , testBuilderConstr "int32HexFixed" int32HexFixed_list int32HexFixed + , testBuilderConstr "int64HexFixed" int64HexFixed_list int64HexFixed + + , testBuilderConstr "floatHexFixed" floatHexFixed_list floatHexFixed + , testBuilderConstr "doubleHexFixed" doubleHexFixed_list doubleHexFixed + ] + where + enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) + +testsFloating :: [TestTree] +testsFloating = + [ testMatches "f2sBasic" floatDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "f2sSubnormal" floatDec show + [ ( 1.1754944e-38 , "1.1754944e-38" ) + ] + , testMatches "f2sMinAndMax" floatDec show + [ ( coerceWord32ToFloat 0x7f7fffff , "3.4028235e38" ) + , ( coerceWord32ToFloat 0x00000001 , "1.0e-45" ) + ] + , testMatches "f2sBoundaryRound" floatDec show + [ ( 3.355445e7 , "3.3554448e7" ) + , ( 8.999999e9 , "8.999999e9" ) + , ( 3.4366717e10 , "3.4366718e10" ) + ] + , testMatches "f2sExactValueRound" floatDec show + [ ( 3.0540412e5 , "305404.13" ) + , ( 8.0990312e3 , "8099.0313" ) + ] + , testMatches "f2sTrailingZeros" floatDec show + -- Pattern for the first test: 00111001100000000000000000000000 + [ ( 2.4414062e-4 , "2.4414063e-4" ) + , ( 2.4414062e-3 , "2.4414063e-3" ) + , ( 4.3945312e-3 , "4.3945313e-3" ) + , ( 6.3476562e-3 , "6.3476563e-3" ) + ] + , testMatches "f2sRegression" floatDec show + [ ( 4.7223665e21 , "4.7223665e21" ) + , ( 8388608.0 , "8388608.0" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4103.9004" ) + , ( 5.3399997e9 , "5.3399997e9" ) + , ( 6.0898e-39 , "6.0898e-39" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 2.8823261e17 , "2.882326e17" ) + , ( 7.0385309e-26 , "7.038531e-26" ) + , ( 9.2234038e17 , "9.223404e17" ) + , ( 6.7108872e7 , "6.710887e7" ) + , ( 1.0e-44 , "1.0e-44" ) + , ( 2.816025e14 , "2.816025e14" ) + , ( 9.223372e18 , "9.223372e18" ) + , ( 1.5846085e29 , "1.5846086e29" ) + , ( 1.1811161e19 , "1.1811161e19" ) + , ( 5.368709e18 , "5.368709e18" ) + , ( 4.6143165e18 , "4.6143166e18" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 1.4e-45 , "1.0e-45" ) + , ( 1.18697724e20 , "1.18697725e20" ) + , ( 1.00014165e-36 , "1.00014165e-36" ) + , ( 200.0 , "200.0" ) + , ( 3.3554432e7 , "3.3554432e7" ) + , ( 2.0019531 , "2.0019531" ) + , ( 2.001953 , "2.001953" ) + ] + , testExpected "f2sScientific" (formatFloat scientific) + [ ( 0.0 , "0.0e0" ) + , ( 8388608.0 , "8.388608e6" ) + , ( 1.6777216e7 , "1.6777216e7" ) + , ( 3.3554436e7 , "3.3554436e7" ) + , ( 6.7131496e7 , "6.7131496e7" ) + , ( 1.9310392e-38 , "1.9310392e-38" ) + , ( (-2.47e-43) , "-2.47e-43" ) + , ( 1.993244e-38 , "1.993244e-38" ) + , ( 4103.9003 , "4.1039004e3" ) + , ( 0.0010310042 , "1.0310042e-3" ) + , ( 0.007812537 , "7.812537e-3" ) + , ( 200.0 , "2.0e2" ) + , ( 2.0019531 , "2.0019531e0" ) + , ( 2.001953 , "2.001953e0" ) + ] + , testMatches "f2sLooksLikePowerOf5" floatDec show + [ ( coerceWord32ToFloat 0x5D1502F9 , "6.7108864e17" ) + , ( coerceWord32ToFloat 0x5D9502F9 , "1.3421773e18" ) + , ( coerceWord32ToFloat 0x5e1502F9 , "2.6843546e18" ) + ] + , testMatches "f2sOutputLength" floatDec show + [ ( 1.0 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456735e-36 , "1.23456735e-36" ) + ] + , testMatches "d2sBasic" doubleDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) + , ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + , ( (0/0) , "NaN" ) + , ( (1/0) , "Infinity" ) + , ( (-1/0) , "-Infinity" ) + ] + , testMatches "d2sSubnormal" doubleDec show + [ ( 2.2250738585072014e-308 , "2.2250738585072014e-308" ) + ] + , testMatches "d2sMinAndMax" doubleDec show + [ ( (coerceWord64ToDouble 0x7fefffffffffffff) , "1.7976931348623157e308" ) + , ( (coerceWord64ToDouble 0x0000000000000001) , "5.0e-324" ) + ] + , testMatches "d2sTrailingZeros" doubleDec show + [ ( 2.98023223876953125e-8 , "2.9802322387695313e-8" ) + ] + , testMatches "d2sRegression" doubleDec show + [ ( (-2.109808898695963e16) , "-2.1098088986959632e16" ) + , ( 4.940656e-318 , "4.940656e-318" ) + , ( 1.18575755e-316 , "1.18575755e-316" ) + , ( 2.989102097996e-312 , "2.989102097996e-312" ) + , ( 9.0608011534336e15 , "9.0608011534336e15" ) + , ( 4.708356024711512e18 , "4.708356024711512e18" ) + , ( 9.409340012568248e18 , "9.409340012568248e18" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.9430376160308388e16 , "1.9430376160308388e16" ) + , ( (-6.9741824662760956e19), "-6.9741824662760956e19" ) + , ( 4.3816050601147837e18 , "4.3816050601147837e18" ) + ] + , testExpected "d2sScientific" (formatDouble scientific) + [ ( 0.0 , "0.0e0" ) + , ( 1.2345678 , "1.2345678e0" ) + , ( 4.294967294 , "4.294967294e0" ) + , ( 4.294967295 , "4.294967295e0" ) + ] + , testGroup "d2sStandard" + [ testCase "specific" do + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3 , "12.30" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.345 , "12.34" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 12.3451 , "12.35" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0050 , "0.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.999 , "1000.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 999.199 , "999.20" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.999 , "1.00" ) + singleMatches (formatDouble (standard 2)) (flip (showFFloat (Just 2)) []) ( 0.0051 , "0.01" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0056 , "0.006" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0096 , "0.010" ) + singleMatches (formatDouble (standard 5)) (flip (showFFloat (Just 5)) []) ( 12.345 , "12.34500" ) + singleMatches (formatDouble (standard 3)) (flip (showFFloat (Just 3)) []) ( 0.0 , "0.000" ) + , testProperty "standard N" \(NonNegative p, d :: Double) -> (LC.unpack . toLazyByteString) (formatDouble (standard p) d) === showFFloat (Just p) d "" + ] + , testMatches "d2sLooksLikePowerOf5" doubleDec show + [ ( (coerceWord64ToDouble 0x4830F0CF064DD592) , "5.764607523034235e39" ) + , ( (coerceWord64ToDouble 0x4840F0CF064DD592) , "1.152921504606847e40" ) + , ( (coerceWord64ToDouble 0x4850F0CF064DD592) , "2.305843009213694e40" ) + , ( (coerceWord64ToDouble 0x4400000000000004) , "3.689348814741914e19" ) + + -- here v- is a power of 5 but since we don't accept bounds there is no + -- interesting trailing behavior + , ( (coerceWord64ToDouble 0x440000000000301d) , "3.6893488147520004e19" ) + ] + , testMatches "d2sOutputLength" doubleDec show + [ ( 1 , "1.0" ) + , ( 1.2 , "1.2" ) + , ( 1.23 , "1.23" ) + , ( 1.234 , "1.234" ) + , ( 1.2345 , "1.2345" ) + , ( 1.23456 , "1.23456" ) + , ( 1.234567 , "1.234567" ) + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456789 , "1.23456789" ) + , ( 1.234567895 , "1.234567895" ) + , ( 1.2345678901 , "1.2345678901" ) + , ( 1.23456789012 , "1.23456789012" ) + , ( 1.234567890123 , "1.234567890123" ) + , ( 1.2345678901234 , "1.2345678901234" ) + , ( 1.23456789012345 , "1.23456789012345" ) + , ( 1.234567890123456 , "1.234567890123456" ) + , ( 1.2345678901234567 , "1.2345678901234567" ) + + -- Test 32-bit chunking + , ( 4.294967294 , "4.294967294" ) + , ( 4.294967295 , "4.294967295" ) + , ( 4.294967296 , "4.294967296" ) + , ( 4.294967297 , "4.294967297" ) + , ( 4.294967298 , "4.294967298" ) + ] + , testMatches "d2sMinMaxShift" doubleDec show + [ ( (ieeeParts2Double False 4 0) , "1.7800590868057611e-307" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 28 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 28 <= dist <= 50 + , ( (ieeeParts2Double False 6 maxMantissa) , "2.8480945388892175e-306" ) + -- 32-bit opt-size=0: 52 <= dist <= 53 + -- 32-bit opt-size=1: 2 <= dist <= 53 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 41 0) , "2.446494580089078e-296" ) + -- 32-bit opt-size=0: 52 <= dist <= 52 + -- 32-bit opt-size=1: 2 <= dist <= 52 + -- 64-bit opt-size=0: 53 <= dist <= 53 + -- 64-bit opt-size=1: 2 <= dist <= 53 + , ( (ieeeParts2Double False 40 maxMantissa) , "4.8929891601781557e-296" ) + -- 32-bit opt-size=0: 57 <= dist <= 58 + -- 32-bit opt-size=1: 57 <= dist <= 58 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1077 0) , "1.8014398509481984e16" ) + -- 32-bit opt-size=0: 57 <= dist <= 57 + -- 32-bit opt-size=1: 57 <= dist <= 57 + -- 64-bit opt-size=0: 58 <= dist <= 58 + -- 64-bit opt-size=1: 58 <= dist <= 58 + , ( (ieeeParts2Double False 1076 maxMantissa) , "3.6028797018963964e16" ) + -- 32-bit opt-size=0: 51 <= dist <= 52 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 307 0) , "2.900835519859558e-216" ) + -- 32-bit opt-size=0: 51 <= dist <= 51 + -- 32-bit opt-size=1: 51 <= dist <= 59 + -- 64-bit opt-size=0: 52 <= dist <= 52 + -- 64-bit opt-size=1: 52 <= dist <= 59 + , ( (ieeeParts2Double False 306 maxMantissa) , "5.801671039719115e-216" ) + -- 32-bit opt-size=0: 49 <= dist <= 49 + -- 32-bit opt-size=1: 44 <= dist <= 49 + -- 64-bit opt-size=0: 50 <= dist <= 50 + -- 64-bit opt-size=1: 44 <= dist <= 50 + , ( (ieeeParts2Double False 934 0x000FA7161A4D6e0C) , "3.196104012172126e-27" ) + ] + , testMatches "d2sSmallIntegers" doubleDec show + [ ( 9007199254740991.0 , "9.007199254740991e15" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + , ( 1.0e+0 , "1.0" ) + , ( 1.2e+1 , "12.0" ) + , ( 1.23e+2 , "123.0" ) + , ( 1.234e+3 , "1234.0" ) + , ( 1.2345e+4 , "12345.0" ) + , ( 1.23456e+5 , "123456.0" ) + , ( 1.234567e+6 , "1234567.0" ) + , ( 1.2345678e+7 , "1.2345678e7" ) + , ( 1.23456789e+8 , "1.23456789e8" ) + , ( 1.23456789e+9 , "1.23456789e9" ) + , ( 1.234567895e+9 , "1.234567895e9" ) + , ( 1.2345678901e+10 , "1.2345678901e10" ) + , ( 1.23456789012e+11 , "1.23456789012e11" ) + , ( 1.234567890123e+12 , "1.234567890123e12" ) + , ( 1.2345678901234e+13 , "1.2345678901234e13" ) + , ( 1.23456789012345e+14 , "1.23456789012345e14" ) + , ( 1.234567890123456e+15 , "1.234567890123456e15" ) + + -- 10^i + , ( 1.0e+0 , "1.0" ) + , ( 1.0e+1 , "10.0" ) + , ( 1.0e+2 , "100.0" ) + , ( 1.0e+3 , "1000.0" ) + , ( 1.0e+4 , "10000.0" ) + , ( 1.0e+5 , "100000.0" ) + , ( 1.0e+6 , "1000000.0" ) + , ( 1.0e+7 , "1.0e7" ) + , ( 1.0e+8 , "1.0e8" ) + , ( 1.0e+9 , "1.0e9" ) + , ( 1.0e+10 , "1.0e10" ) + , ( 1.0e+11 , "1.0e11" ) + , ( 1.0e+12 , "1.0e12" ) + , ( 1.0e+13 , "1.0e13" ) + , ( 1.0e+14 , "1.0e14" ) + , ( 1.0e+15 , "1.0e15" ) + + -- 10^15 + 10^i + , ( (1.0e+15 + 1.0e+0) , "1.000000000000001e15" ) + , ( (1.0e+15 + 1.0e+1) , "1.00000000000001e15" ) + , ( (1.0e+15 + 1.0e+2) , "1.0000000000001e15" ) + , ( (1.0e+15 + 1.0e+3) , "1.000000000001e15" ) + , ( (1.0e+15 + 1.0e+4) , "1.00000000001e15" ) + , ( (1.0e+15 + 1.0e+5) , "1.0000000001e15" ) + , ( (1.0e+15 + 1.0e+6) , "1.000000001e15" ) + , ( (1.0e+15 + 1.0e+7) , "1.00000001e15" ) + , ( (1.0e+15 + 1.0e+8) , "1.0000001e15" ) + , ( (1.0e+15 + 1.0e+9) , "1.000001e15" ) + , ( (1.0e+15 + 1.0e+10) , "1.00001e15" ) + , ( (1.0e+15 + 1.0e+11) , "1.0001e15" ) + , ( (1.0e+15 + 1.0e+12) , "1.001e15" ) + , ( (1.0e+15 + 1.0e+13) , "1.01e15" ) + , ( (1.0e+15 + 1.0e+14) , "1.1e15" ) + + -- Largest power of 2 <= 10^(i+1) + , ( 8.0 , "8.0" ) + , ( 64.0 , "64.0" ) + , ( 512.0 , "512.0" ) + , ( 8192.0 , "8192.0" ) + , ( 65536.0 , "65536.0" ) + , ( 524288.0 , "524288.0" ) + , ( 8388608.0 , "8388608.0" ) + , ( 67108864.0 , "6.7108864e7" ) + , ( 536870912.0 , "5.36870912e8" ) + , ( 8589934592.0 , "8.589934592e9" ) + , ( 68719476736.0 , "6.8719476736e10" ) + , ( 549755813888.0 , "5.49755813888e11" ) + , ( 8796093022208.0 , "8.796093022208e12" ) + , ( 70368744177664.0 , "7.0368744177664e13" ) + , ( 562949953421312.0 , "5.62949953421312e14" ) + , ( 9007199254740992.0 , "9.007199254740992e15" ) + + -- 1000 * (Largest power of 2 <= 10^(i+1)) + , ( 8.0e+3 , "8000.0" ) + , ( 64.0e+3 , "64000.0" ) + , ( 512.0e+3 , "512000.0" ) + , ( 8192.0e+3 , "8192000.0" ) + , ( 65536.0e+3 , "6.5536e7" ) + , ( 524288.0e+3 , "5.24288e8" ) + , ( 8388608.0e+3 , "8.388608e9" ) + , ( 67108864.0e+3 , "6.7108864e10" ) + , ( 536870912.0e+3 , "5.36870912e11" ) + , ( 8589934592.0e+3 , "8.589934592e12" ) + , ( 68719476736.0e+3 , "6.8719476736e13" ) + , ( 549755813888.0e+3 , "5.49755813888e14" ) + , ( 8796093022208.0e+3 , "8.796093022208e15" ) + ] + , testMatches "f2sPowersOf10" floatDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] + , testMatches "d2sPowersOf10" doubleDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] + ] + where + testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree + testExpected name dec = testCase name . traverse_ \(x, ref) -> LC.unpack (toLazyByteString (dec x)) @?= ref + + singleMatches :: (a -> Builder) -> (a -> String) -> (a, String) -> Assertion + singleMatches dec refdec (x, ref) = do + LC.unpack (toLazyByteString (dec x)) @?= refdec x + refdec x @?= ref + + testMatches :: TestName -> (a -> Builder) -> (a -> String) -> [(a, String)] -> TestTree + testMatches name dec refdec = testCase name . traverse_ (singleMatches dec refdec) + + maxMantissa = (1 `shiftL` 53) - 1 :: Word64 + + ieeeParts2Double :: Bool -> Int -> Word64 -> Double + ieeeParts2Double sign expo mantissa = + coerceWord64ToDouble $ (fromIntegral (fromEnum sign) `shiftL` 63) .|. (fromIntegral expo `shiftL` 52) .|. mantissa + + asShowRef x = (x, show x) + +testsChar8 :: [TestTree] +testsChar8 = + [ testBuilderConstr "charChar8" char8_list char8 + , testBuilderConstr "stringChar8" (foldMap char8_list) string8 + ] + +testsUtf8 :: [TestTree] +testsUtf8 = + [ testBuilderConstr "charUtf8" charUtf8_list charUtf8 + , testBuilderConstr "stringUtf8" (foldMap charUtf8_list) stringUtf8 + ] diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs.rej b/tests/builder/Data/ByteString/Builder/Tests.hs.rej new file mode 100644 index 000000000..5ee188b31 --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Tests.hs.rej @@ -0,0 +1,31 @@ +@@ -641,8 +641,9 @@ + where + enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) + +-testsFloating :: [TestTree] +-testsFloating = ++testsFloating :: TestTree ++testsFloating = testGroup "RealFloat" ++ [ testGroup "Float" + [ testMatches "f2sNonNumbersAndZero" floatDec show + [ ( 0.0 , "0.0" ) + , ( (-0.0) , "-0.0" ) +@@ -742,7 +743,9 @@ + , ( 1.2345678 , "1.2345678" ) + , ( 1.23456735e-36 , "1.23456735e-36" ) + ] +- , testMatches "d2sBasic" doubleDec show ++ ] ++ , testGroup "Double" ++ [ testMatches "d2sBasic" doubleDec show + [ ( 1.0 , "1.0" ) + , ( (-1.0) , "-1.0" ) + ] +@@ -962,6 +965,7 @@ + , testMatches "d2sPowersOf10" doubleDec show $ + fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] + ] ++ ] + where + testExpected :: TestName -> (a -> Builder) -> [(a, String)] -> TestTree + testExpected name dec = testCase name . traverse_ \(x, ref) -> LC.unpack (toLazyByteString (dec x)) @?= ref From e181e2a0d0db76263803a867027b57930ce35984 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Thu, 11 Jan 2024 17:12:28 -0500 Subject: [PATCH 23/34] toCharsNonNumberAndZero now takes the float and only uses bit operations to determine special string --- Data/ByteString/Builder/RealFloat/D2S.hs | 15 ++++---- Data/ByteString/Builder/RealFloat/F2S.hs | 16 ++++----- Data/ByteString/Builder/RealFloat/Internal.hs | 36 ++++++++++++------- 3 files changed, 38 insertions(+), 29 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index ffe8793c3..d13ee0e83 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -191,19 +191,18 @@ d2d m e = -- | Dispatches to `d2d` or `d2dSmallInt` and applies the given formatters {-# INLINE d2s' #-} -d2s' :: (Bool -> Word64 -> Int32 -> a) -> (Bool -> MantissaWord Double -> ExponentWord Double -> Maybe a) -> Double -> a -d2s' formatter specialFormatter d = - let (sign, mantissa, expo) = breakdown d - in flip fromMaybe (specialFormatter sign mantissa expo) $ - let FloatingDecimal m e = d2d mantissa expo - in formatter sign m e +d2s' :: (Bool -> Word64 -> Int32 -> a) -> (Double -> Maybe a) -> Double -> a +d2s' formatter specialFormatter d = flip fromMaybe (specialFormatter d) $ + let FloatingDecimal m e = d2d mantissa expo + (sign, mantissa, expo) = breakdown d + in formatter sign m e -- | Render a Double in scientific notation d2s :: Word8# -> SpecialStrings -> Double -> Builder -d2s eE ss d = primBounded (d2s' (toCharsScientific eE) (toCharsNonNumbersAndZero @Double Proxy ss) d) () +d2s eE ss d = primBounded (d2s' (toCharsScientific eE) (toCharsNonNumbersAndZero ss) d) () -- | Returns the decimal representation of a Double. NaN and Infinity will -- return `FloatingDecimal 0 0` {-# INLINE d2Intermediate #-} d2Intermediate :: Double -> FD -d2Intermediate = d2s' (const FloatingDecimal) (\_ _ _ -> Nothing) +d2Intermediate = d2s' (const FloatingDecimal) (const Nothing) diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index da68aa727..7e80d6309 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -20,7 +20,6 @@ import Data.ByteString.Builder.Internal (Builder) import Data.ByteString.Builder.Prim (primBounded) import Data.ByteString.Builder.RealFloat.Internal import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy(Proxy)) import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word32(..), Word64(..)) @@ -172,19 +171,18 @@ f2d m e = -- | Dispatches to `f2d` and applies the given formatters {-# INLINE f2s' #-} -f2s' :: (Bool -> Word32 -> Int32 -> a) -> (Bool -> MantissaWord Float -> ExponentWord Float -> Maybe a) -> Float -> a -f2s' formatter specialFormatter f = - let (sign, mantissa, expo) = breakdown f - in flip fromMaybe (specialFormatter sign mantissa expo) $ - let FloatingDecimal m e = f2d mantissa expo - in formatter sign m e +f2s' :: (Bool -> Word32 -> Int32 -> a) -> (Float -> Maybe a) -> Float -> a +f2s' formatter specialFormatter f = flip fromMaybe (specialFormatter f) $ + let FloatingDecimal m e = f2d mantissa expo + (sign, mantissa, expo) = breakdown f + in formatter sign m e -- | Render a Float in scientific notation f2s :: Word8# -> SpecialStrings -> Float -> Builder -f2s eE ss f = primBounded (f2s' (toCharsScientific eE) (toCharsNonNumbersAndZero @Float Proxy ss) f) () +f2s eE ss f = primBounded (f2s' (toCharsScientific eE) (toCharsNonNumbersAndZero ss) f) () -- | Returns the decimal representation of a Float. NaN and Infinity will -- return `FloatingDecimal 0 0` {-# INLINE f2Intermediate #-} f2Intermediate :: Float -> FD -f2Intermediate = f2s' (const FloatingDecimal) (\_ _ _ -> Nothing) +f2Intermediate = f2s' (const FloatingDecimal) (const Nothing) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 7ce4dd306..90c3198cd 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -9,6 +9,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} -- | -- Module : Data.ByteString.Builder.RealFloat.Internal -- Copyright : (c) Lawrence Wu 2021 @@ -88,7 +89,6 @@ import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) import Data.ByteString.Builder.RealFloat.TableGenerator import Data.ByteString.Utils.UnalignedWrite import Data.Char (ord) -import Data.Proxy (Proxy) import Foreign.C.Types import GHC.Int (Int(..), Int32(..)) import GHC.IO (IO(..), unIO) @@ -260,25 +260,37 @@ boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) -- * biased exponent = all 0 bits. -- * fraction = all 0 bits. {-# INLINABLE toCharsNonNumbersAndZero #-} -{-# SPECIALIZE toCharsNonNumbersAndZero :: Proxy Float -> SpecialStrings -> Bool -> MantissaWord Float -> ExponentWord Float -> Maybe (BoundedPrim ()) #-} -{-# SPECIALIZE toCharsNonNumbersAndZero :: Proxy Double -> SpecialStrings -> Bool -> MantissaWord Double -> ExponentWord Double -> Maybe (BoundedPrim ()) #-} +{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Float -> Maybe (BoundedPrim ()) #-} +{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Double -> Maybe (BoundedPrim ()) #-} toCharsNonNumbersAndZero :: forall a mw ew. - ( ExponentBits a + ( CastToWord a + , MantissaBits a + , mw ~ MantissaWord a , Ord mw , Num mw + , Bits mw + , Integral mw + , ExponentBits a + , ew ~ ExponentWord a , Ord ew , Num ew , Bits ew , Integral ew - ) => Proxy a -> SpecialStrings -> Bool -> mw -> ew -> Maybe (BoundedPrim ()) -toCharsNonNumbersAndZero _ SpecialStrings{..} sign mantissa expo = - if (expo == mask (exponentBits @a)) || (expo == 0 && mantissa == 0) - then Just $ boundString $ if - | mantissa > 0 -> nan - | expo > 0 -> if sign then negativeInfinity else positiveInfinity - | sign -> negativeZero - | otherwise -> positiveZero + ) => SpecialStrings -> a -> Maybe (BoundedPrim ()) +toCharsNonNumbersAndZero SpecialStrings{..} f = boundString <$> + if w .&. expoMantissaBits == 0 + then Just if w == signBit then negativeZero else positiveZero + else if w .&. expoMask == expoMask + then Just if w .&. mantissaMask == 0 + then if w .&. signBit /= 0 then negativeInfinity else positiveInfinity + else nan else Nothing + where + w = castToWord f + expoMask = mask (exponentBits @a) `shiftL` mantissaBits @a + mantissaMask = mask (mantissaBits @a) + expoMantissaBits = complement signBit + signBit = 1 `rotateR` 1 data SpecialStrings = SpecialStrings { nan :: String From cbeeef8f9ada867de424c747bac3259f88e1ed72 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Fri, 12 Jan 2024 10:43:27 -0500 Subject: [PATCH 24/34] removed f2s d2s --- Data/ByteString/Builder/RealFloat.hs | 58 ++++++++++--------- Data/ByteString/Builder/RealFloat/D2S.hs | 9 +-- Data/ByteString/Builder/RealFloat/F2S.hs | 9 +-- Data/ByteString/Builder/RealFloat/Internal.hs | 53 +++++++++++++---- 4 files changed, 79 insertions(+), 50 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 285c506e5..d58e2f61c 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -2,6 +2,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -85,6 +89,8 @@ import GHC.Int (Int32) import GHC.Show (intToDigit) import Data.Char (ord) import GHC.Prim (Word8#) +import Data.Bits (Bits) +import Data.Proxy (Proxy(Proxy)) -- | Returns a rendered Float. Matches `show` in displaying in standard or -- scientific notation @@ -213,47 +219,55 @@ formatDouble = formatFloating {-# INLINABLE formatFloating #-} {-# SPECIALIZE formatFloating :: FloatFormat -> Float -> Builder #-} {-# SPECIALIZE formatFloating :: FloatFormat -> Double -> Builder #-} -formatFloating :: +formatFloating :: forall a mw ew ei. -- a - ( ToS a + ( ToS' a , Num a , Ord a , RealFloat a , Intermediate a + , R.CastToWord a + , R.MantissaBits a + , R.ExponentBits a + , Bits (R.ExponentWord a) -- mantissa , mw ~ R.MantissaWord a , R.Mantissa mw , ToWord64 mw , R.DecimalLength mw + -- exponent + , ew ~ R.ExponentWord a + , Integral (R.ExponentWord a) + , ei ~ R.ExponentInt a + , R.ToInt ei + , Integral ei + , R.FromInt ei ) => FloatFormat -> a -> Builder -formatFloating = \case - FGeneric eE prec (minExpo,maxExpo) ss -> \f -> let (R.FloatingDecimal m e) = intermediate f; e' = toInt e + R.decimalLength m in - case specialStr ss f of - Just b -> b +formatFloating fmt f = case fmt of + FGeneric eE prec (minExpo,maxExpo) ss -> let (R.FloatingDecimal m e) = intermediate f; e' = R.toInt e + R.decimalLength m in + case R.toCharsNonNumbersAndZero ss f of + Just b -> BP.primBounded b () Nothing -> if e' >= minExpo && e' <= maxExpo then sign f `mappend` showStandard (toWord64 m) e' prec - else BP.primBounded (R.toCharsScientific eE (f < 0) m e) () - FScientific eE ss -> toS eE ss - FStandard prec ss -> \f -> let (R.FloatingDecimal m e) = intermediate f; e' = toInt e + R.decimalLength m in - case specialStr ss f of - Just b -> b + else BP.primBounded (R.toCharsScientific @a Proxy eE (f < 0) m e) () + FScientific eE ss -> BP.primBounded (toS' (R.toCharsScientific @a Proxy eE) (R.toCharsNonNumbersAndZero ss) f) () + FStandard prec ss -> let (R.FloatingDecimal m e) = intermediate f; e' = R.toInt e + R.decimalLength m in + case R.toCharsNonNumbersAndZero ss f of + Just b -> BP.primBounded b () Nothing -> sign f `mappend` showStandard (toWord64 m) e' prec class Intermediate a where intermediate :: a -> R.FloatingDecimal a instance Intermediate Float where intermediate = RF.f2Intermediate instance Intermediate Double where intermediate = RD.d2Intermediate -class ToInt a where toInt :: a -> Int -instance ToInt Int32 where toInt = R.int32ToInt - class ToWord64 a where toWord64 :: a -> Word64 instance ToWord64 Word32 where toWord64 = R.word32ToWord64 instance ToWord64 Word64 where toWord64 = id -class ToS a where toS :: Word8# -> R.SpecialStrings -> a -> Builder -instance ToS Float where toS = RF.f2s -instance ToS Double where toS = RD.d2s +class ToS' a where toS' :: (Bool -> R.MantissaWord a -> R.ExponentInt a -> b) -> (a -> Maybe b) -> a -> b +instance ToS' Float where toS' = RF.f2s' +instance ToS' Double where toS' = RD.d2s' -- | Char7 encode a 'Char'. {-# INLINE char7 #-} @@ -269,16 +283,6 @@ string7 = BP.primMapListFixed BP.char7 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 => R.SpecialStrings -> a -> Maybe Builder -specialStr R.SpecialStrings{..} f - | isNaN f = Just $ string7 nan - | isInfinite f = Just $ if f < 0 then string7 negativeInfinity else string7 positiveInfinity - | isNegativeZero f = Just $ string7 negativeZero - | f == 0 = Just $ string7 positiveZero - | otherwise = Nothing - -- | Returns a list of decimal digits in a Word64 digits :: Word64 -> [Int] digits w = go [] w diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index d13ee0e83..91f15e30a 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -11,8 +11,8 @@ -- Implementation of double-to-string conversion module Data.ByteString.Builder.RealFloat.D2S - ( d2s - , d2Intermediate + ( d2Intermediate + , d2s' ) where import Control.Arrow (first) @@ -26,6 +26,7 @@ import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word64(..)) import GHC.Prim (Word8#) +import Data.Proxy (Proxy(Proxy)) -- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level -- explanation of the ryu algorithm @@ -197,10 +198,6 @@ d2s' formatter specialFormatter d = flip fromMaybe (specialFormatter d) $ (sign, mantissa, expo) = breakdown d in formatter sign m e --- | Render a Double in scientific notation -d2s :: Word8# -> SpecialStrings -> Double -> Builder -d2s eE ss d = primBounded (d2s' (toCharsScientific eE) (toCharsNonNumbersAndZero ss) d) () - -- | Returns the decimal representation of a Double. NaN and Infinity will -- return `FloatingDecimal 0 0` {-# INLINE d2Intermediate #-} diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 7e80d6309..80200bf1f 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -10,8 +10,8 @@ -- Implementation of float-to-string conversion module Data.ByteString.Builder.RealFloat.F2S - ( f2s - , f2Intermediate + ( f2Intermediate + , f2s' ) where import Control.Arrow (first) @@ -24,6 +24,7 @@ import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word32(..), Word64(..)) import GHC.Prim (Word8#) +import Data.Proxy (Proxy(Proxy)) -- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level -- explanation of the ryu algorithm @@ -177,10 +178,6 @@ f2s' formatter specialFormatter f = flip fromMaybe (specialFormatter f) $ (sign, mantissa, expo) = breakdown f in formatter sign m e --- | Render a Float in scientific notation -f2s :: Word8# -> SpecialStrings -> Float -> Builder -f2s eE ss f = primBounded (f2s' (toCharsScientific eE) (toCharsNonNumbersAndZero ss) f) () - -- | Returns the decimal representation of a Float. NaN and Infinity will -- return `FloatingDecimal 0 0` {-# INLINE f2Intermediate #-} diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 90c3198cd..1ee48f502 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -75,9 +75,13 @@ module Data.ByteString.Builder.RealFloat.Internal , FloatingDecimal(..) , MantissaWord , ExponentWord + , ExponentInt , breakdown , MantissaBits(..) , ExponentBits(..) + , CastToWord(..) + , ToInt(..) + , FromInt(..) , module Data.ByteString.Builder.RealFloat.TableGenerator ) where @@ -89,6 +93,7 @@ import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) import Data.ByteString.Builder.RealFloat.TableGenerator import Data.ByteString.Utils.UnalignedWrite import Data.Char (ord) +import Data.Proxy (Proxy) import Foreign.C.Types import GHC.Int (Int(..), Int32(..)) import GHC.IO (IO(..), unIO) @@ -862,7 +867,13 @@ writeMantissa ptr olength = go (ptr `plusAddr#` olength) in (# ptr `plusAddr#` 3#, s4 #) -- | Write the exponent into the given address. -writeExponent :: Addr# -> Int32 -> State# RealWorld -> (# Addr#, State# RealWorld #) +writeExponent :: forall a ei. + ( ei ~ ExponentInt a + , Ord ei + , Num ei + , Integral ei + , ToInt ei + ) => Addr# -> ei -> State# RealWorld -> (# Addr#, State# RealWorld #) writeExponent ptr !expo s1 | expo >= 100 = let !(e1, e0) = fquotRem10 (fromIntegral expo) -- TODO @@ -875,7 +886,7 @@ writeExponent ptr !expo s1 | otherwise = let s2 = poke ptr (wordToWord8# (toAscii (int2Word# e))) s1 in (# ptr `plusAddr#` 1#, s2 #) - where !(I# e) = int32ToInt expo + where !(I# e) = toInt expo -- | Write the sign into the given address. writeSign :: Addr# -> Bool -> State# d -> (# Addr#, State# d #) @@ -887,31 +898,47 @@ writeSign ptr False s = (# ptr, s #) -- | Returns the decimal representation of a floating point number in -- scientific (exponential) notation {-# INLINABLE toCharsScientific #-} -{-# SPECIALIZE toCharsScientific :: Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} -{-# SPECIALIZE toCharsScientific :: Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} -toCharsScientific :: (Mantissa a, DecimalLength a) => Word8# -> Bool -> a -> Int32 -> BoundedPrim () -toCharsScientific eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do +{-# SPECIALIZE toCharsScientific :: Proxy Float -> Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} +{-# SPECIALIZE toCharsScientific :: Proxy Double -> Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} +toCharsScientific :: forall a mw ei. + ( Mantissa mw + , DecimalLength mw + , mw ~ MantissaWord a + , ei ~ ExponentInt a + , Ord ei + , Num ei + , Integral ei + , ToInt ei + , FromInt ei + ) => Proxy a -> Word8# -> Bool -> mw -> ei -> BoundedPrim () +toCharsScientific _ eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do let !olength@(I# ol) = decimalLength mantissa - !expo' = expo + intToInt32 olength - 1 + !expo' = expo + fromInt olength - 1 IO $ \s1 -> let !(# p1, s2 #) = writeSign p0 sign s1 !(# p2, s3 #) = writeMantissa p1 ol mantissa s2 s4 = poke p2 eE s3 !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 - !(# p4, s6 #) = writeExponent p3 (abs expo') s5 + !(# p4, s6 #) = writeExponent @a p3 (abs expo') s5 in (# s6, (Ptr p4) #) data FloatingDecimal a = FloatingDecimal { fmantissa :: !(MantissaWord a) - , fexponent :: !Int32 + , fexponent :: !(ExponentInt a) } -deriving instance Show (MantissaWord a) => Show (FloatingDecimal a) -deriving instance Eq (MantissaWord a) => Eq (FloatingDecimal a) +deriving instance (Show (MantissaWord a), Show (ExponentInt a)) => Show (FloatingDecimal a) +deriving instance (Eq (MantissaWord a), Eq (ExponentInt a)) => Eq (FloatingDecimal a) type family MantissaWord a type instance MantissaWord Float = Word32 type instance MantissaWord Double = Word64 +class ToInt a where toInt :: a -> Int +instance ToInt Int32 where toInt = int32ToInt + +class FromInt a where fromInt :: Int -> a +instance FromInt Int32 where fromInt = intToInt32 + -- | Split a Double into (sign, mantissa, exponent) {-# INLINABLE breakdown #-} {-# SPECIALIZE breakdown :: Float -> (Bool, MantissaWord Float, ExponentWord Float) #-} @@ -937,6 +964,10 @@ type family ExponentWord a type instance ExponentWord Float = Word32 type instance ExponentWord Double = Word64 +type family ExponentInt a +type instance ExponentInt Float = Int32 +type instance ExponentInt Double = Int32 + class CastToWord a where castToWord :: a -> MantissaWord a instance CastToWord Float where castToWord = castFloatToWord32 instance CastToWord Double where castToWord = castDoubleToWord64 From bf287a5ca6e9097adcc568baaaf53393a202df12 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Fri, 12 Jan 2024 14:16:55 -0500 Subject: [PATCH 25/34] removed f2s f2s' f2Intermediate --- Data/ByteString/Builder/RealFloat.hs | 55 ++++++++++--------- Data/ByteString/Builder/RealFloat/D2S.hs | 29 +++------- Data/ByteString/Builder/RealFloat/F2S.hs | 22 +------- Data/ByteString/Builder/RealFloat/Internal.hs | 18 ++---- 4 files changed, 42 insertions(+), 82 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index d58e2f61c..4a820b972 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -85,12 +85,12 @@ import qualified Data.ByteString.Builder.RealFloat.D2S as RD import qualified Data.ByteString.Builder.Prim as BP import GHC.Float (roundTo) import GHC.Word (Word32, Word64) -import GHC.Int (Int32) import GHC.Show (intToDigit) import Data.Char (ord) import GHC.Prim (Word8#) import Data.Bits (Bits) import Data.Proxy (Proxy(Proxy)) +import Data.Maybe (fromMaybe) -- | Returns a rendered Float. Matches `show` in displaying in standard or -- scientific notation @@ -120,7 +120,11 @@ data FloatFormat | FStandard (Maybe Int) R.SpecialStrings -- ^ standard notation with `Maybe Int` digits after the decimal | FGeneric Word8# (Maybe Int) (Int,Int) R.SpecialStrings -- ^ dispatches to scientific or standard notation based on the exponent deriving Show + +fScientific :: Char -> R.SpecialStrings -> FloatFormat fScientific eE = FScientific (R.asciiRaw $ ord eE) + +fGeneric :: Char -> Maybe Int -> (Int, Int) -> R.SpecialStrings -> FloatFormat fGeneric eE = FGeneric (R.asciiRaw $ ord eE) -- | Standard notation with `n` decimal places @@ -221,11 +225,8 @@ formatDouble = formatFloating {-# SPECIALIZE formatFloating :: FloatFormat -> Double -> Builder #-} formatFloating :: forall a mw ew ei. -- a - ( ToS' a - , Num a - , Ord a + ( ToD a , RealFloat a - , Intermediate a , R.CastToWord a , R.MantissaBits a , R.ExponentBits a @@ -244,30 +245,32 @@ formatFloating :: forall a mw ew ei. , R.FromInt ei ) => FloatFormat -> a -> Builder formatFloating fmt f = case fmt of - FGeneric eE prec (minExpo,maxExpo) ss -> let (R.FloatingDecimal m e) = intermediate f; e' = R.toInt e + R.decimalLength m in - case R.toCharsNonNumbersAndZero ss f of - Just b -> BP.primBounded b () - Nothing -> - if e' >= minExpo && e' <= maxExpo - then sign f `mappend` showStandard (toWord64 m) e' prec - else BP.primBounded (R.toCharsScientific @a Proxy eE (f < 0) m e) () - FScientific eE ss -> BP.primBounded (toS' (R.toCharsScientific @a Proxy eE) (R.toCharsNonNumbersAndZero ss) f) () - FStandard prec ss -> let (R.FloatingDecimal m e) = intermediate f; e' = R.toInt e + R.decimalLength m in - case R.toCharsNonNumbersAndZero ss f of - Just b -> BP.primBounded b () - Nothing -> sign f `mappend` showStandard (toWord64 m) e' prec - -class Intermediate a where intermediate :: a -> R.FloatingDecimal a -instance Intermediate Float where intermediate = RF.f2Intermediate -instance Intermediate Double where intermediate = RD.d2Intermediate + FGeneric eE prec (minExpo,maxExpo) ss -> + case R.toCharsNonNumbersAndZero ss f of + Just b -> BP.primBounded b () + Nothing -> + if e' >= minExpo && e' <= maxExpo + then printSign f `mappend` showStandard (toWord64 m) e' prec + else BP.primBounded (sci eE) () + FScientific eE ss -> flip BP.primBounded () + $ fromMaybe (sci eE) (R.toCharsNonNumbersAndZero ss f) + FStandard prec ss -> + case R.toCharsNonNumbersAndZero ss f of + Just b -> BP.primBounded b () + Nothing -> printSign f `mappend` showStandard (toWord64 m) e' prec + where + sci eE = R.toCharsScientific @a Proxy eE sign m e + e' = R.toInt e + R.decimalLength m + R.FloatingDecimal m e = toD @a mantissa expo + (sign, mantissa, expo) = R.breakdown f class ToWord64 a where toWord64 :: a -> Word64 instance ToWord64 Word32 where toWord64 = R.word32ToWord64 instance ToWord64 Word64 where toWord64 = id -class ToS' a where toS' :: (Bool -> R.MantissaWord a -> R.ExponentInt a -> b) -> (a -> Maybe b) -> a -> b -instance ToS' Float where toS' = RF.f2s' -instance ToS' Double where toS' = RD.d2s' +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 #-} @@ -280,8 +283,8 @@ 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 +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] diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index 91f15e30a..a1e342c50 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -11,22 +11,16 @@ -- Implementation of double-to-string conversion module Data.ByteString.Builder.RealFloat.D2S - ( d2Intermediate - , d2s' + ( 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 Data.Proxy (Proxy(Proxy)) import GHC.Int (Int32(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word64(..)) -import GHC.Prim (Word8#) -import Data.Proxy (Proxy(Proxy)) -- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level -- explanation of the ryu algorithm @@ -43,6 +37,7 @@ foreign import ccall "&hs_bytestring_double_pow5_inv_split" foreign import ccall "&hs_bytestring_double_pow5_split" double_pow5_split :: Ptr Word64 +double_mantissa_bits :: Int double_mantissa_bits = mantissaBits @Double -- | Bias in encoded 64-bit float representation (2^10 - 1) @@ -162,8 +157,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 -> FD -d2d m e = +d2dGeneral :: Word64 -> Word64 -> FD +d2dGeneral m e = let !mf = if e == 0 then m else (1 `unsafeShiftL` double_mantissa_bits) .|. m @@ -190,16 +185,6 @@ d2d m e = !e' = e10 + removed in FloatingDecimal output e' --- | Dispatches to `d2d` or `d2dSmallInt` and applies the given formatters -{-# INLINE d2s' #-} -d2s' :: (Bool -> Word64 -> Int32 -> a) -> (Double -> Maybe a) -> Double -> a -d2s' formatter specialFormatter d = flip fromMaybe (specialFormatter d) $ - let FloatingDecimal m e = d2d mantissa expo - (sign, mantissa, expo) = breakdown d - in formatter sign m e - --- | Returns the decimal representation of a Double. NaN and Infinity will --- return `FloatingDecimal 0 0` -{-# INLINE d2Intermediate #-} -d2Intermediate :: Double -> FD -d2Intermediate = d2s' (const FloatingDecimal) (const Nothing) +-- 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 diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 80200bf1f..006e43724 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -10,21 +10,15 @@ -- Implementation of float-to-string conversion module Data.ByteString.Builder.RealFloat.F2S - ( f2Intermediate - , f2s' + ( f2d ) 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(..)) import GHC.Ptr (Ptr(..)) import GHC.Word (Word32(..), Word64(..)) -import GHC.Prim (Word8#) -import Data.Proxy (Proxy(Proxy)) -- See Data.ByteString.Builder.RealFloat.TableGenerator for a high-level -- explanation of the ryu algorithm @@ -169,17 +163,3 @@ f2d m e = else trimNoTrailing state !e' = e10 + removed in FloatingDecimal output e' - --- | Dispatches to `f2d` and applies the given formatters -{-# INLINE f2s' #-} -f2s' :: (Bool -> Word32 -> Int32 -> a) -> (Float -> Maybe a) -> Float -> a -f2s' formatter specialFormatter f = flip fromMaybe (specialFormatter f) $ - let FloatingDecimal m e = f2d mantissa expo - (sign, mantissa, expo) = breakdown f - in formatter sign m e - --- | Returns the decimal representation of a Float. NaN and Infinity will --- return `FloatingDecimal 0 0` -{-# INLINE f2Intermediate #-} -f2Intermediate :: Float -> FD -f2Intermediate = f2s' (const FloatingDecimal) (const Nothing) diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 1ee48f502..1e2e56bfe 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -267,7 +267,7 @@ boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) {-# INLINABLE toCharsNonNumbersAndZero #-} {-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Float -> Maybe (BoundedPrim ()) #-} {-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Double -> Maybe (BoundedPrim ()) #-} -toCharsNonNumbersAndZero :: forall a mw ew. +toCharsNonNumbersAndZero :: forall a mw. ( CastToWord a , MantissaBits a , mw ~ MantissaWord a @@ -276,11 +276,6 @@ toCharsNonNumbersAndZero :: forall a mw ew. , Bits mw , Integral mw , ExponentBits a - , ew ~ ExponentWord a - , Ord ew - , Num ew - , Bits ew - , Integral ew ) => SpecialStrings -> a -> Maybe (BoundedPrim ()) toCharsNonNumbersAndZero SpecialStrings{..} f = boundString <$> if w .&. expoMantissaBits == 0 @@ -318,7 +313,7 @@ data SpecialStrings = SpecialStrings -- @ -- acceptBounds v = ((v \`quot\` 4) .&. 1) == 0 -- @ -acceptBounds :: Mantissa a => a -> Bool +acceptBounds :: a -> Bool acceptBounds _ = False ------------------------------------------------------------------------------- @@ -867,9 +862,8 @@ writeMantissa ptr olength = go (ptr `plusAddr#` olength) in (# ptr `plusAddr#` 3#, s4 #) -- | Write the exponent into the given address. -writeExponent :: forall a ei. - ( ei ~ ExponentInt a - , Ord ei +writeExponent :: forall ei. + ( Ord ei , Num ei , Integral ei , ToInt ei @@ -903,7 +897,6 @@ writeSign ptr False s = (# ptr, s #) toCharsScientific :: forall a mw ei. ( Mantissa mw , DecimalLength mw - , mw ~ MantissaWord a , ei ~ ExponentInt a , Ord ei , Num ei @@ -919,7 +912,7 @@ toCharsScientific _ eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(# p2, s3 #) = writeMantissa p1 ol mantissa s2 s4 = poke p2 eE s3 !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 - !(# p4, s6 #) = writeExponent @a p3 (abs expo') s5 + !(# p4, s6 #) = writeExponent p3 (abs expo') s5 in (# s6, (Ptr p4) #) data FloatingDecimal a = FloatingDecimal @@ -949,7 +942,6 @@ breakdown :: forall a mw ew. , CastToWord a , mw ~ MantissaWord a , Bits mw - , Eq mw , Integral mw , Num ew ) => a -> (Bool, mw, ew) From f399638f2b09e4612d3287d9ba8273c9d3aef9f5 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Thu, 11 Jan 2024 14:50:26 -0500 Subject: [PATCH 26/34] removed specialStr and replaced with improved version of toCharsNonNumbersAndZero --- Data/ByteString/Builder/RealFloat.hs | 33 +++++++++---------- Data/ByteString/Builder/RealFloat/Internal.hs | 32 +++++++++++++----- 2 files changed, 38 insertions(+), 27 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 4a820b972..948fbc2cf 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -225,12 +225,14 @@ formatDouble = formatFloating {-# SPECIALIZE formatFloating :: FloatFormat -> Double -> Builder #-} formatFloating :: forall a mw ew ei. -- a + --( ToS a ( ToD a + , Num a + , Ord a , RealFloat a - , R.CastToWord a - , R.MantissaBits a , R.ExponentBits a - , Bits (R.ExponentWord a) + , R.MantissaBits a + , R.CastToWord a -- mantissa , mw ~ R.MantissaWord a , R.Mantissa mw @@ -238,28 +240,23 @@ formatFloating :: forall a mw ew ei. , R.DecimalLength mw -- exponent , ew ~ R.ExponentWord a - , Integral (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 eE prec (minExpo,maxExpo) ss -> - case R.toCharsNonNumbersAndZero ss f of - Just b -> BP.primBounded b () - Nothing -> - if e' >= minExpo && e' <= maxExpo - then printSign f `mappend` showStandard (toWord64 m) e' prec - else BP.primBounded (sci eE) () - FScientific eE ss -> flip BP.primBounded () - $ fromMaybe (sci eE) (R.toCharsNonNumbersAndZero ss f) - FStandard prec ss -> - case R.toCharsNonNumbersAndZero ss f of - Just b -> BP.primBounded b () - Nothing -> printSign f `mappend` showStandard (toWord64 m) e' prec + FGeneric eE prec (minExpo,maxExpo) ss -> flip fromMaybe (R.toCharsNonNumbersAndZero ss f) $ + if e' >= minExpo && e' <= maxExpo + then printSign f `mappend` showStandard (toWord64 m) e' prec + else sci eE + FScientific eE ss -> fromMaybe (sci eE) (R.toCharsNonNumbersAndZero ss f) + FStandard prec ss -> flip fromMaybe (R.toCharsNonNumbersAndZero ss f) $ + printSign f `mappend` showStandard (toWord64 m) e' prec where - sci eE = R.toCharsScientific @a Proxy eE sign m e + sci eE = BP.primBounded (R.toCharsScientific @a Proxy eE sign m e) () e' = R.toInt e + R.decimalLength m R.FloatingDecimal m e = toD @a mantissa expo (sign, mantissa, expo) = R.breakdown f diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 1e2e56bfe..acffac3e4 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -6,7 +6,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} @@ -89,9 +88,11 @@ module Data.ByteString.Builder.RealFloat.Internal import Control.Monad (foldM) import Data.Bits (Bits(..), FiniteBits(..)) import Data.ByteString.Internal (c2w) +import Data.ByteString.Builder.Internal (Builder) import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) import Data.ByteString.Builder.RealFloat.TableGenerator import Data.ByteString.Utils.UnalignedWrite +import qualified Data.ByteString.Builder.Prim as BP import Data.Char (ord) import Data.Proxy (Proxy) import Foreign.C.Types @@ -265,19 +266,31 @@ boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) -- * biased exponent = all 0 bits. -- * fraction = all 0 bits. {-# INLINABLE toCharsNonNumbersAndZero #-} -{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Float -> Maybe (BoundedPrim ()) #-} -{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Double -> Maybe (BoundedPrim ()) #-} -toCharsNonNumbersAndZero :: forall a mw. - ( CastToWord a - , MantissaBits a +{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Float -> Maybe Builder #-} +{-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Double -> Maybe Builder #-} +toCharsNonNumbersAndZero :: forall a mw ew. + ( ExponentBits a , mw ~ MantissaWord a , Ord mw , Num mw + , ew ~ ExponentWord a + , Ord ew + , Num ew + , Bits ew + , Integral ew + + , ExponentBits a + , MantissaBits a + , CastToWord a + , mw ~ MantissaWord a , Bits mw + , Eq mw , Integral mw - , ExponentBits a - ) => SpecialStrings -> a -> Maybe (BoundedPrim ()) -toCharsNonNumbersAndZero SpecialStrings{..} f = boundString <$> + , ew ~ ExponentWord a + , Num ew + + ) => SpecialStrings -> a -> Maybe Builder +toCharsNonNumbersAndZero SpecialStrings{..} f = flip BP.primBounded () . boundString <$> if w .&. expoMantissaBits == 0 then Just if w == signBit then negativeZero else positiveZero else if w .&. expoMask == expoMask @@ -943,6 +956,7 @@ breakdown :: forall a mw ew. , mw ~ MantissaWord a , Bits mw , Integral mw + , ew ~ ExponentWord a , Num ew ) => a -> (Bool, mw, ew) breakdown f = (sign, mantissa, expo) From d9ebd68f3c83f0812ba6b5a204f34c0cd0fe49b4 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Fri, 12 Jan 2024 15:50:08 -0500 Subject: [PATCH 27/34] clean up --- Data/ByteString/Builder/RealFloat.hs | 2 -- Data/ByteString/Builder/RealFloat/Internal.hs | 34 ++++++------------- 2 files changed, 11 insertions(+), 25 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 948fbc2cf..29af9afdf 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -227,8 +227,6 @@ formatFloating :: forall a mw ew ei. -- a --( ToS a ( ToD a - , Num a - , Ord a , RealFloat a , R.ExponentBits a , R.MantissaBits a diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index acffac3e4..dd01640dd 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -269,26 +269,20 @@ boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) {-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Float -> Maybe Builder #-} {-# SPECIALIZE toCharsNonNumbersAndZero :: SpecialStrings -> Double -> Maybe Builder #-} toCharsNonNumbersAndZero :: forall a mw ew. - ( ExponentBits a - , mw ~ MantissaWord a - , Ord mw - , Num mw - , ew ~ ExponentWord a - , Ord ew - , Num ew - , Bits ew - , Integral ew - - , ExponentBits a - , MantissaBits a - , CastToWord a - , mw ~ MantissaWord a + ( Bits ew , Bits mw + , CastToWord a , Eq mw + , ExponentBits a + , Integral ew , Integral mw - , ew ~ ExponentWord a + , MantissaBits a , Num ew - + , Num mw + , Ord ew + , Ord mw + , ew ~ ExponentWord a + , mw ~ MantissaWord a ) => SpecialStrings -> a -> Maybe Builder toCharsNonNumbersAndZero SpecialStrings{..} f = flip BP.primBounded () . boundString <$> if w .&. expoMantissaBits == 0 @@ -876,9 +870,7 @@ writeMantissa ptr olength = go (ptr `plusAddr#` olength) -- | Write the exponent into the given address. writeExponent :: forall ei. - ( Ord ei - , Num ei - , Integral ei + ( Integral ei , ToInt ei ) => Addr# -> ei -> State# RealWorld -> (# Addr#, State# RealWorld #) writeExponent ptr !expo s1 @@ -910,9 +902,6 @@ writeSign ptr False s = (# ptr, s #) toCharsScientific :: forall a mw ei. ( Mantissa mw , DecimalLength mw - , ei ~ ExponentInt a - , Ord ei - , Num ei , Integral ei , ToInt ei , FromInt ei @@ -956,7 +945,6 @@ breakdown :: forall a mw ew. , mw ~ MantissaWord a , Bits mw , Integral mw - , ew ~ ExponentWord a , Num ew ) => a -> (Bool, mw, ew) breakdown f = (sign, mantissa, expo) From bd2b68585e447b587037fc921262b9796b10e503 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Fri, 12 Jan 2024 16:00:22 -0500 Subject: [PATCH 28/34] cleaned up function formatFloating --- Data/ByteString/Builder/RealFloat.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 29af9afdf..0c0a9450d 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -246,18 +247,19 @@ formatFloating :: forall a mw ew ei. , R.FromInt ei ) => FloatFormat -> a -> Builder formatFloating fmt f = case fmt of - FGeneric eE prec (minExpo,maxExpo) ss -> flip fromMaybe (R.toCharsNonNumbersAndZero ss f) $ + FGeneric eE prec (minExpo,maxExpo) ss -> specialsOr ss if e' >= minExpo && e' <= maxExpo - then printSign f `mappend` showStandard (toWord64 m) e' prec + then std prec else sci eE - FScientific eE ss -> fromMaybe (sci eE) (R.toCharsNonNumbersAndZero ss f) - FStandard prec ss -> flip fromMaybe (R.toCharsNonNumbersAndZero ss f) $ - printSign f `mappend` showStandard (toWord64 m) e' prec + FScientific eE ss -> specialsOr ss $ sci eE + FStandard prec ss -> specialsOr ss $ std prec where sci eE = BP.primBounded (R.toCharsScientific @a Proxy eE sign m e) () + std prec = printSign f `mappend` showStandard (toWord64 m) e' prec e' = R.toInt e + R.decimalLength m R.FloatingDecimal m e = toD @a mantissa expo (sign, mantissa, expo) = R.breakdown f + specialsOr ss = flip fromMaybe $ R.toCharsNonNumbersAndZero ss f class ToWord64 a where toWord64 :: a -> Word64 instance ToWord64 Word32 where toWord64 = R.word32ToWord64 From a9cbf583d7ebe723c14383cc104af6d55dedd28a Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 14 Jan 2024 17:41:07 -0500 Subject: [PATCH 29/34] fixed precison printing of zero and neg zero for FStandard --- Data/ByteString/Builder/RealFloat.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 0c0a9450d..459f5abc0 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -81,6 +82,7 @@ module Data.ByteString.Builder.RealFloat import Data.ByteString.Builder.Internal (Builder) import qualified Data.ByteString.Builder.RealFloat.Internal as R +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 @@ -132,7 +134,12 @@ fGeneric eE = FGeneric (R.asciiRaw $ ord eE) -- -- @since 0.11.2.0 standard :: Int -> FloatFormat -standard n = FStandard (Just n) standardSpecialStrings +standard n = FStandard (Just n) 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`) -- From bbd4f76d19ac2c51d614921b1a7514c602a22335 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Mon, 15 Jan 2024 21:28:01 -0500 Subject: [PATCH 30/34] labels for RealFloat format parameters --- Data/ByteString/Builder/RealFloat.hs | 54 +++++++++++++++++++++------- 1 file changed, 41 insertions(+), 13 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 459f5abc0..3ce54d87f 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -8,6 +8,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -119,22 +121,45 @@ doubleDec = formatFloating generic -- -- @since 0.11.2.0 data FloatFormat - = FScientific Word8# R.SpecialStrings -- ^ scientific notation - | FStandard (Maybe Int) R.SpecialStrings -- ^ standard notation with `Maybe Int` digits after the decimal - | FGeneric Word8# (Maybe Int) (Int,Int) R.SpecialStrings -- ^ dispatches to scientific or standard notation based on the exponent + -- | scientific notation + = FScientific + { eE :: Word8# + , specials :: R.SpecialStrings + } + -- | standard notation with `Maybe Int` digits after the decimal + | FStandard + { precision :: Maybe Int + , specials :: R.SpecialStrings + } + -- | dispatches to scientific or standard notation based on the exponent + | FGeneric + { eE :: Word8# + , precision :: Maybe Int + , stdExpoRange :: (Int, Int) + , specials :: R.SpecialStrings + } deriving Show fScientific :: Char -> R.SpecialStrings -> FloatFormat -fScientific eE = FScientific (R.asciiRaw $ ord eE) +fScientific eE specials = FScientific + { eE = R.asciiRaw $ ord eE + , specials + } fGeneric :: Char -> Maybe Int -> (Int, Int) -> R.SpecialStrings -> FloatFormat -fGeneric eE = FGeneric (R.asciiRaw $ ord eE) +fGeneric eE precision stdExpoRange specials = FGeneric + { eE = R.asciiRaw $ ord eE + , .. + } -- | Standard notation with `n` decimal places -- -- @since 0.11.2.0 standard :: Int -> FloatFormat -standard n = FStandard (Just n) standardSpecialStrings {positiveZero, negativeZero} +standard n = FStandard + { precision = Just n + , specials = standardSpecialStrings {positiveZero, negativeZero} + } where positiveZero = if n == 0 then "0" @@ -145,7 +170,10 @@ standard n = FStandard (Just n) standardSpecialStrings {positiveZero, negativeZe -- -- @since 0.11.2.0 standardDefaultPrecision :: FloatFormat -standardDefaultPrecision = FStandard Nothing standardSpecialStrings +standardDefaultPrecision = FStandard + { precision = Nothing + , specials = standardSpecialStrings + } -- | Scientific notation with \'default precision\' (decimal places matching `show`) -- @@ -254,19 +282,19 @@ formatFloating :: forall a mw ew ei. , R.FromInt ei ) => FloatFormat -> a -> Builder formatFloating fmt f = case fmt of - FGeneric eE prec (minExpo,maxExpo) ss -> specialsOr ss + FGeneric {stdExpoRange = (minExpo,maxExpo), ..} -> specialsOr specials if e' >= minExpo && e' <= maxExpo - then std prec + then std precision else sci eE - FScientific eE ss -> specialsOr ss $ sci eE - FStandard prec ss -> specialsOr ss $ std prec + FScientific {..} -> specialsOr specials $ sci eE + FStandard {..} -> specialsOr specials $ std precision where sci eE = BP.primBounded (R.toCharsScientific @a Proxy eE sign m e) () - std prec = printSign f `mappend` showStandard (toWord64 m) e' prec + std precision = printSign f `mappend` 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 ss = flip fromMaybe $ R.toCharsNonNumbersAndZero ss f + specialsOr specials = flip fromMaybe $ R.toCharsNonNumbersAndZero specials f class ToWord64 a where toWord64 :: a -> Word64 instance ToWord64 Word32 where toWord64 = R.word32ToWord64 From a1e556ef8d05718088d100cd6f7249a4be7dfbf6 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 16 Jan 2024 06:12:02 -0500 Subject: [PATCH 31/34] fix possible overflow error when converting String to Builder --- Data/ByteString/Builder/RealFloat.hs | 7 +----- Data/ByteString/Builder/RealFloat/Internal.hs | 23 +++++++------------ 2 files changed, 9 insertions(+), 21 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 3ce54d87f..772b8033a 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -309,11 +309,6 @@ instance ToD Double where toD = RD.d2d 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 printSign :: RealFloat a => a -> Builder printSign f = if f < 0 then char7 '-' else mempty @@ -332,7 +327,7 @@ showStandard m e prec = 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 diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index dd01640dd..6fde9dac8 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -28,6 +28,7 @@ module Data.ByteString.Builder.RealFloat.Internal ( mask + , string7 , toCharsNonNumbersAndZero , SpecialStrings(..) , DecimalLength(..) @@ -85,9 +86,7 @@ module Data.ByteString.Builder.RealFloat.Internal , module Data.ByteString.Builder.RealFloat.TableGenerator ) where -import Control.Monad (foldM) import Data.Bits (Bits(..), FiniteBits(..)) -import Data.ByteString.Internal (c2w) import Data.ByteString.Builder.Internal (Builder) import Data.ByteString.Builder.Prim.Internal (BoundedPrim, boundedPrim) import Data.ByteString.Builder.RealFloat.TableGenerator @@ -99,10 +98,9 @@ import Foreign.C.Types import GHC.Int (Int(..), Int32(..)) import GHC.IO (IO(..), unIO) import GHC.Prim -import GHC.Ptr (Ptr(..), plusPtr, castPtr) +import GHC.Ptr (Ptr(..), castPtr) import GHC.Types (isTrue#) -import GHC.Word (Word8, Word16(..), Word32(..), Word64(..)) -import qualified Foreign.Storable as S (poke) +import GHC.Word (Word16(..), Word32(..), Word64(..)) #include #include "MachDeps.h" @@ -234,15 +232,10 @@ instance DecimalLength Word64 where decimalLength = decimalLength17 maxEncodedLength :: Int maxEncodedLength = 32 --- | Storable.poke a String into a Ptr Word8, converting through c2w -pokeAll :: String -> Ptr Word8 -> IO (Ptr Word8) -pokeAll s ptr = foldM pokeOne ptr s - where pokeOne p c = S.poke p (c2w c) >> return (p `plusPtr` 1) - --- | Unsafe creation of a bounded primitive of String at most length --- `maxEncodedLength` -boundString :: String -> BoundedPrim () -boundString s = boundedPrim maxEncodedLength $ const (pokeAll s) +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = BP.primMapListFixed BP.char7 -- | Special rendering for NaN, positive\/negative 0, and positive\/negative -- infinity. These are based on the IEEE representation of non-numbers. @@ -284,7 +277,7 @@ toCharsNonNumbersAndZero :: forall a mw ew. , ew ~ ExponentWord a , mw ~ MantissaWord a ) => SpecialStrings -> a -> Maybe Builder -toCharsNonNumbersAndZero SpecialStrings{..} f = flip BP.primBounded () . boundString <$> +toCharsNonNumbersAndZero SpecialStrings{..} f = string7 <$> if w .&. expoMantissaBits == 0 then Just if w == signBit then negativeZero else positiveZero else if w .&. expoMask == expoMask From 182d76fcb2ec3f957894691386f831800a08e47f Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 16 Jan 2024 06:27:19 -0500 Subject: [PATCH 32/34] specialized maxEncodeLength to Float and Double also helps prevent future overflow implementation errors for example 128 bit floats --- Data/ByteString/Builder/RealFloat.hs | 1 + Data/ByteString/Builder/RealFloat/Internal.hs | 12 +++++++----- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 772b8033a..99a5cf216 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -267,6 +267,7 @@ formatFloating :: forall a mw ew ei. , R.ExponentBits a , R.MantissaBits a , R.CastToWord a + , R.MaxEncodedLength a -- mantissa , mw ~ R.MantissaWord a , R.Mantissa mw diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index 6fde9dac8..cc86b6be5 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -44,6 +44,7 @@ module Data.ByteString.Builder.RealFloat.Internal , trimTrailing , trimNoTrailing , closestCorrectlyRounded + , MaxEncodedLength(..) , toCharsScientific , asciiRaw -- hand-rolled division and remainder for f2s and d2s @@ -228,9 +229,9 @@ instance DecimalLength Word64 where decimalLength = decimalLength17 -- -- floats: 1 (sign) + 9 (mantissa) + 1 (.) + 1 (e) + 3 (exponent) = 15 -- doubles: 1 (sign) + 17 (mantissa) + 1 (.) + 1 (e) + 4 (exponent) = 24 --- -maxEncodedLength :: Int -maxEncodedLength = 32 +class MaxEncodedLength a where maxEncodedLength :: Int +instance MaxEncodedLength Float where maxEncodedLength = 15 +instance MaxEncodedLength Double where maxEncodedLength = 24 -- | Char7 encode a 'String'. {-# INLINE string7 #-} @@ -893,13 +894,14 @@ writeSign ptr False s = (# ptr, s #) {-# SPECIALIZE toCharsScientific :: Proxy Float -> Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} {-# SPECIALIZE toCharsScientific :: Proxy Double -> Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} toCharsScientific :: forall a mw ei. - ( Mantissa mw + ( MaxEncodedLength a + , Mantissa mw , DecimalLength mw , Integral ei , ToInt ei , FromInt ei ) => Proxy a -> Word8# -> Bool -> mw -> ei -> BoundedPrim () -toCharsScientific _ eE !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !(Ptr p0)-> do +toCharsScientific _ eE !sign !mantissa !expo = boundedPrim (maxEncodedLength @a) $ \_ !(Ptr p0)-> do let !olength@(I# ol) = decimalLength mantissa !expo' = expo + fromInt olength - 1 IO $ \s1 -> From 8479796ce543f39dcce46183fbf751473ec84899 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 16 Jan 2024 07:07:23 -0500 Subject: [PATCH 33/34] moved FloatFormat to Internal so that it can be exported and users can manipulate it beyond the regular formants --- Data/ByteString/Builder/RealFloat.hs | 40 +--------- Data/ByteString/Builder/RealFloat/D2S.hs | 5 +- Data/ByteString/Builder/RealFloat/F2S.hs | 5 +- Data/ByteString/Builder/RealFloat/Internal.hs | 74 ++++++++++++++----- 4 files changed, 64 insertions(+), 60 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 99a5cf216..1d6f89d18 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -8,8 +8,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# LANGUAGE DuplicateRecordFields #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -84,6 +82,7 @@ module Data.ByteString.Builder.RealFloat 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 @@ -91,8 +90,6 @@ import qualified Data.ByteString.Builder.Prim as BP import GHC.Float (roundTo) import GHC.Word (Word32, Word64) import GHC.Show (intToDigit) -import Data.Char (ord) -import GHC.Prim (Word8#) import Data.Bits (Bits) import Data.Proxy (Proxy(Proxy)) import Data.Maybe (fromMaybe) @@ -117,41 +114,6 @@ floatDec = formatFloating generic doubleDec :: Double -> Builder doubleDec = formatFloating generic --- | Format type for use with `formatFloat` and `formatDouble`. --- --- @since 0.11.2.0 -data FloatFormat - -- | scientific notation - = FScientific - { eE :: Word8# - , specials :: R.SpecialStrings - } - -- | standard notation with `Maybe Int` digits after the decimal - | FStandard - { precision :: Maybe Int - , specials :: R.SpecialStrings - } - -- | dispatches to scientific or standard notation based on the exponent - | FGeneric - { eE :: Word8# - , precision :: Maybe Int - , stdExpoRange :: (Int, Int) - , specials :: R.SpecialStrings - } - deriving Show - -fScientific :: Char -> R.SpecialStrings -> FloatFormat -fScientific eE specials = FScientific - { eE = R.asciiRaw $ ord eE - , specials - } - -fGeneric :: Char -> Maybe Int -> (Int, Int) -> R.SpecialStrings -> FloatFormat -fGeneric eE precision stdExpoRange specials = FGeneric - { eE = R.asciiRaw $ ord eE - , .. - } - -- | Standard notation with `n` decimal places -- -- @since 0.11.2.0 diff --git a/Data/ByteString/Builder/RealFloat/D2S.hs b/Data/ByteString/Builder/RealFloat/D2S.hs index a1e342c50..8f6fe069d 100644 --- a/Data/ByteString/Builder/RealFloat/D2S.hs +++ b/Data/ByteString/Builder/RealFloat/D2S.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} -- | -- Module : Data.ByteString.Builder.RealFloat.D2S -- Copyright : (c) Lawrence Wu 2021 @@ -171,7 +172,7 @@ d2dGeneral 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 @@ -179,7 +180,7 @@ d2dGeneral m e = -- 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 diff --git a/Data/ByteString/Builder/RealFloat/F2S.hs b/Data/ByteString/Builder/RealFloat/F2S.hs index 006e43724..6d253f310 100644 --- a/Data/ByteString/Builder/RealFloat/F2S.hs +++ b/Data/ByteString/Builder/RealFloat/F2S.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns, MagicHash #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} -- | -- Module : Data.ByteString.Builder.RealFloat.F2S -- Copyright : (c) Lawrence Wu 2021 @@ -150,7 +151,7 @@ f2d 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 f2dGT e2 u v w else f2dLT e2 u v w @@ -158,7 +159,7 @@ f2d m e = -- 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 diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index cc86b6be5..dae38a50a 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -9,6 +9,9 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} -- | -- Module : Data.ByteString.Builder.RealFloat.Internal -- Copyright : (c) Lawrence Wu 2021 @@ -83,6 +86,9 @@ module Data.ByteString.Builder.RealFloat.Internal , CastToWord(..) , ToInt(..) , FromInt(..) + , FloatFormat(..) + , fScientific + , fGeneric , module Data.ByteString.Builder.RealFloat.TableGenerator ) where @@ -656,43 +662,44 @@ data BoundsState a = BoundsState trimTrailing :: Mantissa a => BoundsState a -> (BoundsState a, Int32) trimTrailing !initial = (res, r + r') where - !(d', r) = trimTrailing' initial - !(d'', r') = if vuIsTrailingZeros d' then trimTrailing'' d' else (d', 0) - res = if vvIsTrailingZeros d'' && lastRemovedDigit d'' == 5 && vv d'' `rem` 2 == 0 + !(d'@BoundsState{vuIsTrailingZeros = vuIsTrailingZeros'}, r) = trimTrailing' initial + !(d''@BoundsState{vvIsTrailingZeros = vvIsTrailingZeros'', lastRemovedDigit = lastRemovedDigit'', vv = vv''}, r') = + if vuIsTrailingZeros' then trimTrailing'' d' else (d', 0) + res = if vvIsTrailingZeros'' && lastRemovedDigit'' == 5 && vv'' `rem` 2 == 0 -- set `{ lastRemovedDigit = 4 }` to round-even then d'' else d'' - trimTrailing' !d + trimTrailing' !d@BoundsState{..} | vw' > vu' = fmap ((+) 1) . trimTrailing' $ d { vu = vu' , vv = vv' , vw = vw' , lastRemovedDigit = vvRem - , vuIsTrailingZeros = vuIsTrailingZeros d && vuRem == 0 - , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 + , vuIsTrailingZeros = vuIsTrailingZeros && vuRem == 0 + , vvIsTrailingZeros = vvIsTrailingZeros && lastRemovedDigit == 0 } | otherwise = (d, 0) where - !(vv', vvRem) = quotRem10 $ vv d - !(vu', vuRem) = quotRem10 $ vu d - !(vw', _ ) = quotRem10 $ vw d + !(vv', vvRem) = quotRem10 vv + !(vu', vuRem) = quotRem10 vu + !(vw', _ ) = quotRem10 vw - trimTrailing'' !d + trimTrailing'' !d@BoundsState{..} | vuRem == 0 = fmap ((+) 1) . trimTrailing'' $ d { vu = vu' , vv = vv' , vw = vw' , lastRemovedDigit = vvRem - , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 + , vvIsTrailingZeros = vvIsTrailingZeros && lastRemovedDigit == 0 } | otherwise = (d, 0) where - !(vu', vuRem) = quotRem10 $ vu d - !(vv', vvRem) = quotRem10 $ vv d - !(vw', _ ) = quotRem10 $ vw d + !(vu', vuRem) = quotRem10 vu + !(vv', vvRem) = quotRem10 vv + !(vw', _ ) = quotRem10 vw -- | Trim digits and update bookkeeping state when the table-computed @@ -731,10 +738,10 @@ trimNoTrailing !(BoundsState u v w ld _ _) = -- bounds {-# INLINE closestCorrectlyRounded #-} closestCorrectlyRounded :: Mantissa a => Bool -> BoundsState a -> a -closestCorrectlyRounded acceptBound s = vv s + boolToWord roundUp +closestCorrectlyRounded acceptBound BoundsState{..} = vv + boolToWord roundUp where - outsideBounds = not (vuIsTrailingZeros s) || not acceptBound - roundUp = (vv s == vu s && outsideBounds) || lastRemovedDigit s >= 5 + outsideBounds = not vuIsTrailingZeros || not acceptBound + roundUp = (vv == vu && outsideBounds) || lastRemovedDigit >= 5 -- Wrappe around int2Word# asciiRaw :: Int -> Word8# @@ -972,3 +979,36 @@ instance MantissaBits Double where mantissaBits = 52 class ExponentBits a where exponentBits :: Int instance ExponentBits Float where exponentBits = 8 instance ExponentBits Double where exponentBits = 11 + +-- | Format type for use with `formatFloat` and `formatDouble`. +-- +-- @since 0.11.2.0 +data FloatFormat + -- | scientific notation + = FScientific + { eE :: Word8# + , specials :: SpecialStrings + } + -- | standard notation with `Maybe Int` digits after the decimal + | FStandard + { precision :: Maybe Int + , specials :: SpecialStrings + } + -- | dispatches to scientific or standard notation based on the exponent + | FGeneric + { eE :: Word8# + , precision :: Maybe Int + , stdExpoRange :: (Int, Int) + , specials :: SpecialStrings + } + deriving Show +fScientific :: Char -> SpecialStrings -> FloatFormat +fScientific eE specials = FScientific + { eE = asciiRaw $ ord eE + , specials + } +fGeneric :: Char -> Maybe Int -> (Int, Int) -> SpecialStrings -> FloatFormat +fGeneric eE precision stdExpoRange specials = FGeneric + { eE = asciiRaw $ ord eE + , .. + } From a2c73244a4508ea82cc78b9ba3ac9b4294840019 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 16 Jan 2024 05:52:47 -0500 Subject: [PATCH 34/34] added zero padded exponent for scientific floating builder --- Data/ByteString/Builder/RealFloat.hs | 47 +++++++++++----- Data/ByteString/Builder/RealFloat/Internal.hs | 55 +++++++++++++++---- bench/BenchAll.hs | 12 ++++ bytestring.cabal | 3 +- .../builder/Data/ByteString/Builder/Tests.hs | 36 +++++++++++- 5 files changed, 124 insertions(+), 29 deletions(-) diff --git a/Data/ByteString/Builder/RealFloat.hs b/Data/ByteString/Builder/RealFloat.hs index 1d6f89d18..2d33f00d5 100644 --- a/Data/ByteString/Builder/RealFloat.hs +++ b/Data/ByteString/Builder/RealFloat.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -- | -- Module : Data.ByteString.Builder.RealFloat -- Copyright : (c) Lawrence Wu 2021 @@ -77,6 +78,7 @@ module Data.ByteString.Builder.RealFloat , standard , standardDefaultPrecision , scientific + , scientificZeroPaddedExponent , generic ) where @@ -117,7 +119,7 @@ doubleDec = formatFloating generic -- | Standard notation with `n` decimal places -- -- @since 0.11.2.0 -standard :: Int -> FloatFormat +standard :: Int -> FloatFormat a standard n = FStandard { precision = Just n , specials = standardSpecialStrings {positiveZero, negativeZero} @@ -131,7 +133,7 @@ standard n = FStandard -- | Standard notation with the \'default precision\' (decimal places matching `show`) -- -- @since 0.11.2.0 -standardDefaultPrecision :: FloatFormat +standardDefaultPrecision :: FloatFormat a standardDefaultPrecision = FStandard { precision = Nothing , specials = standardSpecialStrings @@ -140,8 +142,24 @@ standardDefaultPrecision = FStandard -- | Scientific notation with \'default precision\' (decimal places matching `show`) -- -- @since 0.11.2.0 -scientific :: FloatFormat -scientific = fScientific 'e' scientificSpecialStrings +scientific :: FloatFormat a +scientific = fScientific 'e' scientificSpecialStrings False + +-- | Like @scientific@ but has a zero padded exponent. +scientificZeroPaddedExponent :: forall a. ZeroPadCount a => FloatFormat a +scientificZeroPaddedExponent = scientific + { expoZeroPad = True + , specials = scientificSpecialStrings + { positiveZero + , negativeZero = '-' : positiveZero + } + } + where + positiveZero = "0.0e" <> replicate (zeroPadCount @a) '0' + +class ZeroPadCount a where zeroPadCount :: Int +instance ZeroPadCount Float where zeroPadCount = 2 +instance ZeroPadCount Double where zeroPadCount = 3 scientificSpecialStrings, standardSpecialStrings :: R.SpecialStrings scientificSpecialStrings = R.SpecialStrings @@ -159,8 +177,8 @@ standardSpecialStrings = scientificSpecialStrings -- | Standard or scientific notation depending on the exponent. Matches `show` -- -- @since 0.11.2.0 -generic :: FloatFormat -generic = fGeneric 'e' Nothing (0,7) standardSpecialStrings +generic :: FloatFormat a +generic = fGeneric 'e' Nothing (0,7) standardSpecialStrings False -- TODO: support precision argument for FGeneric and FScientific -- | Returns a rendered Float. Returns the \'shortest\' representation in @@ -187,7 +205,7 @@ generic = fGeneric 'e' Nothing (0,7) standardSpecialStrings -- -- @since 0.11.2.0 {-# INLINABLE formatFloat #-} -formatFloat :: FloatFormat -> Float -> Builder +formatFloat :: FloatFormat Float -> Float -> Builder formatFloat = formatFloating -- TODO: support precision argument for FGeneric and FScientific @@ -215,12 +233,12 @@ formatFloat = formatFloating -- -- @since 0.11.2.0 {-# INLINABLE formatDouble #-} -formatDouble :: FloatFormat -> Double -> Builder +formatDouble :: FloatFormat Double -> Double -> Builder formatDouble = formatFloating {-# INLINABLE formatFloating #-} -{-# SPECIALIZE formatFloating :: FloatFormat -> Float -> Builder #-} -{-# SPECIALIZE formatFloating :: FloatFormat -> Double -> Builder #-} +{-# SPECIALIZE formatFloating :: FloatFormat Float -> Float -> Builder #-} +{-# SPECIALIZE formatFloating :: FloatFormat Double -> Double -> Builder #-} formatFloating :: forall a mw ew ei. -- a --( ToS a @@ -230,6 +248,7 @@ formatFloating :: forall a mw ew ei. , R.MantissaBits a , R.CastToWord a , R.MaxEncodedLength a + , R.WriteZeroPaddedExponent a -- mantissa , mw ~ R.MantissaWord a , R.Mantissa mw @@ -243,16 +262,16 @@ formatFloating :: forall a mw ew ei. , R.ToInt ei , Integral ei , R.FromInt ei - ) => FloatFormat -> a -> Builder + ) => FloatFormat a -> 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 + else sci expoZeroPad eE + FScientific {..} -> specialsOr specials $ sci expoZeroPad eE FStandard {..} -> specialsOr specials $ std precision where - sci eE = BP.primBounded (R.toCharsScientific @a Proxy eE sign m e) () + sci expoZeroPad eE = BP.primBounded (R.toCharsScientific @a Proxy expoZeroPad eE sign m e) () std precision = printSign f `mappend` showStandard (toWord64 m) e' precision e' = R.toInt e + R.decimalLength m R.FloatingDecimal m e = toD @a mantissa expo diff --git a/Data/ByteString/Builder/RealFloat/Internal.hs b/Data/ByteString/Builder/RealFloat/Internal.hs index dae38a50a..4b9ec0081 100644 --- a/Data/ByteString/Builder/RealFloat/Internal.hs +++ b/Data/ByteString/Builder/RealFloat/Internal.hs @@ -48,6 +48,7 @@ module Data.ByteString.Builder.RealFloat.Internal , trimNoTrailing , closestCorrectlyRounded , MaxEncodedLength(..) + , WriteZeroPaddedExponent , toCharsScientific , asciiRaw -- hand-rolled division and remainder for f2s and d2s @@ -870,11 +871,11 @@ writeMantissa ptr olength = go (ptr `plusAddr#` olength) in (# ptr `plusAddr#` 3#, s4 #) -- | Write the exponent into the given address. -writeExponent :: forall ei. +writeUnpaddedExponent :: forall ei. ( Integral ei , ToInt ei ) => Addr# -> ei -> State# RealWorld -> (# Addr#, State# RealWorld #) -writeExponent ptr !expo s1 +writeUnpaddedExponent ptr !expo s1 | expo >= 100 = let !(e1, e0) = fquotRem10 (fromIntegral expo) -- TODO s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw e1)) ptr s1 @@ -888,6 +889,28 @@ writeExponent ptr !expo s1 in (# ptr `plusAddr#` 1#, s2 #) where !(I# e) = toInt expo +-- | Write the zero padded exponent into the given address. +class WriteZeroPaddedExponent a where + writeZeroPaddedExponent :: Addr# -> ExponentInt a -> State# RealWorld -> (# Addr#, State# RealWorld #) +instance WriteZeroPaddedExponent Float where + writeZeroPaddedExponent ptr !expo s1 = + let s2 = copyWord16 (digit_table `unsafeAt` e) ptr s1 + in (# ptr `plusAddr#` 2#, s2 #) + where + !(I# e) = toInt expo +instance WriteZeroPaddedExponent Double where + writeZeroPaddedExponent ptr !expo s1 + | expo >= 100 = + let !(e1, e0) = fquotRem10 (fromIntegral expo) -- TODO + s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw e1)) ptr s1 + s3 = poke (ptr `plusAddr#` 2#) (wordToWord8# (toAscii (unsafeRaw e0))) s2 + in (# ptr `plusAddr#` 3#, s3 #) + | otherwise = + let s2 = poke ptr (asciiRaw asciiZero) s1 + s3 = copyWord16 (digit_table `unsafeAt` e) (ptr `plusAddr#` 1#) s2 + in (# ptr `plusAddr#` 3#, s3 #) + where !(I# e) = toInt expo + -- | Write the sign into the given address. writeSign :: Addr# -> Bool -> State# d -> (# Addr#, State# d #) writeSign ptr True s1 = @@ -898,17 +921,19 @@ writeSign ptr False s = (# ptr, s #) -- | Returns the decimal representation of a floating point number in -- scientific (exponential) notation {-# INLINABLE toCharsScientific #-} -{-# SPECIALIZE toCharsScientific :: Proxy Float -> Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} -{-# SPECIALIZE toCharsScientific :: Proxy Double -> Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} +{-# SPECIALIZE toCharsScientific :: Proxy Float -> Bool -> Word8# -> Bool -> Word32 -> Int32 -> BoundedPrim () #-} +{-# SPECIALIZE toCharsScientific :: Proxy Double -> Bool -> Word8# -> Bool -> Word64 -> Int32 -> BoundedPrim () #-} toCharsScientific :: forall a mw ei. ( MaxEncodedLength a + , WriteZeroPaddedExponent a , Mantissa mw , DecimalLength mw + , ei ~ ExponentInt a , Integral ei , ToInt ei , FromInt ei - ) => Proxy a -> Word8# -> Bool -> mw -> ei -> BoundedPrim () -toCharsScientific _ eE !sign !mantissa !expo = boundedPrim (maxEncodedLength @a) $ \_ !(Ptr p0)-> do + ) => Proxy a -> Bool -> Word8# -> Bool -> mw -> ei -> BoundedPrim () +toCharsScientific _ expoZeroPad eE !sign !mantissa !expo = boundedPrim (maxEncodedLength @a) $ \_ !(Ptr p0)-> do let !olength@(I# ol) = decimalLength mantissa !expo' = expo + fromInt olength - 1 IO $ \s1 -> @@ -918,6 +943,10 @@ toCharsScientific _ eE !sign !mantissa !expo = boundedPrim (maxEncodedLength @a) !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 !(# p4, s6 #) = writeExponent p3 (abs expo') s5 in (# s6, (Ptr p4) #) + where + writeExponent = if expoZeroPad + then writeZeroPaddedExponent @a + else writeUnpaddedExponent data FloatingDecimal a = FloatingDecimal { fmantissa :: !(MantissaWord a) @@ -983,11 +1012,12 @@ instance ExponentBits Double where exponentBits = 11 -- | Format type for use with `formatFloat` and `formatDouble`. -- -- @since 0.11.2.0 -data FloatFormat +data FloatFormat a -- | scientific notation = FScientific { eE :: Word8# , specials :: SpecialStrings + , expoZeroPad :: Bool -- ^ pad the exponent with zeros } -- | standard notation with `Maybe Int` digits after the decimal | FStandard @@ -1000,15 +1030,16 @@ data FloatFormat , precision :: Maybe Int , stdExpoRange :: (Int, Int) , specials :: SpecialStrings + , expoZeroPad :: Bool -- ^ pad the exponent with zeros } deriving Show -fScientific :: Char -> SpecialStrings -> FloatFormat -fScientific eE specials = FScientific +fScientific :: Char -> SpecialStrings -> Bool -> FloatFormat a +fScientific eE specials expoZeroPad = FScientific { eE = asciiRaw $ ord eE - , specials + , .. } -fGeneric :: Char -> Maybe Int -> (Int, Int) -> SpecialStrings -> FloatFormat -fGeneric eE precision stdExpoRange specials = FGeneric +fGeneric :: Char -> Maybe Int -> (Int, Int) -> SpecialStrings -> Bool -> FloatFormat a +fGeneric eE precision stdExpoRange specials expoZeroPad = FGeneric { eE = asciiRaw $ ord eE , .. } diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index 41950dd35..534da8b76 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -372,6 +372,18 @@ main = do [ benchB "Float Average" floatSpecials $ foldMap (formatFloat scientific) , benchB "Double Average" doubleSpecials $ foldMap (formatDouble scientific) ] + , bgroup "Zero Padded" + [ bgroup "Positive" + [ benchB "Float" floatPosData $ foldMap (formatFloat $ scientificZeroPaddedExponent) + , benchB "Double" doublePosData $ foldMap (formatDouble $ scientificZeroPaddedExponent) + , benchB "DoubleSmall" doublePosSmallData $ foldMap (formatDouble $ scientificZeroPaddedExponent) + ] + , bgroup "Negative" + [ benchB "Float" floatNegData $ foldMap (formatFloat $ scientificZeroPaddedExponent) + , benchB "Double" doubleNegData $ foldMap (formatDouble $ scientificZeroPaddedExponent) + , benchB "DoubleSmall" doubleNegSmallData $ foldMap (formatDouble $ scientificZeroPaddedExponent) + ] + ] ] , bgroup "FStandard" [ bgroup "Positive" diff --git a/bytestring.cabal b/bytestring.cabal index 28a4d338a..5d1cbe3f8 100644 --- a/bytestring.cabal +++ b/bytestring.cabal @@ -92,6 +92,7 @@ library Data.ByteString.Builder.Extra Data.ByteString.Builder.Prim Data.ByteString.Builder.RealFloat + Data.ByteString.Builder.RealFloat.Internal -- perhaps only exposed temporarily Data.ByteString.Builder.Internal @@ -103,7 +104,6 @@ library Data.ByteString.Builder.Prim.Internal.Floating Data.ByteString.Builder.RealFloat.F2S Data.ByteString.Builder.RealFloat.D2S - Data.ByteString.Builder.RealFloat.Internal Data.ByteString.Builder.RealFloat.TableGenerator Data.ByteString.Internal.Type Data.ByteString.Lazy.Internal.Deque @@ -181,6 +181,7 @@ test-suite bytestring-tests deepseq, ghc-prim, QuickCheck, + quickcheck-assertions, tasty, tasty-hunit, tasty-quickcheck >= 0.8.1, diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index f35bcfc3f..90d9177f7 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -3,6 +3,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -27,7 +29,7 @@ import Control.Monad.Trans.Writer (WriterT, execWriterT, tell) import Foreign (minusPtr) -import Data.Char (chr) +import Data.Char (chr, isDigit) import Data.Bits ((.|.), shiftL) import Data.Foldable import Data.Semigroup (Semigroup(..)) @@ -45,6 +47,7 @@ import Data.ByteString.Builder.Internal (Put, putBuilder, fromPut) import qualified Data.ByteString.Builder.Internal as BI import qualified Data.ByteString.Builder.Prim as BP import Data.ByteString.Builder.Prim.TestUtils +import Data.ByteString.Builder.RealFloat.Internal (FloatFormat(FScientific), expoZeroPad, positiveZero, negativeZero, specials) import Control.Exception (evaluate) import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode, hSetEncoding, utf8, hSetNewlineMode, noNewlineTranslation) @@ -58,10 +61,11 @@ import Test.Tasty.HUnit (testCase, (@?=), Assertion) import Test.Tasty.QuickCheck ( Arbitrary(..), oneof, choose, listOf, elements, forAll , counterexample, ioProperty, Property, testProperty - , (===), (.&&.), conjoin + , (===), (.&&.), (.||.), conjoin , UnicodeString(..), NonNegative(..) ) import QuickCheckUtils +import Test.QuickCheck.Assertions (binAsrt) tests :: [TestTree] @@ -743,6 +747,20 @@ testsFloating = testGroup "RealFloat" , ( 1.2345678 , "1.2345678" ) , ( 1.23456735e-36 , "1.23456735e-36" ) ] + , testProperty "zero padded exponent" \d -> let + padLen = 2 + bs = toLazyByteString $ formatFloat (scientificZeroPaddedExponent @Float) $ d + s = LC.unpack bs + indexEnd i = bs `LC.index` (LC.length bs - i) + in conjoin + [ binAsrt (s <> " does not read to the value " <> show d) $ + read (LC.unpack bs) == d + , binAsrt (s <> " does not have " <> show padLen <> " exponent digits") $ + LC.all isDigit (LC.takeEnd padLen bs) + , binAsrt (s <> " does not have a proper prefix to exponent digits") + $ indexEnd (padLen + 1) == 'e' + || indexEnd (padLen + 1) == '-' && indexEnd (padLen + 2) == 'e' + ] , testMatches "f2sPowersOf10" floatDec show $ fmap asShowRef [read ("1.0e" ++ show x) :: Float | x <- [-46..39 :: Int]] ] @@ -973,6 +991,20 @@ testsFloating = testGroup "RealFloat" , ( 549755813888.0e+3 , "5.49755813888e14" ) , ( 8796093022208.0e+3 , "8.796093022208e15" ) ] + , testProperty "zero padded exponent" \d -> let + padLen = 3 + bs = toLazyByteString $ formatDouble (scientificZeroPaddedExponent @Double) $ d + s = LC.unpack bs + indexEnd i = bs `LC.index` (LC.length bs - i) + in conjoin + [ binAsrt (s <> " does not read to the value " <> show d) $ + read (LC.unpack bs) == d + , binAsrt (s <> " does not have " <> show padLen <> " exponent digits") $ + LC.all isDigit (LC.takeEnd padLen bs) + , binAsrt (s <> " does not have a proper prefix to exponent digits") + $ indexEnd (padLen + 1) == 'e' + || indexEnd (padLen + 1) == '-' && indexEnd (padLen + 2) == 'e' + ] , testMatches "d2sPowersOf10" doubleDec show $ fmap asShowRef [read ("1.0e" ++ show x) :: Double | x <- [-324..309 :: Int]] ]