Skip to content

Commit

Permalink
Use manual strictness
Browse files Browse the repository at this point in the history 
- Strict extension is from ghc >= 8.0.1
  • Loading branch information
@la-wu
la-wu committed Feb 22, 2021
1 parent 2c9dda8 commit 567e8a6
Show file tree
Hide file tree
Showing 3 changed files with 74 additions and 77 deletions.
65 changes: 32 additions & 33 deletions Data/ByteString/Builder/RealFloat/D2S.hs
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}

module Data.ByteString.Builder.RealFloat.D2S
Expand Down Expand Up @@ -103,21 +102,21 @@ mulPow5InvDivPow2 m q j = mulShift64Unboxed m (get_double_pow5_inv_split (word2I


acceptBounds :: Word64 -> Bool
acceptBounds (W64# v) = boxToBool (acceptBoundsUnboxed v)
acceptBounds !(W64# v) = boxToBool (acceptBoundsUnboxed v)

data BoundsState = BoundsState
{ vu :: Word64
, vv :: Word64
, vw :: Word64
, lastRemovedDigit :: Word64
, vuIsTrailingZeros :: Bool
, vvIsTrailingZeros :: Bool
{ vu :: !Word64
, vv :: !Word64
, vw :: !Word64
, lastRemovedDigit :: !Word64
, vuIsTrailingZeros :: !Bool
, vvIsTrailingZeros :: !Bool
} deriving Show

trimTrailing' :: BoundsState -> (BoundsState, Int32)
trimTrailing' d
trimTrailing' !d
| vw' > vu' =
let (vv', vvRem) = dquotRem10Boxed $ vv d
let !(vv', vvRem) = dquotRem10Boxed $ vv d
in fmap ((+) 1) . trimTrailing' $
d { vu = vu'
, vv = vv'
Expand All @@ -128,14 +127,14 @@ trimTrailing' d
}
| otherwise = (d, 0)
where
(vu', vuRem) = dquotRem10Boxed $ vu d
vw' = dwrapped dquot10 (vw d)
!(vu', vuRem) = dquotRem10Boxed $ vu d
!vw' = dwrapped dquot10 (vw d)

trimTrailing'' :: BoundsState -> (BoundsState, Int32)
trimTrailing'' d
| vuRem == 0 =
let (vv', vvRem) = dquotRem10Boxed $ vv d
vw' = dwrapped dquot10 (vw d)
let !(vv', vvRem) = dquotRem10Boxed $ vv d
!vw' = dwrapped dquot10 (vw d)
in fmap ((+) 1) . trimTrailing'' $
d { vu = vu'
, vv = vv'
Expand All @@ -145,12 +144,12 @@ trimTrailing'' d
}
| otherwise = (d, 0)
where
(vu', vuRem) = dquotRem10Boxed $ vu d
!(vu', vuRem) = dquotRem10Boxed $ vu d

trimTrailing :: BoundsState -> (BoundsState, Int32)
trimTrailing d =
let (d', r) = trimTrailing' d
(d'', r') = if vuIsTrailingZeros d'
let !(d', r) = trimTrailing' d
!(d'', r') = if vuIsTrailingZeros d'
then trimTrailing'' d'
else (d', 0)
res = if vvIsTrailingZeros d'' && lastRemovedDigit d'' == 5 && vv d'' `rem` 2 == 0
Expand All @@ -166,25 +165,25 @@ trimNoTrailing'' u' v' w' lastRemoved count =
in trimNoTrailing' vu' vv' vw' ld (count +# 1#)
0# -> (# u', v', lastRemoved , count #)
where
vu' = dquot10 u'
vw' = dquot10 w'
!vu' = dquot10 u'
!vw' = dquot10 w'

trimNoTrailing' :: Word# -> Word# -> Word# -> Word# -> Int# -> (# Word#, Word#, Word#, Int# #)
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%
let vw' = dquot100 w'
vu' = dquot100 u'
let !vw' = dquot100 w'
!vu' = dquot100 u'
in case vw' `gtWord#` vu' of
1# -> let vv' = dquot100 v'
ld = dquot10 (v' `minusWord#` (vv' `timesWord#` 100##))
1# -> let !vv' = dquot100 v'
!ld = dquot10 (v' `minusWord#` (vv' `timesWord#` 100##))
in trimNoTrailing'' vu' vv' vw' ld (count +# 2#)
0# -> trimNoTrailing'' u' v' w' lastRemoved count

trimNoTrailing :: BoundsState -> (BoundsState, Int32)
trimNoTrailing (BoundsState (W64# u' ) (W64# v') (W64# w') (W64# ld) _ _) =
trimNoTrailing !(BoundsState (W64# u' ) (W64# v') (W64# w') (W64# ld) _ _) =
let !(# vu', vv', ld', c' #) = trimNoTrailing' u' v' w' ld 0#
in (BoundsState (W64# vu') (W64# vv') 0 (W64# ld') False False, I32# c')

Expand Down Expand Up @@ -240,31 +239,31 @@ calculate b s = vv s + asWord (roundUp b s)

d2d :: Word64 -> Word32 -> FloatingDecimal
d2d m e =
let mf = if e == 0
let !mf = if e == 0
then m
else (1 .<< double_mantissa_bits) .|. m
ef = if e == 0
!ef = if e == 0
then toS 1 - toS double_bias - toS double_mantissa_bits
else fromIntegral e - toS double_bias - toS double_mantissa_bits
e2 = fromIntegral ef - 2 :: Int32
!e2 = fromIntegral ef - 2 :: Int32
-- Step 2. 3-tuple (u, v, w) * 2**e2
u = 4 * mf - 1 - asWord (m /= 0 || e <= 1)
v = 4 * mf
w = 4 * mf + 2
!u = 4 * mf - 1 - asWord (m /= 0 || e <= 1)
!v = 4 * mf
!w = 4 * mf + 2
-- Step 3. convert to decimal power base
(state, e10) =
!(state, e10) =
if e2 >= 0
then d2dGT e2 u v w
else d2dLT e2 u v w
-- Step 4: Find the shortest decimal representation in the interval of
-- valid representations.
(output, removed) =
!(output, removed) =
if vvIsTrailingZeros state || vuIsTrailingZeros state
then pmap (\s -> calculate (not (acceptBounds v)
|| not (vuIsTrailingZeros s)) s)
$ trimTrailing state
else pmap (calculate True) $ trimNoTrailing state
e' = e10 + removed
!e' = e10 + removed
in FloatingDecimal output e'

breakdown :: Double -> (Bool, Word64, Word64)
Expand Down
59 changes: 29 additions & 30 deletions Data/ByteString/Builder/RealFloat/F2S.hs
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}

module Data.ByteString.Builder.RealFloat.F2S
Expand Down Expand Up @@ -70,21 +69,21 @@ mulPow5DivPow2 :: Word# -> Int# -> Int# -> Word#
mulPow5DivPow2 m i j = mulShift32Unboxed m (get_float_pow5_split i) j

acceptBounds :: Word32 -> Bool
acceptBounds (W32# v) = boxToBool (acceptBoundsUnboxed v)
acceptBounds !(W32# v) = boxToBool (acceptBoundsUnboxed v)

data BoundsState = BoundsState
{ vu :: Word32
, vv :: Word32
, vw :: Word32
, lastRemovedDigit :: Word32
, vuIsTrailingZeros :: Bool
, vvIsTrailingZeros :: Bool
{ vu :: !Word32
, vv :: !Word32
, vw :: !Word32
, lastRemovedDigit :: !Word32
, vuIsTrailingZeros :: !Bool
, vvIsTrailingZeros :: !Bool
}

trimTrailing' :: BoundsState -> (BoundsState, Int32)
trimTrailing' d
trimTrailing' !d
| vw' > vu' =
let (vv', vvRem) = fquotRem10Boxed $ vv d
let !(vv', vvRem) = fquotRem10Boxed $ vv d
in fmap ((+) 1) . trimTrailing' $
d { vu = vu'
, vv = vv'
Expand All @@ -99,10 +98,10 @@ trimTrailing' d
vw' = fwrapped fquot10 (vw d)

trimTrailing'' :: BoundsState -> (BoundsState, Int32)
trimTrailing'' d
trimTrailing'' !d
| vuRem == 0 =
let (vv', vvRem) = fquotRem10Boxed $ vv d
vw' = fwrapped fquot10 (vw d)
let !(vv', vvRem) = fquotRem10Boxed $ vv d
!vw' = fwrapped fquot10 (vw d)
in fmap ((+) 1) . trimTrailing'' $
d { vu = vu'
, vv = vv'
Expand All @@ -115,9 +114,9 @@ trimTrailing'' d
(vu', vuRem) = fquotRem10Boxed $ vu d

trimTrailing :: BoundsState -> (BoundsState, Int32)
trimTrailing d =
let (d', r) = trimTrailing' d
(d'', r') = if vuIsTrailingZeros d'
trimTrailing !d =
let !(d', r) = trimTrailing' d
!(d'', r') = if vuIsTrailingZeros d'
then trimTrailing'' d'
else (d', 0)
res = if vvIsTrailingZeros d'' && lastRemovedDigit d'' == 5 && vv d'' `rem` 2 == 0
Expand All @@ -133,11 +132,11 @@ trimNoTrailing' u' v' w' lastRemoved count =
in trimNoTrailing' vu' vv' vw' ld (count +# 1#)
0# -> (# u', v', lastRemoved , count #)
where
vu' = fquot10 u'
vw' = fquot10 w'
!vu' = fquot10 u'
!vw' = fquot10 w'

trimNoTrailing :: BoundsState -> (BoundsState, Int32)
trimNoTrailing (BoundsState (W32# u') (W32# v') (W32# w') (W32# ld) _ _) =
trimNoTrailing !(BoundsState (W32# u') (W32# v') (W32# w') (W32# ld) _ _) =
let !(# vu', vv', ld', c' #) = trimNoTrailing' u' v' w' ld 0#
in (BoundsState (W32# vu') (W32# vv') 0 (W32# ld') False False, I32# c')

Expand All @@ -150,7 +149,7 @@ f2dGT (I32# e2) (W32# u) (W32# v) (W32# w) =
u' = mulPow5InvDivPow2 u q i
v' = mulPow5InvDivPow2 v q i
w' = mulPow5InvDivPow2 w q i
lastRemoved =
!lastRemoved =
case (q `neWord#` 0##) `andI#` ((fquot10 (w' `minusWord#` 1##)) `leWord#` fquot10 u') of
-- We need to know one removed digit even if we are not going to loop
-- below. We could use q = X - 1 above, except that would require 33
Expand Down Expand Up @@ -181,7 +180,7 @@ f2dLT (I32# e2) (W32# u) (W32# v) (W32# w) =
u' = mulPow5DivPow2 u i j
v' = mulPow5DivPow2 v i j
w' = mulPow5DivPow2 w i j
lastRemoved =
!lastRemoved =
case (q `neWord#` 0##) `andI#` ((fquot10 (u'`minusWord#` 1##)) `leWord#` fquot10 u') of
1# -> let j' = word2Int# q -# 1# -# (pow5bitsUnboxed (i +# 1#) -# unbox float_pow5_bitcount)
in frem10 (mulPow5DivPow2 v (i +# 1#) j')
Expand All @@ -206,31 +205,31 @@ calculate b s = vv s + asWord (roundUp b s)

f2d :: Word32 -> Word32 -> FloatingDecimal
f2d m e =
let mf = if e == 0
let !mf = if e == 0
then m
else (1 .<< float_mantissa_bits) .|. m
ef = if e == 0
!ef = if e == 0
then toS 1 - toS (float_bias + float_mantissa_bits)
else toS e - toS (float_bias + float_mantissa_bits)
e2 = ef - 2
!e2 = ef - 2
-- Step 2. 3-tuple (u, v, w) * 2**e2
u = 4 * mf - 1 - asWord (m /= 0 || e <= 1)
v = 4 * mf
w = 4 * mf + 2
!u = 4 * mf - 1 - asWord (m /= 0 || e <= 1)
!v = 4 * mf
!w = 4 * mf + 2
-- Step 3. convert to decimal power base
(state, e10) =
!(state, e10) =
if e2 >= 0
then f2dGT e2 u v w
else f2dLT e2 u v w
-- Step 4: Find the shortest decimal representation in the interval of
-- valid representations.
(output, removed) =
!(output, removed) =
if vvIsTrailingZeros state || vuIsTrailingZeros state
then pmap (\s -> calculate (not (acceptBounds v)
|| not (vuIsTrailingZeros s)) s)
$ trimTrailing state
else pmap (calculate True) $ trimNoTrailing state
e' = e10 + removed
!e' = e10 + removed
in FloatingDecimal output e'

breakdown :: Float -> (Bool, Word32, Word32)
Expand Down
27 changes: 13 additions & 14 deletions Data/ByteString/Builder/RealFloat/Internal.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}

Expand Down Expand Up @@ -189,10 +188,10 @@ acceptBoundsUnboxed _ = 0#
-- acceptBoundsUnboxed v = ((v `uncheckedShiftRL#` 2#) `and#` 1##) `eqWord#` 0##

fcoerceToWord :: Float -> Word32
fcoerceToWord x = runST (cast x)
fcoerceToWord !x = runST (cast x)

dcoerceToWord :: Double -> Word64
dcoerceToWord x = runST (cast x)
dcoerceToWord !x = runST (cast x)

{-# INLINE cast #-}
cast :: (MArray (STUArray s) a (ST s),
Expand Down Expand Up @@ -344,23 +343,23 @@ second = fromIntegral
{-# SPECIALIZE writeMantissa :: Ptr Word8 -> Int -> Word32 -> IO (Ptr Word8) #-}
{-# SPECIALIZE writeMantissa :: Ptr Word8 -> Int -> Word64 -> IO (Ptr Word8) #-}
writeMantissa :: (Mantissa a) => Ptr Word8 -> Int -> a -> IO (Ptr Word8)
writeMantissa ptr olength = go (ptr `plusPtr` olength)
writeMantissa !ptr !olength = go (ptr `plusPtr` olength)
where
go p mantissa
go !p !mantissa
| mantissa >= 10000 = do
let (m', c) = quotRem10000 mantissa
(c1, c0) = quotRem100 c
let !(m', c) = quotRem10000 mantissa
!(c1, c0) = quotRem100 c
copy (digit_table `unsafeAt` fromIntegral c0) (p `plusPtr` (-1))
copy (digit_table `unsafeAt` fromIntegral c1) (p `plusPtr` (-3))
go (p `plusPtr` (-4)) m'
| mantissa >= 100 = do
let (m', c) = quotRem100 mantissa
let !(m', c) = quotRem100 mantissa
copy (digit_table `unsafeAt` fromIntegral c) (p `plusPtr` (-1))
finalize m'
| otherwise = finalize mantissa
finalize mantissa
| mantissa >= 10 = do
let bs = digit_table `unsafeAt` fromIntegral mantissa
let !bs = digit_table `unsafeAt` fromIntegral mantissa
poke (ptr `plusPtr` 2) (first bs)
poke (ptr `plusPtr` 1) (c2w '.')
poke ptr (second bs)
Expand All @@ -375,9 +374,9 @@ writeMantissa ptr olength = go (ptr `plusPtr` olength)
return (ptr `plusPtr` 3)

writeExponent :: Ptr Word8 -> Int32 -> IO (Ptr Word8)
writeExponent ptr expo
writeExponent !ptr !expo
| expo >= 100 = do
let (e1, e0) = fquotRem10Boxed (fromIntegral expo)
let !(e1, e0) = fquotRem10Boxed (fromIntegral expo)
copy (digit_table `unsafeAt` fromIntegral e1) ptr
poke (ptr `plusPtr` 2) (toAscii e0 :: Word8)
return $ ptr `plusPtr` 3
Expand All @@ -398,9 +397,9 @@ writeSign ptr False = return ptr
{-# 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 $ \_ p0 -> do
let olength = decimalLength mantissa
expo' = expo + fromIntegral olength - 1
toCharsScientific !sign !mantissa !expo = boundedPrim maxEncodedLength $ \_ !p0 -> do
let !olength = decimalLength mantissa
!expo' = expo + fromIntegral olength - 1
p1 <- writeSign p0 sign
p2 <- writeMantissa p1 olength mantissa
poke p2 (c2w 'e')
Expand Down

0 comments on commit 567e8a6

Please sign in to comment.