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
, fquot10
, frem10
, fquot5
, frem5
, dquot10
, dquotRem10
, dquot5
, drem5
, dquot100
, timesWord2
, Addr(..)
, ByteArray(..)
, castDoubleToWord64
, castFloatToWord32
, getWord64At
, getWord128At
, 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 <ghcautoconf.h>
#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)
castFloatToWord32 :: Float -> Word32
castFloatToWord32 x = unsafePerformIO (with x (peek . castPtr))
castDoubleToWord64 :: Double -> Word64
castDoubleToWord64 x = unsafePerformIO (with x (peek . castPtr))
#endif
mask :: (Bits a, Integral a) => Int -> a
mask = flip () 1 . unsafeShiftL 1
boolToWord32 :: Bool -> Word32
boolToWord32 = fromIntegral . fromEnum
boolToWord64 :: Bool -> Word64
boolToWord64 = fromIntegral . fromEnum
int32ToInt :: Int32 -> Int
int32ToInt = fromIntegral
intToInt32 :: Int -> Int32
intToInt32 = fromIntegral
word32ToInt :: Word32 -> Int
word32ToInt = fromIntegral
word64ToInt :: Word64 -> Int
word64ToInt = fromIntegral
word32ToWord64 :: Word32 -> Word64
word32ToWord64 = fromIntegral
word64ToWord32 :: Word64 -> Word32
word64ToWord32 = fromIntegral
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
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
maxEncodedLength :: Int
maxEncodedLength = 32
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)
boundString :: String -> BoundedPrim ()
boundString s = boundedPrim maxEncodedLength $ const (pokeAll s)
data NonNumbersAndZero = NonNumbersAndZero
{ negative :: Bool
, exponent_all_one :: Bool
, mantissa_non_zero :: Bool
}
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 ""
acceptBounds :: Mantissa a => a -> Bool
acceptBounds _ = False
pow5bitsUnboxed :: Int# -> Int#
pow5bitsUnboxed e = (e *# 1217359#) `uncheckedIShiftRL#` 19# +# 1#
log10pow2Unboxed :: Int# -> Int#
log10pow2Unboxed e = (e *# 78913#) `uncheckedIShiftRL#` 18#
log10pow5Unboxed :: Int# -> Int#
log10pow5Unboxed e = (e *# 732923#) `uncheckedIShiftRL#` 20#
pow5bits, log10pow2, log10pow5 :: Int -> Int
pow5bits = wrapped pow5bitsUnboxed
log10pow2 = wrapped log10pow2Unboxed
log10pow5 = wrapped log10pow5Unboxed
fquot10 :: Word32 -> Word32
fquot10 w = word64ToWord32 ((word32ToWord64 w * 0xCCCCCCCD) `unsafeShiftR` 35)
frem10 :: Word32 -> Word32
frem10 w = w fquot10 w * 10
fquotRem10 :: Word32 -> (Word32, Word32)
fquotRem10 w =
let w' = fquot10 w
in (w', w fquot10 w * 10)
fquot100 :: Word32 -> Word32
fquot100 w = word64ToWord32 ((word32ToWord64 w * 0x51EB851F) `unsafeShiftR` 37)
fquotRem10000 :: Word32 -> (Word32, Word32)
fquotRem10000 w =
let w' = word64ToWord32 ((word32ToWord64 w * 0xD1B71759) `unsafeShiftR` 45)
in (w', w w' * 10000)
fquot5 :: Word32 -> Word32
fquot5 w = word64ToWord32 ((word32ToWord64 w * 0xCCCCCCCD) `unsafeShiftR` 34)
frem5 :: Word32 -> Word32
frem5 w = w fquot5 w * 5
dquot10 :: Word64 -> Word64
dquot10 w =
let !(rdx, _) = w `timesWord2` 0xCCCCCCCCCCCCCCCD
in rdx `unsafeShiftR` 3
dquot100 :: Word64 -> Word64
dquot100 w =
let !(rdx, _) = (w `unsafeShiftR` 2) `timesWord2` 0x28F5C28F5C28F5C3
in rdx `unsafeShiftR` 2
dquotRem10000 :: Word64 -> (Word64, Word64)
dquotRem10000 w =
let !(rdx, _) = w `timesWord2` 0x346DC5D63886594B
w' = rdx `unsafeShiftR` 11
in (w', w w' * 10000)
dquotRem10 :: Word64 -> (Word64, Word64)
dquotRem10 w =
let w' = dquot10 w
in (w', w w' * 10)
dquot5 :: Word64 -> Word64
dquot5 w =
let !(rdx, _) = w `timesWord2` 0xCCCCCCCCCCCCCCCD
in rdx `unsafeShiftR` 2
drem5 :: Word64 -> Word64
drem5 w = w dquot5 w * 5
dquotRem5 :: Word64 -> (Word64, Word64)
dquotRem5 w =
let w' = dquot5 w
in (w', w w' * 5)
wrapped :: (Int# -> Int#) -> Int -> Int
wrapped f (I# w) = I# (f w)
#if WORD_SIZE_IN_BITS == 32
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
unpackWord64 :: Word64# -> (# Word#, Word# #)
unpackWord64 w =
#if defined(WORDS_BIGENDIAN)
(# word64ToWord# w
, word64ToWord# (w `uncheckedShiftRL64#` 32#)
#)
#else
(# word64ToWord# (w `uncheckedShiftRL64#` 32#)
, word64ToWord# w
#)
#endif
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
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
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)
type WORD64 =
#if WORD_SIZE_IN_BITS < 64 || __GLASGOW_HASKELL__ >= 903
Word64#
#else
Word#
#endif
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#)
multipleOfPowerOf5 :: Mantissa a => a -> Int -> Bool
multipleOfPowerOf5 value (I# p) = isTrue# (pow5_factor (raw value) 0# >=# p)
multipleOfPowerOf2 :: Mantissa a => a -> Int -> Bool
multipleOfPowerOf2 value p = (value .&. mask p) == 0
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
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
quotRem10 = fquotRem10
quot10 = fquot10
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
quotRem10 = dquotRem10
quot10 = dquot10
quot100 = dquot100
quotRem100 w =
let w' = dquot100 w
in (w', (w w' * 100))
quotRem10000 = dquotRem10000
data BoundsState a = BoundsState
{ vu :: !a
, vv :: !a
, vw :: !a
, lastRemovedDigit :: !a
, vuIsTrailingZeros :: !Bool
, vvIsTrailingZeros :: !Bool
}
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
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
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
| 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'
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
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'
toAscii :: Word# -> Word#
toAscii a = a `plusWord#` asciiRaw asciiZero
data Addr = Addr Addr#
getWord64At :: Addr# -> Int -> Word64
getWord64At arr (I# i) =
#if defined(WORDS_BIGENDIAN)
W64# (byteSwap64# (indexWord64OffAddr# arr i))
#else
W64# (indexWord64OffAddr# arr i)
#endif
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#
packWord16 :: Word# -> Word# -> Word#
packWord16 l h =
#if defined(WORDS_BIGENDIAN)
(h `uncheckedShiftL#` 8#) `or#` l
#else
(l `uncheckedShiftL#` 8#) `or#` h
#endif
unpackWord16 :: Word# -> (# Word#, Word# #)
unpackWord16 w =
#if defined(WORDS_BIGENDIAN)
(# w `and#` 0xff##, w `uncheckedShiftRL#` 8# #)
#else
(# w `uncheckedShiftRL#` 8#, w `and#` 0xff## #)
#endif
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 #))
unsafeAt :: ByteArray -> Int# -> Word#
unsafeAt (ByteArray bs) i =
#if __GLASGOW_HASKELL__ >= 902
word16ToWord# (indexWord16Array# bs i)
#else
indexWord16Array# bs i
#endif
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
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
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 #)
writeExponent :: Addr# -> Int32 -> State# d -> (# Addr#, State# d #)
writeExponent ptr !expo s1
| expo >= 100 =
let !(e1, e0) = fquotRem10 (fromIntegral expo)
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
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 #)
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) #))