From 8838241f7d672a58522b902c89c9149d6197bb72 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 3 Jun 2021 11:31:49 +0200 Subject: Fix naturalToFloat/Double * move naturalToFloat/Double from ghc-bignum to base:GHC.Float and make them wired-in (as their integerToFloat/Double counterparts) * use the same rounding method as integerToFloat/Double. This is an oversight of 540fa6b2cff3802877ff56a47ab3611e33a9ac86 * add passthrough rules for intToFloat, intToDouble, wordToFloat, wordToDouble. --- compiler/GHC/Builtin/Names.hs | 16 ++++++++++---- compiler/GHC/Core/Opt/ConstantFold.hs | 34 +++++++++++++++++++++++------ libraries/base/GHC/Float.hs | 15 +++++++++++++ libraries/ghc-bignum/changelog.md | 4 ++++ libraries/ghc-bignum/ghc-bignum.cabal | 2 +- libraries/ghc-bignum/src/GHC/Num/Natural.hs | 9 -------- 6 files changed, 59 insertions(+), 21 deletions(-) diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index afad51ca70..80d5e4f48f 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -437,6 +437,8 @@ basicKnownKeyNames -- Float/Double integerToFloatName, integerToDoubleName, + naturalToFloatName, + naturalToDoubleName, rationalToFloatName, rationalToDoubleName, @@ -1367,9 +1369,13 @@ floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey -- other GHC.Float functions -integerToFloatName, integerToDoubleName, rationalToFloatName, rationalToDoubleName :: Name +integerToFloatName, integerToDoubleName, + naturalToFloatName, naturalToDoubleName, + rationalToFloatName, rationalToDoubleName :: Name integerToFloatName = varQual gHC_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey integerToDoubleName = varQual gHC_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey +naturalToFloatName = varQual gHC_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey +naturalToDoubleName = varQual gHC_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey @@ -2387,13 +2393,15 @@ coercionTokenIdKey = mkPreludeMiscIdUnique 124 noinlineIdKey = mkPreludeMiscIdUnique 125 considerAccessibleIdKey = mkPreludeMiscIdUnique 126 -integerToFloatIdKey, integerToDoubleIdKey :: Unique +integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique integerToFloatIdKey = mkPreludeMiscIdUnique 128 integerToDoubleIdKey = mkPreludeMiscIdUnique 129 +naturalToFloatIdKey = mkPreludeMiscIdUnique 130 +naturalToDoubleIdKey = mkPreludeMiscIdUnique 131 rationalToFloatIdKey, rationalToDoubleIdKey :: Unique -rationalToFloatIdKey = mkPreludeMiscIdUnique 130 -rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 +rationalToFloatIdKey = mkPreludeMiscIdUnique 132 +rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 withDictKey :: Unique withDictKey = mkPreludeMiscIdUnique 156 diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index e6cf3b1da0..14d4f840b6 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1857,11 +1857,24 @@ builtinBignumRules = , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap -- identity passthrough - , id_passthrough "Int# -> Integer -> Int#" integerToIntName integerISName - , id_passthrough "Word# -> Integer -> Word#" integerToWordName integerFromWordName - , id_passthrough "Int64# -> Integer -> Int64#" integerToInt64Name integerFromInt64Name - , id_passthrough "Word64# -> Integer -> Word64#" integerToWord64Name integerFromWord64Name - , id_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSName + , id_passthrough "Int# -> Integer -> Int#" + integerToIntName integerISName + , id_passthrough "Word# -> Integer -> Word#" + integerToWordName integerFromWordName + , id_passthrough "Int64# -> Integer -> Int64#" + integerToInt64Name integerFromInt64Name + , id_passthrough "Word64# -> Integer -> Word64#" + integerToWord64Name integerFromWord64Name + , id_passthrough "Natural -> Integer -> Natural (wrap)" + integerToNaturalName integerFromNaturalName + , id_passthrough "Natural -> Integer -> Natural (throw)" + integerToNaturalThrowName integerFromNaturalName + , id_passthrough "Natural -> Integer -> Natural (clamp)" + integerToNaturalClampName integerFromNaturalName + , id_passthrough "Word# -> Natural -> Word#" + naturalToWordName naturalNSName + , id_passthrough "Word# -> Natural -> Word# (clamp)" + naturalToWordClampName naturalNSName -- identity passthrough with a conversion that can be done directly instead , small_passthrough "Int# -> Integer -> Word#" @@ -1870,8 +1883,15 @@ builtinBignumRules = integerISName integerToFloatName (mkPrimOpId IntToFloatOp) , small_passthrough "Int# -> Integer -> Double#" integerISName integerToDoubleName (mkPrimOpId IntToDoubleOp) - , small_passthrough "Word# -> Natural -> Int#" - naturalNSName naturalToWordName (mkPrimOpId WordToIntOp) + , small_passthrough "Word# -> Integer -> Float#" + integerFromWordName integerToFloatName (mkPrimOpId WordToFloatOp) + , small_passthrough "Word# -> Integer -> Double#" + integerFromWordName integerToDoubleName (mkPrimOpId WordToDoubleOp) + + , small_passthrough "Word# -> Natural -> Float#" + naturalNSName naturalToFloatName (mkPrimOpId WordToFloatOp) + , small_passthrough "Word# -> Natural -> Double#" + naturalNSName naturalToDoubleName (mkPrimOpId WordToDoubleOp) -- Bits.bit , bignum_bit "integerBit" integerBitName mkLitInteger diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs index acca5118ab..e1dbe03010 100644 --- a/libraries/base/GHC/Float.hs +++ b/libraries/base/GHC/Float.hs @@ -309,6 +309,13 @@ integerToFloat# i@(IP _) = case integerToBinaryFloat' i of integerToFloat# (IN bn) = case integerToBinaryFloat' (IP bn) of F# x -> negateFloat# x +-- | Convert a Natural to a Float# +naturalToFloat# :: Natural -> Float# +{-# NOINLINE naturalToFloat# #-} +naturalToFloat# (NS w) = word2Float# w +naturalToFloat# (NB b) = case integerToBinaryFloat' (IP b) of + F# x -> x + -- | @since 2.01 instance Real Float where toRational (F# x#) = @@ -530,6 +537,14 @@ integerToDouble# i@(IP _) = case integerToBinaryFloat' i of integerToDouble# (IN bn) = case integerToBinaryFloat' (IP bn) of D# x -> negateDouble# x +-- | Encode a Natural (mantissa) into a Double# +naturalToDouble# :: Natural -> Double# +{-# NOINLINE naturalToDouble# #-} +naturalToDouble# (NS w) = word2Double# w +naturalToDouble# (NB b) = case integerToBinaryFloat' (IP b) of + D# x -> x + + -- | @since 2.01 instance Real Double where toRational (D# x#) = diff --git a/libraries/ghc-bignum/changelog.md b/libraries/ghc-bignum/changelog.md index 55cbef72b3..68f98d3adc 100644 --- a/libraries/ghc-bignum/changelog.md +++ b/libraries/ghc-bignum/changelog.md @@ -1,5 +1,9 @@ # Changelog for `ghc-bignum` package +## 1.2 + +- Moved naturalToDouble# and naturalToFloat# to `base` package + ## 1.1 - Moved integerToDouble# and integerToFloat# to `base` package with fixed diff --git a/libraries/ghc-bignum/ghc-bignum.cabal b/libraries/ghc-bignum/ghc-bignum.cabal index 6de0328c49..468c2a042a 100644 --- a/libraries/ghc-bignum/ghc-bignum.cabal +++ b/libraries/ghc-bignum/ghc-bignum.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: ghc-bignum -version: 1.1 +version: 1.2 synopsis: GHC BigNum library license: BSD3 license-file: LICENSE diff --git a/libraries/ghc-bignum/src/GHC/Num/Natural.hs b/libraries/ghc-bignum/src/GHC/Num/Natural.hs index 55aee2d2f7..38a20f5169 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Natural.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Natural.hs @@ -132,19 +132,10 @@ naturalEncodeDouble# (NS w) 0# = word2Double# w naturalEncodeDouble# (NS w) e = wordEncodeDouble# w e naturalEncodeDouble# (NB b) e = bigNatEncodeDouble# b e --- | Encode a Natural (mantissa) into a Double# -naturalToDouble# :: Natural -> Double# -naturalToDouble# !n = naturalEncodeDouble# n 0# - --- | Encode a Natural (mantissa) into a Float# -naturalToFloat# :: Natural -> Float# -naturalToFloat# !i = naturalEncodeFloat# i 0# - -- | Encode (# Natural mantissa, Int# exponent #) into a Float# -- -- TODO: Not sure if it's worth to write 'Float' optimized versions here naturalEncodeFloat# :: Natural -> Int# -> Float# -naturalEncodeFloat# !m 0# = double2Float# (naturalToDouble# m) naturalEncodeFloat# !m e = double2Float# (naturalEncodeDouble# m e) -- | Equality test for Natural -- cgit v1.2.1