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.

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