{-# 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
    , 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.ByteString.Utils.ByteOrder
import Data.ByteString.Utils.UnalignedAccess
#if PURE_HASKELL
import qualified Data.ByteString.Internal.Pure as Pure
#else
import Foreign.C.Types
#endif
import Data.Char (ord)
import GHC.Int (Int(..), Int32(..))
import GHC.IO (IO(..), unIO)
import GHC.Prim
import GHC.Ptr (Ptr(..), plusPtr, castPtr)
import GHC.Types (isTrue#)
import GHC.Word (Word8, Word16(..), 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

import Data.ByteString.Builder.Prim.Internal.Floating
  (castFloatToWord32, castDoubleToWord64)

-- | Build a full bit-mask of specified length.
--
-- e.g
--
-- > showHex (mask 12) [] = "fff"
{-# INLINABLE mask #-}
mask :: (Bits a, Integral a) => Int -> a
mask :: forall a. (Bits a, Integral a) => Int -> a
mask = (a -> a -> a) -> a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (-) a
1 (a -> a) -> (Int -> a) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftL a
1

-- | Convert boolean false to 0 and true to 1
{-# INLINABLE boolToWord32 #-}
boolToWord32 :: Bool -> Word32
boolToWord32 :: Bool -> Word32
boolToWord32 = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> (Bool -> Int) -> Bool -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum

-- | Convert boolean false to 0 and true to 1
{-# INLINABLE boolToWord64 #-}
boolToWord64 :: Bool -> Word64
boolToWord64 :: Bool -> Word64
boolToWord64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (Bool -> Int) -> Bool -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum

-- | Monomorphic conversion for @Int32 -> Int@
{-# INLINABLE int32ToInt #-}
int32ToInt :: Int32 -> Int
int32ToInt :: Int32 -> Int
int32ToInt = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Monomorphic conversion for @Int -> Int32@
{-# INLINABLE intToInt32 #-}
intToInt32 :: Int -> Int32
intToInt32 :: Int -> Int32
intToInt32 = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Monomorphic conversion for @Word32 -> Int@
{-# INLINABLE word32ToInt #-}
word32ToInt :: Word32 -> Int
word32ToInt :: Word32 -> Int
word32ToInt = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Monomorphic conversion for @Word64 -> Int@
{-# INLINABLE word64ToInt #-}
word64ToInt :: Word64 -> Int
word64ToInt :: Word64 -> Int
word64ToInt = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Monomorphic conversion for @Word32 -> Word64@
{-# INLINABLE word32ToWord64 #-}
word32ToWord64 :: Word32 -> Word64
word32ToWord64 :: Word32 -> Word64
word32ToWord64 = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Monomorphic conversion for @Word64 -> Word32@
{-# INLINABLE word64ToWord32 #-}
word64ToWord32 :: Word64 -> Word32
word64ToWord32 :: Word64 -> Word32
word64ToWord32 = Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral


-- | Returns the number of decimal digits in v, which must not contain more than 9 digits.
decimalLength9 :: Word32 -> Int
decimalLength9 :: Word32 -> Int
decimalLength9 Word32
v
  | Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
100000000 = Int
9
  | Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
10000000 = Int
8
  | Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
1000000 = Int
7
  | Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
100000 = Int
6
  | Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
10000 = Int
5
  | Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
1000 = Int
4
  | Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
100 = Int
3
  | Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
10 = Int
2
  | Bool
otherwise = Int
1

-- | Returns the number of decimal digits in v, which must not contain more than 17 digits.
decimalLength17 :: Word64 -> Int
decimalLength17 :: Word64 -> Int
decimalLength17 Word64
v
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
10000000000000000 = Int
17
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1000000000000000 = Int
16
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
100000000000000 = Int
15
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
10000000000000 = Int
14
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1000000000000 = Int
13
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
100000000000 = Int
12
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
10000000000 = Int
11
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1000000000 = Int
10
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
100000000 = Int
9
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
10000000 = Int
8
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1000000 = Int
7
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
100000 = Int
6
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
10000 = Int
5
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1000 = Int
4
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
100 = Int
3
  | Word64
v Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
10 = Int
2
  | Bool
otherwise = Int
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 :: Int
maxEncodedLength = Int
32

-- | Storable.poke a String into a Ptr Word8, converting through c2w
pokeAll :: String -> Ptr Word8 -> IO (Ptr Word8)
pokeAll :: String -> Ptr Word8 -> IO (Ptr Word8)
pokeAll String
s Ptr Word8
ptr = (Ptr Word8 -> Char -> IO (Ptr Word8))
-> Ptr Word8 -> String -> IO (Ptr Word8)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Ptr Word8 -> Char -> IO (Ptr Word8)
forall {b}. Ptr Word8 -> Char -> IO (Ptr b)
pokeOne Ptr Word8
ptr String
s
  where pokeOne :: Ptr Word8 -> Char -> IO (Ptr b)
pokeOne Ptr Word8
p Char
c = Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
S.poke Ptr Word8
p (Char -> Word8
c2w Char
c) IO () -> IO (Ptr b) -> IO (Ptr b)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> IO (Ptr b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8
p Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)

-- | Unsafe creation of a bounded primitive of String at most length
-- `maxEncodedLength`
boundString :: String -> BoundedPrim ()
boundString :: String -> BoundedPrim ()
boundString String
s = Int -> (() -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim ()
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
boundedPrim Int
maxEncodedLength ((() -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim ())
-> (() -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim ()
forall a b. (a -> b) -> a -> b
$ (Ptr Word8 -> IO (Ptr Word8)) -> () -> Ptr Word8 -> IO (Ptr Word8)
forall a b. a -> b -> a
const (String -> Ptr Word8 -> IO (Ptr Word8)
pokeAll String
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
  { NonNumbersAndZero -> Bool
negative :: Bool
  , NonNumbersAndZero -> Bool
exponent_all_one :: Bool
  , NonNumbersAndZero -> Bool
mantissa_non_zero :: Bool
  }

-- | Renders NonNumbersAndZero into bounded primitive
toCharsNonNumbersAndZero :: NonNumbersAndZero -> BoundedPrim ()
toCharsNonNumbersAndZero :: NonNumbersAndZero -> BoundedPrim ()
toCharsNonNumbersAndZero NonNumbersAndZero{Bool
negative :: NonNumbersAndZero -> Bool
exponent_all_one :: NonNumbersAndZero -> Bool
mantissa_non_zero :: NonNumbersAndZero -> Bool
negative :: Bool
exponent_all_one :: Bool
mantissa_non_zero :: Bool
..}
  | Bool
mantissa_non_zero = String -> BoundedPrim ()
boundString String
"NaN"
  | Bool
exponent_all_one = String -> BoundedPrim ()
boundString (String -> BoundedPrim ()) -> String -> BoundedPrim ()
forall a b. (a -> b) -> a -> b
$ String
signStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Infinity"
  | Bool
otherwise = String -> BoundedPrim ()
boundString (String -> BoundedPrim ()) -> String -> BoundedPrim ()
forall a b. (a -> b) -> a -> b
$ String
signStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"0.0e0"
  where signStr :: String
signStr = if Bool
negative then String
"-" else String
""

-- | 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 :: forall a. Mantissa a => a -> Bool
acceptBounds a
_ = Bool
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 :: Int# -> Int#
pow5bitsUnboxed Int#
e = (Int#
e Int# -> Int# -> Int#
*# Int#
1217359#) Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
19# Int# -> Int# -> Int#
+# Int#
1#

-- | Returns floor(log_10(2^e)); requires 0 <= e <= 1650.
log10pow2Unboxed :: Int# -> Int#
log10pow2Unboxed :: Int# -> Int#
log10pow2Unboxed Int#
e = (Int#
e Int# -> Int# -> Int#
*# Int#
78913#) Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
18#

-- | Returns floor(log_10(5^e)); requires 0 <= e <= 2620.
log10pow5Unboxed :: Int# -> Int#
log10pow5Unboxed :: Int# -> Int#
log10pow5Unboxed Int#
e = (Int#
e Int# -> Int# -> Int#
*# Int#
732923#) Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
20#

-- | Boxed versions of the functions above
pow5bits, log10pow2, log10pow5 :: Int -> Int
pow5bits :: Int -> Int
pow5bits  = (Int# -> Int#) -> Int -> Int
wrapped Int# -> Int#
pow5bitsUnboxed
log10pow2 :: Int -> Int
log10pow2 = (Int# -> Int#) -> Int -> Int
wrapped Int# -> Int#
log10pow2Unboxed
log10pow5 :: Int -> Int
log10pow5 = (Int# -> Int#) -> Int -> Int
wrapped Int# -> Int#
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 :: Word32 -> Word32
fquot10 Word32
w = Word64 -> Word32
word64ToWord32 ((Word32 -> Word64
word32ToWord64 Word32
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0xCCCCCCCD) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
35)

-- | Returns @w % 10@
frem10 :: Word32 -> Word32
frem10 :: Word32 -> Word32
frem10 Word32
w = Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32 -> Word32
fquot10 Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
10

-- | Returns @(w / 10, w % 10)@
fquotRem10 :: Word32 -> (Word32, Word32)
fquotRem10 :: Word32 -> (Word32, Word32)
fquotRem10 Word32
w =
  let w' :: Word32
w' = Word32 -> Word32
fquot10 Word32
w
   in (Word32
w', Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32 -> Word32
fquot10 Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
10)

-- | Returns @w / 100@
fquot100 :: Word32 -> Word32
fquot100 :: Word32 -> Word32
fquot100 Word32
w = Word64 -> Word32
word64ToWord32 ((Word32 -> Word64
word32ToWord64 Word32
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0x51EB851F) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
37)

-- | Returns @(w / 10000, w % 10000)@
fquotRem10000 :: Word32 -> (Word32, Word32)
fquotRem10000 :: Word32 -> (Word32, Word32)
fquotRem10000 Word32
w =
  let w' :: Word32
w' = Word64 -> Word32
word64ToWord32 ((Word32 -> Word64
word32ToWord64 Word32
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0xD1B71759) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
45)
    in (Word32
w', Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
w' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
10000)

-- | Returns @w / 5@
fquot5 :: Word32 -> Word32
fquot5 :: Word32 -> Word32
fquot5 Word32
w = Word64 -> Word32
word64ToWord32 ((Word32 -> Word64
word32ToWord64 Word32
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0xCCCCCCCD) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
34)

-- | Returns @w % 5@
frem5 :: Word32 -> Word32
frem5 :: Word32 -> Word32
frem5 Word32
w = Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32 -> Word32
fquot5 Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
5

-- | Returns @w / 10@
dquot10 :: Word64 -> Word64
dquot10 :: Word64 -> Word64
dquot10 Word64
w =
  let !(Word64
rdx, Word64
_) = Word64
w Word64 -> Word64 -> (Word64, Word64)
`timesWord2` Word64
0xCCCCCCCCCCCCCCCD
    in Word64
rdx Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
3

-- | Returns @w / 100@
dquot100 :: Word64 -> Word64
dquot100 :: Word64 -> Word64
dquot100 Word64
w =
  let !(Word64
rdx, Word64
_) = (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2) Word64 -> Word64 -> (Word64, Word64)
`timesWord2` Word64
0x28F5C28F5C28F5C3
    in Word64
rdx Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2

-- | Returns @(w / 10000, w % 10000)@
dquotRem10000 :: Word64 -> (Word64, Word64)
dquotRem10000 :: Word64 -> (Word64, Word64)
dquotRem10000 Word64
w =
  let !(Word64
rdx, Word64
_) = Word64
w Word64 -> Word64 -> (Word64, Word64)
`timesWord2` Word64
0x346DC5D63886594B
      w' :: Word64
w' = Word64
rdx Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
11
   in (Word64
w', Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
w' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
10000)

-- | Returns @(w / 10, w % 10)@
dquotRem10 :: Word64 -> (Word64, Word64)
dquotRem10 :: Word64 -> (Word64, Word64)
dquotRem10 Word64
w =
  let w' :: Word64
w' = Word64 -> Word64
dquot10 Word64
w
   in (Word64
w', Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
w' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
10)

-- | Returns @w / 5@
dquot5 :: Word64 -> Word64
dquot5 :: Word64 -> Word64
dquot5 Word64
w =
  let !(Word64
rdx, Word64
_) = Word64
w Word64 -> Word64 -> (Word64, Word64)
`timesWord2` Word64
0xCCCCCCCCCCCCCCCD
    in Word64
rdx Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2

-- | Returns @w % 5@
drem5 :: Word64 -> Word64
drem5 :: Word64 -> Word64
drem5 Word64
w = Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64 -> Word64
dquot5 Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
5

-- | Returns @(w / 5, w % 5)@
dquotRem5 :: Word64 -> (Word64, Word64)
dquotRem5 :: Word64 -> (Word64, Word64)
dquotRem5 Word64
w =
  let w' :: Word64
w' = Word64 -> Word64
dquot5 Word64
w
   in (Word64
w', Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
w' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
5)

-- | Wrap a unboxed function on Int# into the boxed equivalent
wrapped :: (Int# -> Int#) -> Int -> Int
wrapped :: (Int# -> Int#) -> Int -> Int
wrapped Int# -> Int#
f (I# Int#
w) = Int# -> Int
I# (Int# -> Int#
f Int#
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 = case hostByteOrder of
  BigEndian ->
    ((wordToWord64# lo) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# hi)
  LittleEndian ->
    ((wordToWord64# hi) `uncheckedShiftL64#` 32#) `or64#` (wordToWord64# lo)

-- | Unpacks a Word64 into 2 32-bit words (hi, lo)
unpackWord64 :: Word64# -> (# Word#, Word# #)
unpackWord64 w = case hostByteOrder of
  BigEndian ->
    (# word64ToWord# w
     , word64ToWord# (w `uncheckedShiftRL64#` 32#)
     #)
  LittleEndian ->
    (# word64ToWord# (w `uncheckedShiftRL64#` 32#)
     , word64ToWord# w
     #)

-- | 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 :: Word64 -> Word64 -> (Word64, Word64)
timesWord2 Word64
a Word64
b =
  let ra :: WORD64
ra = Word64 -> WORD64
forall a. Mantissa a => a -> WORD64
raw Word64
a
      rb :: WORD64
rb = Word64 -> WORD64
forall a. Mantissa a => a -> WORD64
raw Word64
b
#if WORD_SIZE_IN_BITS >= 64
#if __GLASGOW_HASKELL__ < 903
      !(# hi, lo #) = ra `timesWord2#` rb
#else
      !(# Word#
hi_, Word#
lo_ #) = WORD64 -> Word#
word64ToWord# WORD64
ra Word# -> Word# -> (# Word#, Word# #)
`timesWord2#` WORD64 -> Word#
word64ToWord# WORD64
rb
      hi :: WORD64
hi = Word# -> WORD64
wordToWord64# Word#
hi_
      lo :: WORD64
lo = Word# -> WORD64
wordToWord64# Word#
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 (WORD64 -> Word64
W64# WORD64
hi, WORD64 -> Word64
W64# WORD64
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 :: WORD64 -> Int# -> Int#
pow5_factor WORD64
w Int#
count =
  let !(W64# WORD64
q, W64# WORD64
r) = Word64 -> (Word64, Word64)
dquotRem5 (WORD64 -> Word64
W64# WORD64
w)
#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903
   in case r `eqWord#` 0## of
#else
   in case WORD64
r WORD64 -> WORD64 -> Int#
`eqWord64#` Word# -> WORD64
wordToWord64# Word#
0## of
#endif
        Int#
0# -> Int#
count
        Int#
_  -> WORD64 -> Int# -> Int#
pow5_factor WORD64
q (Int#
count Int# -> Int# -> Int#
+# Int#
1#)

-- | Returns @True@ if value is divisible by @5^p@
multipleOfPowerOf5 :: Mantissa a => a -> Int -> Bool
multipleOfPowerOf5 :: forall a. Mantissa a => a -> Int -> Bool
multipleOfPowerOf5 a
value (I# Int#
p) = Int# -> Bool
isTrue# (WORD64 -> Int# -> Int#
pow5_factor (a -> WORD64
forall a. Mantissa a => a -> WORD64
raw a
value) Int#
0# Int# -> Int# -> Int#
>=# Int#
p)

-- | Returns @True@ if value is divisible by @2^p@
multipleOfPowerOf2 :: Mantissa a => a -> Int -> Bool
multipleOfPowerOf2 :: forall a. Mantissa a => a -> Int -> Bool
multipleOfPowerOf2 a
value Int
p = (a
value a -> a -> a
forall a. Bits a => a -> a -> a
.&. Int -> a
forall a. (Bits a, Integral a) => Int -> a
mask Int
p) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
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 :: Word32 -> Word#
unsafeRaw (W32# Word32#
w) = Word32# -> Word#
word32ToWord# Word32#
w
#else
  unsafeRaw (W32# w) = w
#endif
#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903
  raw = unsafeRaw
#else
  raw :: Word32 -> WORD64
raw Word32
w = Word# -> WORD64
wordToWord64# (Word32 -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw Word32
w)
#endif

  decimalLength :: Word32 -> Int
decimalLength = Word32 -> Int
decimalLength9
  boolToWord :: Bool -> Word32
boolToWord = Bool -> Word32
boolToWord32

  {-# INLINE quotRem10 #-}
  quotRem10 :: Word32 -> (Word32, Word32)
quotRem10 = Word32 -> (Word32, Word32)
fquotRem10

  {-# INLINE quot10 #-}
  quot10 :: Word32 -> Word32
quot10 = Word32 -> Word32
fquot10

  {-# INLINE quot100 #-}
  quot100 :: Word32 -> Word32
quot100 = Word32 -> Word32
fquot100

  quotRem100 :: Word32 -> (Word32, Word32)
quotRem100 Word32
w =
    let w' :: Word32
w' = Word32 -> Word32
fquot100 Word32
w
      in (Word32
w', (Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
w' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
100))

  quotRem10000 :: Word32 -> (Word32, Word32)
quotRem10000 = Word32 -> (Word32, Word32)
fquotRem10000

instance Mantissa Word64 where
#if WORD_SIZE_IN_BITS >= 64 && __GLASGOW_HASKELL__ < 903
  unsafeRaw (W64# w) = w
#else
  unsafeRaw :: Word64 -> Word#
unsafeRaw (W64# WORD64
w) = WORD64 -> Word#
word64ToWord# WORD64
w
#endif
  raw :: Word64 -> WORD64
raw (W64# WORD64
w) = WORD64
w

  decimalLength :: Word64 -> Int
decimalLength = Word64 -> Int
decimalLength17
  boolToWord :: Bool -> Word64
boolToWord = Bool -> Word64
boolToWord64

  {-# INLINE quotRem10 #-}
  quotRem10 :: Word64 -> (Word64, Word64)
quotRem10 = Word64 -> (Word64, Word64)
dquotRem10

  {-# INLINE quot10 #-}
  quot10 :: Word64 -> Word64
quot10 = Word64 -> Word64
dquot10

  {-# INLINE quot100 #-}
  quot100 :: Word64 -> Word64
quot100 = Word64 -> Word64
dquot100

  quotRem100 :: Word64 -> (Word64, Word64)
quotRem100 Word64
w =
    let w' :: Word64
w' = Word64 -> Word64
dquot100 Word64
w
     in (Word64
w', (Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
w' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
100))

  quotRem10000 :: Word64 -> (Word64, Word64)
quotRem10000 = Word64 -> (Word64, Word64)
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
    { forall a. BoundsState a -> a
vu :: !a
    , forall a. BoundsState a -> a
vv :: !a
    , forall a. BoundsState a -> a
vw :: !a
    , forall a. BoundsState a -> a
lastRemovedDigit :: !a
    , forall a. BoundsState a -> Bool
vuIsTrailingZeros :: !Bool
    , forall a. BoundsState a -> 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 :: forall a.
(Show a, Mantissa a) =>
BoundsState a -> (BoundsState a, Int32)
trimTrailing !BoundsState a
initial = (BoundsState a
res, Int32
r Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
r')
  where
    !(BoundsState a
d', Int32
r) = BoundsState a -> (BoundsState a, Int32)
forall {a} {b}.
(Mantissa a, Num b) =>
BoundsState a -> (BoundsState a, b)
trimTrailing' BoundsState a
initial
    !(BoundsState a
d'', Int32
r') = if BoundsState a -> Bool
forall a. BoundsState a -> Bool
vuIsTrailingZeros BoundsState a
d' then BoundsState a -> (BoundsState a, Int32)
forall {a} {b}.
(Mantissa a, Num b) =>
BoundsState a -> (BoundsState a, b)
trimTrailing'' BoundsState a
d' else (BoundsState a
d', Int32
0)
    res :: BoundsState a
res = if BoundsState a -> Bool
forall a. BoundsState a -> Bool
vvIsTrailingZeros BoundsState a
d'' Bool -> Bool -> Bool
&& BoundsState a -> a
forall a. BoundsState a -> a
lastRemovedDigit BoundsState a
d'' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
5 Bool -> Bool -> Bool
&& BoundsState a -> a
forall a. BoundsState a -> a
vv BoundsState a
d'' a -> a -> a
forall a. Integral a => a -> a -> a
`rem` a
2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
             -- set `{ lastRemovedDigit = 4 }` to round-even
             then BoundsState a
d''
             else BoundsState a
d''

    trimTrailing' :: BoundsState a -> (BoundsState a, b)
trimTrailing' !BoundsState a
d
      | a
vw' a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
vu' =
         (b -> b) -> (BoundsState a, b) -> (BoundsState a, b)
forall a b. (a -> b) -> (BoundsState a, a) -> (BoundsState a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> b -> b
forall a. Num a => a -> a -> a
(+) b
1) ((BoundsState a, b) -> (BoundsState a, b))
-> (BoundsState a -> (BoundsState a, b))
-> BoundsState a
-> (BoundsState a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundsState a -> (BoundsState a, b)
trimTrailing' (BoundsState a -> (BoundsState a, b))
-> BoundsState a -> (BoundsState a, b)
forall a b. (a -> b) -> a -> b
$
          BoundsState a
d { vu = vu'
            , vv = vv'
            , vw = vw'
            , lastRemovedDigit = vvRem
            , vuIsTrailingZeros = vuIsTrailingZeros d && vuRem == 0
            , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0
            }
      | Bool
otherwise = (BoundsState a
d, b
0)
      where
        !(a
vv', a
vvRem) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem10 (a -> (a, a)) -> a -> (a, a)
forall a b. (a -> b) -> a -> b
$ BoundsState a -> a
forall a. BoundsState a -> a
vv BoundsState a
d
        !(a
vu', a
vuRem) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem10 (a -> (a, a)) -> a -> (a, a)
forall a b. (a -> b) -> a -> b
$ BoundsState a -> a
forall a. BoundsState a -> a
vu BoundsState a
d
        !(a
vw', a
_    ) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem10 (a -> (a, a)) -> a -> (a, a)
forall a b. (a -> b) -> a -> b
$ BoundsState a -> a
forall a. BoundsState a -> a
vw BoundsState a
d

    trimTrailing'' :: BoundsState a -> (BoundsState a, b)
trimTrailing'' !BoundsState a
d
      | a
vuRem a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 =
         (b -> b) -> (BoundsState a, b) -> (BoundsState a, b)
forall a b. (a -> b) -> (BoundsState a, a) -> (BoundsState a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> b -> b
forall a. Num a => a -> a -> a
(+) b
1) ((BoundsState a, b) -> (BoundsState a, b))
-> (BoundsState a -> (BoundsState a, b))
-> BoundsState a
-> (BoundsState a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundsState a -> (BoundsState a, b)
trimTrailing'' (BoundsState a -> (BoundsState a, b))
-> BoundsState a -> (BoundsState a, b)
forall a b. (a -> b) -> a -> b
$
          BoundsState a
d { vu = vu'
            , vv = vv'
            , vw = vw'
            , lastRemovedDigit = vvRem
            , vvIsTrailingZeros = vvIsTrailingZeros d && lastRemovedDigit d == 0
            }
      | Bool
otherwise = (BoundsState a
d, b
0)
      where
        !(a
vu', a
vuRem) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem10 (a -> (a, a)) -> a -> (a, a)
forall a b. (a -> b) -> a -> b
$ BoundsState a -> a
forall a. BoundsState a -> a
vu BoundsState a
d
        !(a
vv', a
vvRem) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem10 (a -> (a, a)) -> a -> (a, a)
forall a b. (a -> b) -> a -> b
$ BoundsState a -> a
forall a. BoundsState a -> a
vv BoundsState a
d
        !(a
vw', a
_    ) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem10 (a -> (a, a)) -> a -> (a, a)
forall a b. (a -> b) -> a -> b
$ BoundsState a -> a
forall a. BoundsState a -> a
vw BoundsState a
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 :: forall a. Mantissa a => BoundsState a -> (BoundsState a, Int32)
trimNoTrailing !(BoundsState a
u a
v a
w a
ld Bool
_ Bool
_) =
  (a -> a -> a -> a -> Bool -> Bool -> BoundsState a
forall a. a -> a -> a -> a -> Bool -> Bool -> BoundsState a
BoundsState a
ru' a
rv' a
0 a
ld' Bool
False Bool
False, Int32
c)
  where
    !(a
ru', a
rv', a
ld', Int32
c) = a -> a -> a -> a -> Int32 -> (a, a, a, Int32)
forall {a} {c} {d}.
(Mantissa a, Mantissa c, Num d) =>
a -> c -> a -> c -> d -> (a, c, c, d)
trimNoTrailing' a
u a
v a
w a
ld Int32
0

    trimNoTrailing' :: a -> c -> a -> c -> d -> (a, c, c, d)
trimNoTrailing' a
u' c
v' a
w' c
lastRemoved d
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%
      | a
vw' a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
vu' =
          a -> c -> a -> c -> d -> (a, c, c, d)
trimNoTrailing'' a
vu' c
vv' a
vw' (c -> c
forall a. Mantissa a => a -> a
quot10 (c
v' c -> c -> c
forall a. Num a => a -> a -> a
- (c
vv' c -> c -> c
forall a. Num a => a -> a -> a
* c
100))) (d
count d -> d -> d
forall a. Num a => a -> a -> a
+ d
2)
      | Bool
otherwise =
          a -> c -> a -> c -> d -> (a, c, c, d)
trimNoTrailing'' a
u' c
v' a
w' c
lastRemoved d
count
      where
        !vw' :: a
vw' = a -> a
forall a. Mantissa a => a -> a
quot100 a
w'
        !vu' :: a
vu' = a -> a
forall a. Mantissa a => a -> a
quot100 a
u'
        !vv' :: c
vv' = c -> c
forall a. Mantissa a => a -> a
quot100 c
v'

    trimNoTrailing'' :: a -> c -> a -> c -> d -> (a, c, c, d)
trimNoTrailing'' a
u' c
v' a
w' c
lastRemoved d
count
      | a
vw' a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
vu' = a -> c -> a -> c -> d -> (a, c, c, d)
trimNoTrailing' a
vu' c
vv' a
vw' c
lastRemoved' (d
count d -> d -> d
forall a. Num a => a -> a -> a
+ d
1)
      | Bool
otherwise = (a
u', c
v', c
lastRemoved, d
count)
      where
        !(c
vv', c
lastRemoved') = c -> (c, c)
forall a. Mantissa a => a -> (a, a)
quotRem10 c
v'
        !vu' :: a
vu' = a -> a
forall a. Mantissa a => a -> a
quot10 a
u'
        !vw' :: a
vw' = a -> a
forall a. Mantissa a => a -> a
quot10 a
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 :: forall a. Mantissa a => Bool -> BoundsState a -> a
closestCorrectlyRounded Bool
acceptBound BoundsState a
s = BoundsState a -> a
forall a. BoundsState a -> a
vv BoundsState a
s a -> a -> a
forall a. Num a => a -> a -> a
+ Bool -> a
forall a. Mantissa a => Bool -> a
boolToWord Bool
roundUp
  where
    outsideBounds :: Bool
outsideBounds = Bool -> Bool
not (BoundsState a -> Bool
forall a. BoundsState a -> Bool
vuIsTrailingZeros BoundsState a
s) Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
acceptBound
    roundUp :: Bool
roundUp = (BoundsState a -> a
forall a. BoundsState a -> a
vv BoundsState a
s a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== BoundsState a -> a
forall a. BoundsState a -> a
vu BoundsState a
s Bool -> Bool -> Bool
&& Bool
outsideBounds) Bool -> Bool -> Bool
|| BoundsState a -> a
forall a. BoundsState a -> a
lastRemovedDigit BoundsState a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
5

-- Wrappe around int2Word#
asciiRaw :: Int -> Word#
asciiRaw :: Int -> Word#
asciiRaw (I# Int#
i) = Int# -> Word#
int2Word# Int#
i

asciiZero :: Int
asciiZero :: Int
asciiZero = Char -> Int
ord Char
'0'

asciiDot :: Int
asciiDot :: Int
asciiDot = Char -> Int
ord Char
'.'

asciiMinus :: Int
asciiMinus :: Int
asciiMinus = Char -> Int
ord Char
'-'

ascii_e :: Int
ascii_e :: Int
ascii_e = Char -> Int
ord Char
'e'

-- | Convert a single-digit number to the ascii ordinal e.g '1' -> 0x31
toAscii :: Word# -> Word#
toAscii :: Word# -> Word#
toAscii Word#
a = Word#
a Word# -> Word# -> Word#
`plusWord#` Int -> Word#
asciiRaw Int
asciiZero

-- | Index into the 64-bit word lookup table provided
{-# INLINE getWord64At #-}
getWord64At :: Ptr Word64 -> Int -> Word64
getWord64At :: Ptr Word64 -> Int -> Word64
getWord64At (Ptr Addr#
arr) (I# Int#
i) = WORD64 -> Word64
W64# (Addr# -> Int# -> WORD64
indexWord64OffAddr# Addr#
arr Int#
i)

-- | Index into the 128-bit word lookup table provided
-- Return (# high-64-bits , low-64-bits #)
--
-- NB: The lookup tables we use store the low 64 bits in
-- host-byte-order then the high 64 bits in host-byte-order
{-# INLINE getWord128At #-}
getWord128At :: Ptr Word64 -> Int -> (Word64, Word64)
getWord128At :: Ptr Word64 -> Int -> (Word64, Word64)
getWord128At (Ptr Addr#
arr) (I# Int#
i) = let
  !hi :: Word64
hi = WORD64 -> Word64
W64# (Addr# -> Int# -> WORD64
indexWord64OffAddr# Addr#
arr (Int#
i Int# -> Int# -> Int#
*# Int#
2# Int# -> Int# -> Int#
+# Int#
1#))
  !lo :: Word64
lo = WORD64 -> Word64
W64# (Addr# -> Int# -> WORD64
indexWord64OffAddr# Addr#
arr (Int#
i Int# -> Int# -> Int#
*# Int#
2#))
  in (Word64
hi, Word64
lo)

-- | Packs 2 bytes [lsb, msb] into 16-bit word
packWord16 :: Word# -> Word# -> Word#
packWord16 :: Word# -> Word# -> Word#
packWord16 Word#
l Word#
h = case ByteOrder
hostByteOrder of
  ByteOrder
BigEndian ->
    (Word#
h Word# -> Int# -> Word#
`uncheckedShiftL#` Int#
8#) Word# -> Word# -> Word#
`or#` Word#
l
  ByteOrder
LittleEndian ->
    (Word#
l Word# -> Int# -> Word#
`uncheckedShiftL#` Int#
8#) Word# -> Word# -> Word#
`or#` Word#
h

-- | Unpacks a 16-bit word into 2 bytes [lsb, msb]
unpackWord16 :: Word# -> (# Word#, Word# #)
unpackWord16 :: Word# -> (# Word#, Word# #)
unpackWord16 Word#
w = case ByteOrder
hostByteOrder of
  ByteOrder
BigEndian ->
    (# Word#
w Word# -> Word# -> Word#
`and#` Word#
0xff##, Word#
w Word# -> Int# -> Word#
`uncheckedShiftRL#` Int#
8# #)
  ByteOrder
LittleEndian ->
    (# Word#
w Word# -> Int# -> Word#
`uncheckedShiftRL#` Int#
8#, Word#
w Word# -> Word# -> Word#
`and#` Word#
0xff## #)


-- | Static array of 2-digit pairs 00..99 for faster ascii rendering
digit_table :: Ptr Word16
digit_table :: Ptr Word16
digit_table =
#if PURE_HASKELL
  castPtr Pure.digit_pairs_table
#else
  Ptr CChar -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
c_digit_pairs_table

foreign import ccall "&hs_bytestring_digit_pairs_table"
  c_digit_pairs_table :: Ptr CChar
#endif

-- | Unsafe index a static array for the 16-bit word at the index
unsafeAt :: Ptr Word16 -> Int# -> Word#
unsafeAt :: Ptr Word16 -> Int# -> Word#
unsafeAt (Ptr Addr#
a) Int#
i =
#if __GLASGOW_HASKELL__ >= 902
    Word16# -> Word#
word16ToWord# (Addr# -> Int# -> Word16#
indexWord16OffAddr# Addr#
a Int#
i)
#else
    indexWord16OffAddr# a i
#endif

-- | Write a 16-bit word into the given address
copyWord16 :: Word# -> Addr# -> State# RealWorld -> State# RealWorld
copyWord16 :: Word# -> Addr# -> State# RealWorld -> State# RealWorld
copyWord16 Word#
w Addr#
a State# RealWorld
s = let
#if __GLASGOW_HASKELL__ >= 902
  w16 :: Word16#
w16 = Word# -> Word16#
wordToWord16# Word#
w
#else
  w16 = w
#endif
  in  case IO () -> State# RealWorld -> (# State# RealWorld, () #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (Word16 -> Ptr Word8 -> IO ()
unalignedWriteU16 (Word16# -> Word16
W16# Word16#
w16) (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
a)) State# RealWorld
s of
  (# State# RealWorld
s', ()
_ #) -> State# RealWorld
s'

-- | Write an 8-bit word into the given address
poke :: Addr# -> Word# -> State# d -> State# d
poke :: forall d. Addr# -> Word# -> State# d -> State# d
poke Addr#
a Word#
w State# d
s =
#if __GLASGOW_HASKELL__ >= 902
    Addr# -> Int# -> Word8# -> State# d -> State# d
forall d. Addr# -> Int# -> Word8# -> State# d -> State# d
writeWord8OffAddr# Addr#
a Int#
0# (Word# -> Word8#
wordToWord8# Word#
w) State# d
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# RealWorld -> (# Addr#, State# RealWorld #) #-}
{-# SPECIALIZE writeMantissa :: Addr# -> Int# -> Word64 -> State# RealWorld -> (# Addr#, State# RealWorld #) #-}
writeMantissa :: forall a. (Mantissa a) => Addr# -> Int# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #)
writeMantissa :: forall a.
Mantissa a =>
Addr#
-> Int# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #)
writeMantissa Addr#
ptr Int#
olength = Addr# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #)
forall {a}.
Mantissa a =>
Addr# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #)
go (Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
olength)
  where
    go :: Addr# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #)
go Addr#
p a
mantissa State# RealWorld
s1
      | a
mantissa a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
10000 =
          let !(a
m', a
c) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem10000 a
mantissa
              !(a
c1, a
c0) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem100 a
c
              s2 :: State# RealWorld
s2 = Word# -> Addr# -> State# RealWorld -> State# RealWorld
copyWord16 (Ptr Word16
digit_table Ptr Word16 -> Int# -> Word#
`unsafeAt` Word# -> Int#
word2Int# (a -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw a
c0)) (Addr#
p Addr# -> Int# -> Addr#
`plusAddr#` (Int#
-1#)) State# RealWorld
s1
              s3 :: State# RealWorld
s3 = Word# -> Addr# -> State# RealWorld -> State# RealWorld
copyWord16 (Ptr Word16
digit_table Ptr Word16 -> Int# -> Word#
`unsafeAt` Word# -> Int#
word2Int# (a -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw a
c1)) (Addr#
p Addr# -> Int# -> Addr#
`plusAddr#` (Int#
-3#)) State# RealWorld
s2
           in Addr# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #)
go (Addr#
p Addr# -> Int# -> Addr#
`plusAddr#` (Int#
-4#)) a
m' State# RealWorld
s3
      | a
mantissa a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
100 =
          let !(a
m', a
c) = a -> (a, a)
forall a. Mantissa a => a -> (a, a)
quotRem100 a
mantissa
              s2 :: State# RealWorld
s2 = Word# -> Addr# -> State# RealWorld -> State# RealWorld
copyWord16 (Ptr Word16
digit_table Ptr Word16 -> Int# -> Word#
`unsafeAt` Word# -> Int#
word2Int# (a -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw a
c)) (Addr#
p Addr# -> Int# -> Addr#
`plusAddr#` (Int#
-1#)) State# RealWorld
s1
           in a -> State# RealWorld -> (# Addr#, State# RealWorld #)
forall {a}.
Mantissa a =>
a -> State# RealWorld -> (# Addr#, State# RealWorld #)
finalize a
m' State# RealWorld
s2
      | Bool
otherwise = a -> State# RealWorld -> (# Addr#, State# RealWorld #)
forall {a}.
Mantissa a =>
a -> State# RealWorld -> (# Addr#, State# RealWorld #)
finalize a
mantissa State# RealWorld
s1
    finalize :: a -> State# RealWorld -> (# Addr#, State# RealWorld #)
finalize a
mantissa State# RealWorld
s1
      | a
mantissa a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
10 =
        let !bs :: Word#
bs = Ptr Word16
digit_table Ptr Word16 -> Int# -> Word#
`unsafeAt` Word# -> Int#
word2Int# (a -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw a
mantissa)
            !(# Word#
lsb, Word#
msb #) = Word# -> (# Word#, Word# #)
unpackWord16 Word#
bs
            s2 :: State# RealWorld
s2 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke (Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
2#) Word#
lsb State# RealWorld
s1
            s3 :: State# RealWorld
s3 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke (Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
1#) (Int -> Word#
asciiRaw Int
asciiDot) State# RealWorld
s2
            s4 :: State# RealWorld
s4 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke Addr#
ptr Word#
msb State# RealWorld
s3
           in (# Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` (Int#
olength Int# -> Int# -> Int#
+# Int#
1#), State# RealWorld
s4 #)
      | (Int# -> Int
I# Int#
olength) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 =
          let s2 :: State# RealWorld
s2 = Word# -> Addr# -> State# RealWorld -> State# RealWorld
copyWord16 (Word# -> Word# -> Word#
packWord16 (Int -> Word#
asciiRaw Int
asciiDot) (Word# -> Word#
toAscii (a -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw a
mantissa))) Addr#
ptr State# RealWorld
s1
           in (# Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` (Int#
olength Int# -> Int# -> Int#
+# Int#
1#), State# RealWorld
s2 #)
      | Bool
otherwise =
          let s2 :: State# RealWorld
s2 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke (Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
2#) (Int -> Word#
asciiRaw Int
asciiZero) State# RealWorld
s1
              s3 :: State# RealWorld
s3 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke (Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
1#) (Int -> Word#
asciiRaw Int
asciiDot) State# RealWorld
s2
              s4 :: State# RealWorld
s4 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke Addr#
ptr (Word# -> Word#
toAscii (a -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw a
mantissa)) State# RealWorld
s3
           in (# Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
3#, State# RealWorld
s4 #)

-- | Write the exponent into the given address.
writeExponent :: Addr# -> Int32 -> State# RealWorld -> (# Addr#, State# RealWorld #)
writeExponent :: Addr# -> Int32 -> State# RealWorld -> (# Addr#, State# RealWorld #)
writeExponent Addr#
ptr !Int32
expo State# RealWorld
s1
  | Int32
expo Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
100 =
      let !(Word32
e1, Word32
e0) = Word32 -> (Word32, Word32)
fquotRem10 (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
expo) -- TODO
          s2 :: State# RealWorld
s2 = Word# -> Addr# -> State# RealWorld -> State# RealWorld
copyWord16 (Ptr Word16
digit_table Ptr Word16 -> Int# -> Word#
`unsafeAt` Word# -> Int#
word2Int# (Word32 -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw Word32
e1)) Addr#
ptr State# RealWorld
s1
          s3 :: State# RealWorld
s3 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke (Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
2#) (Word# -> Word#
toAscii (Word32 -> Word#
forall a. Mantissa a => a -> Word#
unsafeRaw Word32
e0)) State# RealWorld
s2
       in (# Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
3#, State# RealWorld
s3 #)
  | Int32
expo Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
10 =
      let s2 :: State# RealWorld
s2 = Word# -> Addr# -> State# RealWorld -> State# RealWorld
copyWord16 (Ptr Word16
digit_table Ptr Word16 -> Int# -> Word#
`unsafeAt` Int#
e) Addr#
ptr State# RealWorld
s1
       in (# Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
2#, State# RealWorld
s2 #)
  | Bool
otherwise =
      let s2 :: State# RealWorld
s2 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke Addr#
ptr (Word# -> Word#
toAscii (Int# -> Word#
int2Word# Int#
e)) State# RealWorld
s1
       in (# Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
1#, State# RealWorld
s2 #)
  where !(I# Int#
e) = Int32 -> Int
int32ToInt Int32
expo

-- | Write the sign into the given address.
writeSign :: Addr# -> Bool -> State# d -> (# Addr#, State# d #)
writeSign :: forall d. Addr# -> Bool -> State# d -> (# Addr#, State# d #)
writeSign Addr#
ptr Bool
True State# d
s1 =
  let s2 :: State# d
s2 = Addr# -> Word# -> State# d -> State# d
forall d. Addr# -> Word# -> State# d -> State# d
poke Addr#
ptr (Int -> Word#
asciiRaw Int
asciiMinus) State# d
s1
   in (# Addr#
ptr Addr# -> Int# -> Addr#
`plusAddr#` Int#
1#, State# d
s2 #)
writeSign Addr#
ptr Bool
False State# d
s = (# Addr#
ptr, State# d
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 :: forall a. Mantissa a => Bool -> a -> Int32 -> BoundedPrim ()
toCharsScientific !Bool
sign !a
mantissa !Int32
expo = Int -> (() -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim ()
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
boundedPrim Int
maxEncodedLength ((() -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim ())
-> (() -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim ()
forall a b. (a -> b) -> a -> b
$ \()
_ !(Ptr Addr#
p0)-> do
  let !olength :: Int
olength@(I# Int#
ol) = a -> Int
forall a. Mantissa a => a -> Int
decimalLength a
mantissa
      !expo' :: Int32
expo' = Int32
expo Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int -> Int32
intToInt32 Int
olength Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1
  (State# RealWorld -> (# State# RealWorld, Ptr Word8 #))
-> IO (Ptr Word8)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Ptr Word8 #))
 -> IO (Ptr Word8))
-> (State# RealWorld -> (# State# RealWorld, Ptr Word8 #))
-> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1 ->
    let !(# Addr#
p1, State# RealWorld
s2 #) = Addr# -> Bool -> State# RealWorld -> (# Addr#, State# RealWorld #)
forall d. Addr# -> Bool -> State# d -> (# Addr#, State# d #)
writeSign Addr#
p0 Bool
sign State# RealWorld
s1
        !(# Addr#
p2, State# RealWorld
s3 #) = Addr#
-> Int# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #)
forall a.
Mantissa a =>
Addr#
-> Int# -> a -> State# RealWorld -> (# Addr#, State# RealWorld #)
writeMantissa Addr#
p1 Int#
ol a
mantissa State# RealWorld
s2
        s4 :: State# RealWorld
s4 = Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
poke Addr#
p2 (Int -> Word#
asciiRaw Int
ascii_e) State# RealWorld
s3
        !(# Addr#
p3, State# RealWorld
s5 #) = Addr# -> Bool -> State# RealWorld -> (# Addr#, State# RealWorld #)
forall d. Addr# -> Bool -> State# d -> (# Addr#, State# d #)
writeSign (Addr#
p2 Addr# -> Int# -> Addr#
`plusAddr#` Int#
1#) (Int32
expo' Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
0) State# RealWorld
s4
        !(# Addr#
p4, State# RealWorld
s6 #) = Addr# -> Int32 -> State# RealWorld -> (# Addr#, State# RealWorld #)
writeExponent Addr#
p3 (Int32 -> Int32
forall a. Num a => a -> a
abs Int32
expo') State# RealWorld
s5
     in (# State# RealWorld
s6, (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
p4) #)