Restore exact old semantics of `decodeFloat`

`integer-gmp2` uses the new 64bit-based IEEE deconstructing primop
introduced in b62bd5ecf3be421778e4835010b6b334e95c5a56.

However, the returned values differ for exceptional IEEE values:

Previous (expected) semantics:

  > decodeFloat (-1/0)
  (-4503599627370496,972)

  > decodeFloat (1/0)
  (4503599627370496,972)

  > decodeFloat (0/0)
  (-6755399441055744,972)

Currently (broken) semantics:

  > decodeFloat (-1/0 :: Double)
  (-9223372036854775808,-53)

  > decodeFloat (1/0 :: Double)
  (-9223372036854775808,-53)

  > decodeFloat (0/0 :: Double)
  (-9223372036854775808,-53)

This patch reverts to the old expected semantics.

I plan to revisit the implementation during GHC 7.11 development.

This should address #9810

Reviewed By: austin, ekmett, luite

Differential Revision: https://phabricator.haskell.org/D486

5 files changed, 54 insertions, 0 deletions

diff --git a/rts/StgPrimFloat.c b/rts/StgPrimFloat.c
index 72a251b33e..e2eeee5c92 100644
--- a/rts/StgPrimFloat.c
+++ b/rts/StgPrimFloat.c
@@ -166,6 +166,8 @@ __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble
 StgInt
 __decodeDouble_Int64 (StgInt64 *const mantissa, const StgDouble dbl)
 {
+#if 0
+    // We can't use this yet as-is, see ticket #9810
     if (dbl) {
         int exp = 0;
         *mantissa = (StgInt64)scalbn(frexp(dbl, &exp), DBL_MANT_DIG);
@@ -174,6 +176,17 @@ __decodeDouble_Int64 (StgInt64 *const mantissa, const StgDouble dbl)
         *mantissa = 0;
         return 0;
     }
+#else
+    I_ man_sign = 0;
+    W_ man_high = 0, man_low = 0;
+    I_ exp = 0;
+
+    __decodeDouble_2Int (&man_sign, &man_high, &man_low, &exp, dbl);
+
+    *mantissa = ((((StgInt64)man_high << 32) | (StgInt64)man_low)
+                 * (StgInt64)man_sign);
+    return exp;
+#endif
 }
 
 /* Convenient union types for checking the layout of IEEE 754 types -
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index a07a376b26..705306c3ef 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1035,6 +1035,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/numeric/should_run/T7233
 /tests/numeric/should_run/T7689
 /tests/numeric/should_run/T8726
+/tests/numeric/should_run/T9810
 /tests/numeric/should_run/add2
 /tests/numeric/should_run/arith001
 /tests/numeric/should_run/arith002
diff --git a/testsuite/tests/numeric/should_run/T9810.hs b/testsuite/tests/numeric/should_run/T9810.hs
new file mode 100644
index 0000000000..b8ce1ba83e
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T9810.hs
@@ -0,0 +1,25 @@
+main = do
+    -- NOTE: the `abs` is to compensate for WAY=optllvm
+    --       having a positive sign for 0/0
+
+    putStrLn "## Double ##"
+    print $ idRational ( 1/0 :: Double)
+    print $ idRational (-1/0 :: Double)
+    print $ abs $ idRational ( 0/0 :: Double)
+    print $ idReencode ( 1/0 :: Double)
+    print $ idReencode (-1/0 :: Double)
+    print $ abs $ idReencode ( 0/0 :: Double)
+
+    putStrLn "## Float ##"
+    print $ idRational ( 1/0 :: Float)
+    print $ idRational (-1/0 :: Float)
+    print $ abs $ idRational ( 0/0 :: Float)
+    print $ idReencode ( 1/0 :: Float)
+    print $ idReencode (-1/0 :: Float)
+    print $ abs $ idReencode ( 0/0 :: Float)
+  where
+    idRational :: (Real a, Fractional a) => a -> a
+    idRational = fromRational . toRational
+
+    idReencode :: (RealFloat a) => a -> a
+    idReencode = uncurry encodeFloat . decodeFloat
diff --git a/testsuite/tests/numeric/should_run/T9810.stdout b/testsuite/tests/numeric/should_run/T9810.stdout
new file mode 100644
index 0000000000..52a7e8f4eb
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T9810.stdout
@@ -0,0 +1,14 @@
+## Double ##
+Infinity
+-Infinity
+Infinity
+Infinity
+-Infinity
+Infinity
+## Float ##
+Infinity
+-Infinity
+Infinity
+Infinity
+-Infinity
+Infinity
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index 76181a2115..62622799b8 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -63,3 +63,4 @@ test('T7233', normal, compile_and_run, [''])
 test('NumDecimals', normal, compile_and_run, [''])
 test('T8726', normal, compile_and_run, [''])
 test('CarryOverflow', omit_ways(['ghci']), compile_and_run, [''])
+test('T9810', normal, compile_and_run, [''])