{-# LANGUAGE ScopedTypeVariables, ExplicitForAll #-} {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- | -- Module : Data.ByteString.Builder.RealFloat.Internal -- Copyright : (c) Lawrence Wu 2021 -- License : BSD-style -- Maintainer : lawrencejwu@gmail.com -- -- Various floating-to-string conversion helpers that are somewhat -- floating-size agnostic -- -- This module includes -- -- - Efficient formatting for scientific floating-to-string -- - Trailing zero handling when converting to decimal power base -- - Approximations for logarithms of powers -- - Fast-division by reciprocal multiplication -- - Prim-op bit-wise peek module Data.ByteString.Builder.RealFloat.Internal ( mask , NonNumbersAndZero(..) , toCharsNonNumbersAndZero , decimalLength9 , decimalLength17 , Mantissa , pow5bits , log10pow2 , log10pow5 , pow5_factor , multipleOfPowerOf5 , multipleOfPowerOf2 , acceptBounds , BoundsState(..) , trimTrailing , trimNoTrailing , closestCorrectlyRounded , toCharsScientific -- hand-rolled division and remainder for f2s and d2s , fquot10 , frem10 , fquot5 , frem5 , dquot10 , dquotRem10 , dquot5 , drem5 , dquot100 -- prim-op helpers , timesWord2 , Addr(..) , ByteArray(..) , castDoubleToWord64 , castFloatToWord32 , getWord64At , getWord128At -- monomorphic conversions , boolToWord32 , boolToWord64 , int32ToInt , intToInt32 , word32ToInt , word64ToInt , word32ToWord64 , word64ToWord32 , 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.Prim.Internal (BoundedPrim, boundedPrim) import Data.ByteString.Builder.RealFloat.TableGenerator import Data.Char (ord) import GHC.Int (Int(..), Int32(..)) import GHC.Prim import GHC.Ptr (Ptr(..), plusPtr) import GHC.ST (ST(..), runST) import GHC.Types (isTrue#) import GHC.Word (Word8, Word32(..), Word64(..)) import qualified Foreign.Storable as S (poke) #include #include "MachDeps.h" #if WORD_SIZE_IN_BITS < 64 && !MIN_VERSION_ghc_prim(0,8,0) import GHC.IntWord64 #endif #if __GLASGOW_HASKELL__ >= 804 import GHC.Float (castFloatToWord32, castDoubleToWord64) #else import System.IO.Unsafe (unsafePerformIO) import Foreign.Marshal.Utils (with) import Foreign.Ptr (castPtr) import Foreign.Storable (peek) -- | Interpret a 'Float' as a 'Word32' as if through a bit-for-bit copy. -- (fallback if not available through GHC.Float) -- -- e.g -- -- > showHex (castFloatToWord32 1.0) [] = "3f800000" {-# NOINLINE castFloatToWord32 #-} castFloatToWord32 :: Float -> Word32 castFloatToWord32 x = unsafePerformIO (with x (peek . castPtr)) -- | Interpret a 'Double' as a 'Word64' as if through a bit-for-bit copy. -- (fallback if not available through GHC.Float) -- -- e.g -- -- > showHex (castDoubleToWord64 1.0) [] = "3ff0000000000000" {-# NOINLINE castDoubleToWord64 #-} castDoubleToWord64 :: Double -> Word64 castDoubleToWord64 x = unsafePerformIO (with x (peek . castPtr)) #endif -- | Build a full bit-mask of specified length. -- -- e.g -- -- > showHex (mask 12) [] = "fff" {-# INLINABLE mask #-} mask :: (Bits a, Integral a) => Int -> a mask = flip (-) 1 . unsafeShiftL 1 -- | Convert boolean false to 0 and true to 1 {-# INLINABLE boolToWord32 #-} boolToWord32 :: Bool -> Word32 boolToWord32 = fromIntegral . fromEnum -- | Convert boolean false to 0 and true to 1 {-# INLINABLE boolToWord64 #-} boolToWord64 :: Bool -> Word64 boolToWord64 = fromIntegral . fromEnum -- | Monomorphic conversion for @Int32 -> Int@ {-# INLINABLE int32ToInt #-} int32ToInt :: Int32 -> Int int32ToInt = fromIntegral -- | Monomorphic conversion for @Int -> Int32@ {-# INLINABLE intToInt32 #-} intToInt32 :: Int -> Int32 intToInt32 = fromIntegral -- | Monomorphic conversion for @Word32 -> Int@ {-# INLINABLE word32ToInt #-} word32ToInt :: Word32 -> Int word32ToInt = fromIntegral -- | Monomorphic conversion for @Word64 -> Int@ {-# INLINABLE word64ToInt #-} word64ToInt :: Word64 -> Int word64ToInt = fromIntegral -- | Monomorphic conversion for @Word32 -> Word64@ {-# INLINABLE word32ToWord64 #-} word32ToWord64 :: Word32 -> Word64 word32ToWord64 = fromIntegral -- | Monomorphic conversion for @Word64 -> Word32@ {-# INLINABLE word64ToWord32 #-} word64ToWord32 :: Word64 -> Word32 word64ToWord32 = fromIntegral -- | Returns the number of decimal digits in v, which must not contain more than 9 digits. decimalLength9 :: Word32 -> Int decimalLength9 v | v >= 100000000 = 9 | v >= 10000000 = 8 | v >= 1000000 = 7 | v >= 100000 = 6 | v >= 10000 = 5 | v >= 1000 = 4 | v >= 100 = 3 | v >= 10 = 2 | otherwise = 1 -- | Returns the number of decimal digits in v, which must not contain more than 17 digits. decimalLength17 :: Word64 -> Int decimalLength17 v | v >= 10000000000000000 = 17 | v >= 1000000000000000 = 16 | v >= 100000000000000 = 15 | v >= 10000000000000 = 14 | v >= 1000000000000 = 13 | v >= 100000000000 = 12 | v >= 10000000000 = 11 | v >= 1000000000 = 10 | v >= 100000000 = 9 | v >= 10000000 = 8 | v >= 1000000 = 7 | v >= 100000 = 6 | v >= 10000 = 5 | v >= 1000 = 4 | v >= 100 = 3 | v >= 10 = 2 | otherwise = 1 -- 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 -- -- v^(m-1) > b^n -- -- Specifically for binary floating point to decimal conversion, we must have -- -- 10^(m-1) > 2^n -- => log(10^(m-1)) > log(2^n) -- => (m-1) * log(10) > n * log(2) -- => m-1 > n * log(2) / log(10) -- => m-1 >= ceil(n * log(2) / log(10)) -- => m >= ceil(n * log(2) / log(10)) + 1 -- -- And since 32 and 64-bit floats have 23 and 52 bits of mantissa (and then an -- implicit leading-bit), we need -- -- ceil(24 * log(2) / log(10)) + 1 => 9 -- ceil(53 * log(2) / log(10)) + 1 => 17 -- -- In addition, the exponent range from floats is [-45,38] and doubles is -- [-324,308] (including subnormals) which are 3 and 4 digits respectively -- -- Thus we have, -- -- 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 -- | 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) -- | Special rendering for NaN, positive\/negative 0, and positive\/negative -- infinity. These are based on the IEEE representation of non-numbers. -- -- Infinity -- -- * sign = 0 for positive infinity, 1 for negative infinity. -- * biased exponent = all 1 bits. -- * fraction = all 0 bits. -- -- NaN -- -- * sign = either 0 or 1 (ignored) -- * biased exponent = all 1 bits. -- * fraction = anything except all 0 bits. -- -- We also handle 0 specially here so that the exponent rendering is more -- correct. -- -- * 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 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 "" -- | 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 -- is implemented as -- -- @ -- acceptBounds _ = False -- @ -- -- For round-to-even and correct shortest, use -- -- @ -- acceptBounds v = ((v \`quot\` 4) .&. 1) == 0 -- @ acceptBounds :: Mantissa a => a -> Bool acceptBounds _ = False ------------------------------------------------------------------------------- -- Logarithm Approximations -- -- These are based on the same transformations. -- -- e.g -- -- log_2(5^e) goal function -- = e * log_2(5) log exponenation -- ~= e * floor(10^7 * log_2(5)) / 10^7 integer operations -- ~= e * 1217359 / 2^19 approximation into n / 2^m -- -- These are verified in the unit tests for the given input ranges ------------------------------------------------------------------------------- -- | Returns e == 0 ? 1 : ceil(log_2(5^e)); requires 0 <= e <= 3528. pow5bitsUnboxed :: Int# -> Int# pow5bitsUnboxed e = (e *# 1217359#) `uncheckedIShiftRL#` 19# +# 1# -- | Returns floor(log_10(2^e)); requires 0 <= e <= 1650. log10pow2Unboxed :: Int# -> Int# log10pow2Unboxed e = (e *# 78913#) `uncheckedIShiftRL#` 18# -- | Returns floor(log_10(5^e)); requires 0 <= e <= 2620. log10pow5Unboxed :: Int# -> Int# log10pow5Unboxed e = (e *# 732923#) `uncheckedIShiftRL#` 20# -- | Boxed versions of the functions above pow5bits, log10pow2, log10pow5 :: Int -> Int pow5bits = wrapped pow5bitsUnboxed log10pow2 = wrapped log10pow2Unboxed log10pow5 = wrapped log10pow5Unboxed ------------------------------------------------------------------------------- -- Fast Division -- -- Division is slow. We leverage fixed-point arithmetic to calculate division -- by a constant as multiplication by the inverse. This could potentially be -- handled by an aggressive compiler, but to ensure that the optimization -- happens, we hard-code the expected divisions / remainders by 5, 10, 100, etc -- -- e.g -- -- x / 5 goal function -- = x * (1 / 5) reciprocal -- = x * (4 / 5) / 4 -- = x * 0b0.110011001100.. / 4 recurring binary representation -- ~= x * (0xCCCCCCCD / 2^32) / 4 approximation with integers -- = (x * 0xCCCCCCCD) >> 34 -- -- Look for `Reciprocal Multiplication, a tutorial` by Douglas W. Jones for a -- more detailed explanation. ------------------------------------------------------------------------------- -- | Returns @w / 10@ fquot10 :: Word32 -> Word32 fquot10 w = word64ToWord32 ((word32ToWord64 w * 0xCCCCCCCD) `unsafeShiftR` 35) -- | Returns @w % 10@ frem10 :: Word32 -> Word32 frem10 w = w - fquot10 w * 10 -- | Returns @(w / 10, w % 10)@ fquotRem10 :: Word32 -> (Word32, Word32) fquotRem10 w = let w' = fquot10 w in (w', w - fquot10 w * 10) -- | Returns @w / 100@ fquot100 :: Word32 -> Word32 fquot100 w = word64ToWord32 ((word32ToWord64 w * 0x51EB851F) `unsafeShiftR` 37) -- | Returns @(w / 10000, w % 10000)@ fquotRem10000 :: Word32 -> (Word32, Word32) fquotRem10000 w = let w' = word64ToWord32 ((word32ToWord64 w * 0xD1B71759) `unsafeShiftR` 45) in (w', w - w' * 10000) -- | Returns @w / 5@ fquot5 :: Word32 -> Word32 fquot5 w = word64ToWord32 ((word32ToWord64 w * 0xCCCCCCCD) `unsafeShiftR` 34) -- | Returns @w % 5@ frem5 :: Word32 -> Word32 frem5 w = w - fquot5 w * 5 -- | Returns @w / 10@ dquot10 :: Word64 -> Word64 dquot10 w = let !(rdx, _) = w `timesWord2` 0xCCCCCCCCCCCCCCCD in rdx `unsafeShiftR` 3 -- | Returns @w / 100@ dquot100 :: Word64 -> Word64 dquot100 w = let !(rdx, _) = (w `unsafeShiftR` 2) `timesWord2` 0x28F5C28F5C28F5C3 in rdx `unsafeShiftR` 2 -- | Returns @(w / 10000, w % 10000)@ dquotRem10000 :: Word64 -> (Word64, Word64) dquotRem10000 w = let !(rdx, _) = w `timesWord2` 0x346DC5D63886594B w' = rdx `unsafeShiftR` 11 in (w', w - w' * 10000) -- | Returns @(w / 10, w % 10)@ dquotRem10 :: Word64 -> (Word64, Word64) dquotRem10 w = let w' = dquot10 w in (w', w - w' * 10) -- | Returns @w / 5@ dquot5 :: Word64 -> Word64 dquot5 w = let !(rdx, _) = w `timesWord2` 0xCCCCCCCCCCCCCCCD in rdx `unsafeShiftR` 2 -- | Returns @w % 5@ drem5 :: Word64 -> Word64 drem5 w = w - dquot5 w * 5 -- | Returns @(w / 5, w % 5)@ dquotRem5 :: Word64 -> (Word64, Word64) dquotRem5 w = let w' = dquot5 w in (w', w - w' * 5) -- | Wrap a unboxed function on Int# into the boxed equivalent wrapped :: (Int# -> Int#) -> Int -> Int wrapped f (I# w) = I# (f w) #if WORD_SIZE_IN_BITS == 32 -- | Packs 2 32-bit system words (hi, lo) into a Word64 packWord64 :: Word# -> Word# -> Word64# packWord64 hi lo = #if defined(WORDS_BIGENDIAN) ((wordToWord64# lo) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# hi) #else ((wordToWord64# hi) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# lo) #endif -- | Unpacks a Word64 into 2 32-bit words (hi, lo) unpackWord64 :: Word64# -> (# Word#, Word# #) unpackWord64 w = #if defined(WORDS_BIGENDIAN) (# word64ToWord# w , word64ToWord# (w `uncheckedShiftRL64#` 32#) #) #else (# word64ToWord# (w `uncheckedShiftRL64#` 32#) , word64ToWord# w #) #endif -- | Adds 2 Word64's with 32-bit addition and manual carrying plusWord64 :: Word64# -> Word64# -> Word64# plusWord64 x y = let !(# x_h, x_l #) = unpackWord64 x !(# y_h, y_l #) = unpackWord64 y lo = x_l `plusWord#` y_l carry = int2Word# (lo `ltWord#` x_l) hi = x_h `plusWord#` y_h `plusWord#` carry in packWord64 hi lo #endif -- | Boxed version of `timesWord2#` for 64 bits timesWord2 :: Word64 -> Word64 -> (Word64, Word64) timesWord2 a b = let ra = raw a rb = raw b #if WORD_SIZE_IN_BITS >= 64 #if __GLASGOW_HASKELL__ < 903 !(# hi, lo #) = ra `timesWord2#` rb #else !(# hi_, lo_ #) = word64ToWord# ra `timesWord2#` word64ToWord# rb hi = wordToWord64# hi_ lo = wordToWord64# lo_ #endif #else !(# x_h, x_l #) = unpackWord64 ra !(# y_h, y_l #) = unpackWord64 rb !(# phh_h, phh_l #) = x_h `timesWord2#` y_h !(# phl_h, phl_l #) = x_h `timesWord2#` y_l !(# plh_h, plh_l #) = x_l `timesWord2#` y_h !(# pll_h, pll_l #) = x_l `timesWord2#` y_l -- x1 x0 -- X y1 y0 -- ------------- -- 00 LOW PART -- ------------- -- 00 -- 10 10 MIDDLE PART -- + 01 -- ------------- -- 01 -- + 11 11 HIGH PART -- ------------- phh = packWord64 phh_h phh_l phl = packWord64 phl_h phl_l !(# mh, ml #) = unpackWord64 (phl `plusWord64` (wordToWord64# pll_h) `plusWord64` (wordToWord64# plh_l)) hi = phh `plusWord64` (wordToWord64# mh) `plusWord64` (wordToWord64# plh_h) lo = packWord64 ml pll_l #endif in (W64# hi, W64# lo) -- | #ifdef for 64-bit word that seems to work on both 32- and 64-bit platforms type WORD64 = #if WORD_SIZE_IN_BITS < 64 || __GLASGOW_HASKELL__ >= 903 Word64# #else Word# #endif -- | Returns the number of times @w@ is divisible by @5@ pow5_factor :: WORD64 -> Int# -> Int# pow5_factor w count = let !(W64# q, W64# r) = dquotRem5 (W64# w) #if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 in case r `eqWord#` 0## of #else in case r `eqWord64#` wordToWord64# 0## of #endif 0# -> count _ -> pow5_factor q (count +# 1#) -- | Returns @True@ if value is divisible by @5^p@ 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@ multipleOfPowerOf2 :: Mantissa a => a -> Int -> Bool multipleOfPowerOf2 value p = (value .&. mask p) == 0 -- | Wrapper for polymorphic handling of 32- and 64-bit floats class (FiniteBits a, Integral a) => Mantissa a where -- NB: might truncate! -- Use this when we know the value fits in 32-bits unsafeRaw :: a -> Word# raw :: a -> WORD64 decimalLength :: a -> Int boolToWord :: Bool -> a quotRem10 :: a -> (a, a) quot10 :: a -> a quot100 :: a -> a quotRem100 :: a -> (a, a) quotRem10000 :: a -> (a, a) instance Mantissa Word32 where #if __GLASGOW_HASKELL__ >= 902 unsafeRaw (W32# w) = word32ToWord# w #else unsafeRaw (W32# w) = w #endif #if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 raw = unsafeRaw #else raw w = wordToWord64# (unsafeRaw w) #endif decimalLength = decimalLength9 boolToWord = boolToWord32 {-# INLINE quotRem10 #-} quotRem10 = fquotRem10 {-# INLINE quot10 #-} quot10 = fquot10 {-# INLINE quot100 #-} quot100 = fquot100 quotRem100 w = let w' = fquot100 w in (w', (w - w' * 100)) quotRem10000 = fquotRem10000 instance Mantissa Word64 where #if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903 unsafeRaw (W64# w) = w #else unsafeRaw (W64# w) = word64ToWord# w #endif raw (W64# w) = w decimalLength = decimalLength17 boolToWord = boolToWord64 {-# INLINE quotRem10 #-} quotRem10 = dquotRem10 {-# INLINE quot10 #-} quot10 = dquot10 {-# INLINE quot100 #-} quot100 = dquot100 quotRem100 w = let w' = dquot100 w in (w', (w - w' * 100)) quotRem10000 = dquotRem10000 -- | Bookkeeping state for finding the shortest, correctly-rounded -- representation. The same trimming algorithm is similar enough for 32- and -- 64-bit floats data BoundsState a = BoundsState { vu :: !a , vv :: !a , vw :: !a , lastRemovedDigit :: !a , vuIsTrailingZeros :: !Bool , vvIsTrailingZeros :: !Bool } -- | Trim digits and update bookkeeping state when the table-computed -- step results in trailing zeros (the general case, happens rarely) -- -- NB: This function isn't actually necessary so long as acceptBounds is always -- @False@ since we don't do anything different with the trailing-zero -- information directly: -- - vuIsTrailingZeros is always False. We can see this by noting that in all -- 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) 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 -- set `{ lastRemovedDigit = 4 }` to round-even then d'' else d'' trimTrailing' !d | 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 } | otherwise = (d, 0) where !(vv', vvRem) = quotRem10 $ vv d !(vu', vuRem) = quotRem10 $ vu d !(vw', _ ) = quotRem10 $ vw d trimTrailing'' !d | vuRem == 0 = fmap ((+) 1) . trimTrailing'' $ d { vu = vu' , vv = vv' , vw = vw' , lastRemovedDigit = vvRem , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0 } | otherwise = (d, 0) where !(vu', vuRem) = quotRem10 $ vu d !(vv', vvRem) = quotRem10 $ vv d !(vw', _ ) = quotRem10 $ vw d -- | Trim digits and update bookkeeping state when the table-computed -- step results has no trailing zeros (common case) trimNoTrailing :: Mantissa a => BoundsState a -> (BoundsState a, Int32) trimNoTrailing !(BoundsState u v w ld _ _) = (BoundsState ru' rv' 0 ld' False False, c) where !(ru', rv', ld', c) = trimNoTrailing' u v w ld 0 trimNoTrailing' u' v' w' lastRemoved count -- Loop iterations below (approximately), without div 100 optimization: -- 0: 0.03%, 1: 13.8%, 2: 70.6%, 3: 14.0%, 4: 1.40%, 5: 0.14%, 6+: 0.02% -- Loop iterations below (approximately), with div 100 optimization: -- 0: 70.6%, 1: 27.8%, 2: 1.40%, 3: 0.14%, 4+: 0.02% | vw' > vu' = trimNoTrailing'' vu' vv' vw' (quot10 (v' - (vv' * 100))) (count + 2) | otherwise = trimNoTrailing'' u' v' w' lastRemoved count where !vw' = quot100 w' !vu' = quot100 u' !vv' = quot100 v' trimNoTrailing'' u' v' w' lastRemoved count | vw' > vu' = trimNoTrailing' vu' vv' vw' lastRemoved' (count + 1) | otherwise = (u', v', lastRemoved, count) where !(vv', lastRemoved') = quotRem10 v' !vu' = quot10 u' !vw' = quot10 w' -- | Returns the correctly rounded decimal representation mantissa based on if -- we need to round up (next decimal place >= 5) or if we are outside the -- bounds {-# INLINE closestCorrectlyRounded #-} closestCorrectlyRounded :: Mantissa a => Bool -> BoundsState a -> a closestCorrectlyRounded acceptBound s = vv s + boolToWord roundUp where outsideBounds = not (vuIsTrailingZeros s) || not acceptBound roundUp = (vv s == vu s && outsideBounds) || lastRemovedDigit s >= 5 -- Wrappe around int2Word# asciiRaw :: Int -> Word# asciiRaw (I# i) = int2Word# i asciiZero :: Int asciiZero = ord '0' asciiDot :: Int 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 data Addr = Addr Addr# -- | Index into the 64-bit word lookup table provided {-# INLINE getWord64At #-} getWord64At :: Addr# -> Int -> Word64 getWord64At arr (I# i) = #if defined(WORDS_BIGENDIAN) W64# (byteSwap64# (indexWord64OffAddr# arr i)) #else W64# (indexWord64OffAddr# arr i) #endif -- | Index into the 128-bit word lookup table provided -- Return (# high-64-bits , low-64-bits #) -- NB: really just swaps the bytes and doesn't reorder the words {-# INLINE getWord128At #-} getWord128At :: Addr# -> Int -> (Word64, Word64) getWord128At arr (I# i) = #if defined(WORDS_BIGENDIAN) ( W64# (byteSwap64# (indexWord64OffAddr# arr (i *# 2# +# 1#))) , W64# (byteSwap64# (indexWord64OffAddr# arr (i *# 2#))) ) #else ( W64# (indexWord64OffAddr# arr (i *# 2# +# 1#)) , W64# (indexWord64OffAddr# arr (i *# 2#)) ) #endif data ByteArray = ByteArray ByteArray# -- | Packs 2 bytes [lsb, msb] into 16-bit word packWord16 :: Word# -> Word# -> Word# packWord16 l h = #if defined(WORDS_BIGENDIAN) (h `uncheckedShiftL#` 8#) `or#` l #else (l `uncheckedShiftL#` 8#) `or#` h #endif -- | Unpacks a 16-bit word into 2 bytes [lsb, msb] unpackWord16 :: Word# -> (# Word#, Word# #) unpackWord16 w = #if defined(WORDS_BIGENDIAN) (# w `and#` 0xff##, w `uncheckedShiftRL#` 8# #) #else (# w `uncheckedShiftRL#` 8#, w `and#` 0xff## #) #endif -- | ByteArray of 2-digit pairs 00..99 for faster ascii rendering digit_table :: ByteArray digit_table = runST (ST $ \s1 -> let !(# s2, marr #) = newByteArray# 200# s1 go y r = \i s -> let !(h, l) = fquotRem10 y e' = packWord16 (toAscii (unsafeRaw l)) (toAscii (unsafeRaw h)) #if __GLASGOW_HASKELL__ >= 902 s' = writeWord16Array# marr i (wordToWord16# e') s #else s' = writeWord16Array# marr i e' s #endif in if isTrue# (i ==# 99#) then s' else r (i +# 1#) s' !(# s3, bs #) = unsafeFreezeByteArray# marr (foldr go (\_ s -> s) [0..99] 0# s2) in (# s3, ByteArray bs #)) -- | Unsafe index a ByteArray for the 16-bit word at the index unsafeAt :: ByteArray -> Int# -> Word# unsafeAt (ByteArray bs) i = #if __GLASGOW_HASKELL__ >= 902 word16ToWord# (indexWord16Array# bs i) #else indexWord16Array# bs i #endif -- | Write a 16-bit word into the given address copyWord16 :: Word# -> Addr# -> State# d -> State# d copyWord16 w a s = #if __GLASGOW_HASKELL__ >= 902 writeWord16OffAddr# a 0# (wordToWord16# w) s #else writeWord16OffAddr# a 0# w s #endif -- | Write an 8-bit word into the given address poke :: Addr# -> Word# -> State# d -> State# d poke a w s = #if __GLASGOW_HASKELL__ >= 902 writeWord8OffAddr# a 0# (wordToWord8# w) s #else writeWord8OffAddr# a 0# w s #endif -- | Write the mantissa into the given address. This function attempts to -- optimize this by writing pairs of digits simultaneously when the mantissa is -- large enough {-# SPECIALIZE writeMantissa :: Addr# -> Int# -> Word32 -> State# d -> (# Addr#, State# d #) #-} {-# SPECIALIZE writeMantissa :: Addr# -> Int# -> Word64 -> State# d -> (# Addr#, State# d #) #-} writeMantissa :: forall a d. (Mantissa a) => Addr# -> Int# -> a -> State# d -> (# Addr#, State# d #) writeMantissa ptr olength = go (ptr `plusAddr#` olength) where go p mantissa s1 | mantissa >= 10000 = let !(m', c) = quotRem10000 mantissa !(c1, c0) = quotRem100 c s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c0)) (p `plusAddr#` (-1#)) s1 s3 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c1)) (p `plusAddr#` (-3#)) s2 in go (p `plusAddr#` (-4#)) m' s3 | mantissa >= 100 = let !(m', c) = quotRem100 mantissa s2 = copyWord16 (digit_table `unsafeAt` word2Int# (unsafeRaw c)) (p `plusAddr#` (-1#)) s1 in finalize m' s2 | otherwise = finalize mantissa s1 finalize mantissa s1 | mantissa >= 10 = let !bs = digit_table `unsafeAt` word2Int# (unsafeRaw mantissa) !(# lsb, msb #) = unpackWord16 bs s2 = poke (ptr `plusAddr#` 2#) lsb s1 s3 = poke (ptr `plusAddr#` 1#) (asciiRaw asciiDot) s2 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 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 in (# ptr `plusAddr#` 3#, s4 #) -- | Write the exponent into the given address. writeExponent :: Addr# -> Int32 -> State# d -> (# Addr#, State# d #) 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 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 in (# ptr `plusAddr#` 1#, s2 #) where !(I# e) = int32ToInt expo -- | Write the sign into the given address. writeSign :: Addr# -> Bool -> State# d -> (# Addr#, State# d #) writeSign ptr True s1 = let s2 = poke ptr (asciiRaw asciiMinus) s1 in (# ptr `plusAddr#` 1#, s2 #) 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 let !olength@(I# ol) = decimalLength mantissa !expo' = expo + intToInt32 olength - 1 return $ runST (ST $ \s1 -> let !(# p1, s2 #) = writeSign p0 sign s1 !(# p2, s3 #) = writeMantissa p1 ol mantissa s2 s4 = poke p2 (asciiRaw ascii_e) s3 !(# p3, s5 #) = writeSign (p2 `plusAddr#` 1#) (expo' < 0) s4 !(# p4, s6 #) = writeExponent p3 (abs expo') s5 in (# s6, (Ptr p4) #))