summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Builtin/Names.hs16
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs34
-rw-r--r--libraries/base/GHC/Float.hs15
-rw-r--r--libraries/ghc-bignum/changelog.md4
-rw-r--r--libraries/ghc-bignum/ghc-bignum.cabal2
-rw-r--r--libraries/ghc-bignum/src/GHC/Num/Natural.hs9
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
View Lorry Controller Status