[commit: ghc] master: Restore exact old semantics of `decodeFloat` (e2af452)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/e2af452cd533778c5447719c59429d72bb1fe00d/ghc

>---------------------------------------------------------------

commit e2af452cd533778c5447719c59429d72bb1fe00d
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date:   Wed Nov 19 11:09:33 2014 +0100

    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


>---------------------------------------------------------------

e2af452cd533778c5447719c59429d72bb1fe00d
 rts/StgPrimFloat.c                              | 13 +++++++++++++
 testsuite/.gitignore                            |  1 +
 testsuite/tests/numeric/should_run/T9810.hs     | 25 +++++++++++++++++++++++++
 testsuite/tests/numeric/should_run/T9810.stdout | 14 ++++++++++++++
 testsuite/tests/numeric/should_run/all.T        |  1 +
 5 files changed, 54 insertions(+)

diff --git a/rts/StgPrimFloat.c b/rts/StgPrimFloat.c
index 72a251b..e2eeee5 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 a07a376..705306c 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 0000000..b8ce1ba
--- /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 0000000..52a7e8f
--- /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 76181a2..6262279 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, [''])