fromInteger :: Integer -> {Float,Double} now always round to nearest even

integerToFloat# and integerToDouble# were moved from ghc-bignum to base.

GHC.Integer.floatFromInteger and doubleFromInteger were removed.

Fixes #15926, #17231, #17782

5 files changed, 65 insertions, 32 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 2836c82e72..4779ca8de2 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -384,8 +384,6 @@ basicKnownKeyNames
         integerModName,
         integerDivModName,
         integerQuotRemName,
-        integerToFloatName,
-        integerToDoubleName,
         integerEncodeFloatName,
         integerEncodeDoubleName,
         integerGcdName,
@@ -438,6 +436,8 @@ basicKnownKeyNames
         bignatFromWordListName,
 
         -- Float/Double
+        integerToFloatName,
+        integerToDoubleName,
         rationalToFloatName,
         rationalToDoubleName,
 
@@ -1197,8 +1197,6 @@ integerFromNaturalName
    , integerModName
    , integerDivModName
    , integerQuotRemName
-   , integerToFloatName
-   , integerToDoubleName
    , integerEncodeFloatName
    , integerEncodeDoubleName
    , integerGcdName
@@ -1324,8 +1322,6 @@ integerDivName            = bniVarQual "integerDiv"                integerDivIdK
 integerModName            = bniVarQual "integerMod"                integerModIdKey
 integerDivModName         = bniVarQual "integerDivMod#"            integerDivModIdKey
 integerQuotRemName        = bniVarQual "integerQuotRem#"           integerQuotRemIdKey
-integerToFloatName        = bniVarQual "integerToFloat#"           integerToFloatIdKey
-integerToDoubleName       = bniVarQual "integerToDouble#"          integerToDoubleIdKey
 integerEncodeFloatName    = bniVarQual "integerEncodeFloat#"       integerEncodeFloatIdKey
 integerEncodeDoubleName   = bniVarQual "integerEncodeDouble#"      integerEncodeDoubleIdKey
 integerGcdName            = bniVarQual "integerGcd"                integerGcdIdKey
@@ -1370,7 +1366,9 @@ floatingClassName  = clsQual gHC_FLOAT (fsLit "Floating")  floatingClassKey
 realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey
 
 -- other GHC.Float functions
-rationalToFloatName, rationalToDoubleName :: Name
+integerToFloatName, integerToDoubleName, rationalToFloatName, rationalToDoubleName :: Name
+integerToFloatName   = varQual gHC_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey
+integerToDoubleName  = varQual gHC_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey
 rationalToFloatName  = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey
 rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey
 
@@ -2387,6 +2385,10 @@ coercionTokenIdKey      = mkPreludeMiscIdUnique 124
 noinlineIdKey           = mkPreludeMiscIdUnique 125
 considerAccessibleIdKey = mkPreludeMiscIdUnique 126
 
+integerToFloatIdKey, integerToDoubleIdKey :: Unique
+integerToFloatIdKey    = mkPreludeMiscIdUnique 128
+integerToDoubleIdKey   = mkPreludeMiscIdUnique 129
+
 rationalToFloatIdKey, rationalToDoubleIdKey :: Unique
 rationalToFloatIdKey   = mkPreludeMiscIdUnique 130
 rationalToDoubleIdKey  = mkPreludeMiscIdUnique 131
@@ -2600,8 +2602,6 @@ integerFromNaturalIdKey
    , integerModIdKey
    , integerDivModIdKey
    , integerQuotRemIdKey
-   , integerToFloatIdKey
-   , integerToDoubleIdKey
    , integerEncodeFloatIdKey
    , integerEncodeDoubleIdKey
    , integerGcdIdKey
@@ -2683,8 +2683,6 @@ integerDivIdKey            = mkPreludeMiscIdUnique 624
 integerModIdKey            = mkPreludeMiscIdUnique 625
 integerDivModIdKey         = mkPreludeMiscIdUnique 626
 integerQuotRemIdKey        = mkPreludeMiscIdUnique 627
-integerToFloatIdKey        = mkPreludeMiscIdUnique 628
-integerToDoubleIdKey       = mkPreludeMiscIdUnique 629
 integerEncodeFloatIdKey    = mkPreludeMiscIdUnique 630
 integerEncodeDoubleIdKey   = mkPreludeMiscIdUnique 631
 integerGcdIdKey            = mkPreludeMiscIdUnique 632
diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs
index cb1ef6044c..e5ecc94045 100644
--- a/libraries/base/GHC/Float.hs
+++ b/libraries/base/GHC/Float.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP
+{-# LANGUAGE BangPatterns
+           , CPP
            , GHCForeignImportPrim
            , NoImplicitPrelude
            , MagicHash
@@ -299,6 +300,15 @@ instance Num Float where
     {-# INLINE fromInteger #-}
     fromInteger i = F# (integerToFloat# i)
 
+-- | Convert an Integer to a Float#
+integerToFloat# :: Integer -> Float#
+{-# NOINLINE integerToFloat# #-}
+integerToFloat# (IS i)   = int2Float# i
+integerToFloat# i@(IP _) = case integerToBinaryFloat' i of
+                             F# x -> x
+integerToFloat# (IN bn)  = case integerToBinaryFloat' (IP bn) of
+                             F# x -> negateFloat# x
+
 -- | @since 2.01
 instance  Real Float  where
     toRational (F# x#)  =
@@ -494,6 +504,14 @@ instance  Num Double  where
     {-# INLINE fromInteger #-}
     fromInteger i = D# (integerToDouble# i)
 
+-- | Convert an Integer to a Double#
+integerToDouble# :: Integer -> Double#
+{-# NOINLINE integerToDouble# #-}
+integerToDouble# (IS i)   = int2Double# i
+integerToDouble# i@(IP _) = case integerToBinaryFloat' i of
+                              D# x -> x
+integerToDouble# (IN bn)  = case integerToBinaryFloat' (IP bn) of
+                              D# x -> negateDouble# x
 
 -- | @since 2.01
 instance  Real Double  where
@@ -920,7 +938,39 @@ floatToDigits base x =
  (map fromIntegral (reverse rds), k)
 
 ------------------------------------------------------------------------
--- Converting from a Rational to a RealFloa
+-- Converting from an Integer to a RealFloat
+------------------------------------------------------------------------
+
+{-# SPECIALISE integerToBinaryFloat' :: Integer -> Float,
+                                        Integer -> Double #-}
+-- | Converts a positive integer to a floating-point value.
+--
+-- The value nearest to the argument will be returned.
+-- If there are two such values, the one with an even significand will
+-- be returned (i.e. IEEE roundTiesToEven).
+--
+-- The argument must be strictly positive, and @floatRadix (undefined :: a)@ must be 2.
+integerToBinaryFloat' :: RealFloat a => Integer -> a
+integerToBinaryFloat' n = result
+  where
+    mantDigs = floatDigits result
+    k = I# (word2Int# (integerLog2# n))
+    result = if k < mantDigs then
+               encodeFloat n 0
+             else
+               let !e@(I# e#) = k - mantDigs + 1
+                   q = n `unsafeShiftR` e
+                   n' = case roundingMode# n (e# -# 1#) of
+                          0# -> q
+                          1# -> if integerToInt q .&. 1 == 0 then
+                                  q
+                                else
+                                  q + 1
+                          _ {- 2# -} -> q + 1
+               in encodeFloat n' e
+
+------------------------------------------------------------------------
+-- Converting from a Rational to a RealFloat
 ------------------------------------------------------------------------
 
 {-
diff --git a/libraries/base/GHC/Integer.hs b/libraries/base/GHC/Integer.hs
index 598fe33c6d..070bd8fb61 100644
--- a/libraries/base/GHC/Integer.hs
+++ b/libraries/base/GHC/Integer.hs
@@ -23,8 +23,7 @@ module GHC.Integer (
 #endif
 
     -- * Helpers for 'RealFloat' type-class operations
-    encodeFloatInteger, floatFromInteger,
-    encodeDoubleInteger, decodeDoubleInteger, doubleFromInteger,
+    encodeFloatInteger, encodeDoubleInteger, decodeDoubleInteger,
 
     -- * Arithmetic operations
     plusInteger, minusInteger, timesInteger, negateInteger,
@@ -95,15 +94,9 @@ integerToInt64 = I.integerToInt64#
 encodeFloatInteger :: Integer -> Int# -> Float#
 encodeFloatInteger = I.integerEncodeFloat#
 
-floatFromInteger :: Integer -> Float#
-floatFromInteger = I.integerToFloat#
-
 encodeDoubleInteger :: Integer -> Int# -> Double#
 encodeDoubleInteger = I.integerEncodeDouble#
 
-doubleFromInteger :: Integer -> Double#
-doubleFromInteger = I.integerToDouble#
-
 decodeDoubleInteger :: Double# -> (# Integer, Int# #)
 decodeDoubleInteger = I.integerDecodeDouble#
 
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 7900c9aad5..fcf9c0dde6 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -38,6 +38,9 @@
   * Under POSIX, `System.IO.openFile` will no longer leak a file descriptor if it
     is interrupted by an asynchronous exception (#19114, #19115).
 
+  * `fromInteger :: Integer -> Float/Double` now consistently round to the
+    nearest value, with ties to even.
+
 ## 4.15.0.0 *TBA*
 
   * `openFile` now calls the `open` system call with an `interruptible` FFI
diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
index ae0d6af20b..6334e1636f 100644
--- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
@@ -1084,22 +1084,11 @@ integerEncodeDouble# (IN b) e  = negateDouble# (bigNatEncodeDouble# b e)
 integerEncodeDouble :: Integer -> Int -> Double
 integerEncodeDouble !m (I# e)  = D# (integerEncodeDouble# m e)
 
--- | Encode an Integer (mantissa) into a Double#
-integerToDouble# :: Integer -> Double#
-{-# NOINLINE integerToDouble# #-}
-integerToDouble# !i = integerEncodeDouble# i 0#
-
--- | Encode an Integer (mantissa) into a Float#
-integerToFloat# :: Integer -> Float#
-{-# NOINLINE integerToFloat# #-}
-integerToFloat# !i = integerEncodeFloat# i 0#
-
 -- | Encode (# Integer mantissa, Int# exponent #) into a Float#
 --
 -- TODO: Not sure if it's worth to write 'Float' optimized versions here
 integerEncodeFloat# :: Integer -> Int# -> Float#
 {-# NOINLINE integerEncodeFloat# #-}
-integerEncodeFloat# !m 0# = double2Float# (integerToDouble# m)
 integerEncodeFloat# !m e  = double2Float# (integerEncodeDouble# m e)
 
 -- | Compute the number of digits of the Integer (without the sign) in the given base.