[commit: base] master: Fix the behaviour of scaleFloat; part of #3898 (e3c360d)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/e3c360d4c1b47b8eb099ea5ffdd800af43eeec3f

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

commit e3c360d4c1b47b8eb099ea5ffdd800af43eeec3f
Author: Ian Lynagh <igloo at earth.li>
Date:   Sun Jul 31 20:41:25 2011 +0100

    Fix the behaviour of scaleFloat; part of #3898
    
    Patch from Daniel Fischer.

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

 GHC/Float.lhs     |   21 +++++++++++++++++----
 cbits/primFloat.c |   22 +++++++++++++++++++++-
 2 files changed, 38 insertions(+), 5 deletions(-)

diff --git a/GHC/Float.lhs b/GHC/Float.lhs
index 5100a88..f86ed6b 100644
--- a/GHC/Float.lhs
+++ b/GHC/Float.lhs
@@ -143,7 +143,10 @@ class  (RealFrac a, Floating a) => RealFloat a  where
     significand x       =  encodeFloat m (negate (floatDigits x))
                            where (m,_) = decodeFloat x
 
-    scaleFloat k x      =  encodeFloat m (n + clamp b k)
+    scaleFloat 0 x      =  x
+    scaleFloat k x
+      | isFix           =  x
+      | otherwise       =  encodeFloat m (n + clamp b k)
                            where (m,n) = decodeFloat x
                                  (l,h) = floatRange x
                                  d     = floatDigits x
@@ -156,6 +159,7 @@ class  (RealFrac a, Floating a) => RealFloat a  where
                                  -- for smaller than l - d.
                                  -- Add a little extra to keep clear
                                  -- from the boundary cases.
+                                 isFix = x == 0 || isNaN x || isInfinite x
 
     atan2 y x
       | x > 0            =  atan (y/x)
@@ -313,9 +317,13 @@ instance  RealFloat Float  where
     significand x       = case decodeFloat x of
                             (m,_) -> encodeFloat m (negate (floatDigits x))
 
-    scaleFloat k x      = case decodeFloat x of
+    scaleFloat 0 x      = x
+    scaleFloat k x
+      | isFix           = x
+      | otherwise       = case decodeFloat x of
                             (m,n) -> encodeFloat m (n + clamp bf k)
                         where bf = FLT_MAX_EXP - (FLT_MIN_EXP) + 4*FLT_MANT_DIG
+                              isFix = x == 0 || isFloatFinite x == 0
 
     isNaN x          = 0 /= isFloatNaN x
     isInfinite x     = 0 /= isFloatInfinite x
@@ -464,9 +472,13 @@ instance  RealFloat Double  where
     significand x       = case decodeFloat x of
                             (m,_) -> encodeFloat m (negate (floatDigits x))
 
-    scaleFloat k x      = case decodeFloat x of
+    scaleFloat 0 x      = x
+    scaleFloat k x
+      | isFix           = x
+      | otherwise       = case decodeFloat x of
                             (m,n) -> encodeFloat m (n + clamp bd k)
                         where bd = DBL_MAX_EXP - (DBL_MIN_EXP) + 4*DBL_MANT_DIG
+                              isFix = x == 0 || isDoubleFinite x == 0
 
     isNaN x             = 0 /= isDoubleNaN x
     isInfinite x        = 0 /= isDoubleInfinite x
@@ -1046,12 +1058,13 @@ foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int
 foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int
 foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int
 foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int
-
+foreign import ccall unsafe "isFloatFinite" isFloatFinite :: Float -> Int
 
 foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int
 foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int
 foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int
 foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int
+foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int
 \end{code}
 
 %*********************************************************
diff --git a/cbits/primFloat.c b/cbits/primFloat.c
index a8f4803..0e9f9b3 100644
--- a/cbits/primFloat.c
+++ b/cbits/primFloat.c
@@ -112,6 +112,16 @@ union stg_ieee754_dbl
 #ifdef IEEE_FLOATING_POINT
 
 HsInt
+isDoubleFinite(HsDouble d)
+{
+  union stg_ieee754_dbl u;
+
+  u.d = d;
+
+  return u.ieee.exponent != 2047;
+}
+
+HsInt
 isDoubleNaN(HsDouble d)
 {
   union stg_ieee754_dbl u;
@@ -190,6 +200,14 @@ isDoubleNegativeZero(HsDouble d)
 
 
 HsInt
+isFloatFinite(HsFloat f)
+{
+    union stg_ieee754_flt u;
+    u.f = f;
+    return u.ieee.exponent != 255;
+}
+
+HsInt
 isFloatNaN(HsFloat f)
 {
     union stg_ieee754_flt u;
@@ -426,11 +444,13 @@ rintDouble(HsDouble d)
 
 #else /* ! IEEE_FLOATING_POINT */
 
-/* Dummy definitions of predicates - they all return false */
+/* Dummy definitions of predicates - they all return "normal" values */
+HsInt isDoubleFinite(d) HsDouble d; { return 1;}
 HsInt isDoubleNaN(d) HsDouble d; { return 0; }
 HsInt isDoubleInfinite(d) HsDouble d; { return 0; }
 HsInt isDoubleDenormalized(d) HsDouble d; { return 0; }
 HsInt isDoubleNegativeZero(d) HsDouble d; { return 0; }
+HsInt isFloatFinite(f) HsFloat f; { return 1; }
 HsInt isFloatNaN(f) HsFloat f; { return 0; }
 HsInt isFloatInfinite(f) HsFloat f; { return 0; }
 HsInt isFloatDenormalized(f) HsFloat f; { return 0; }