Fix the behaviour of scaleFloat; part of #3898

Patch from Daniel Fischer.

diff --git a/GHC/Float.lhs b/GHC/Float.lhs
index 5100a88..f86ed6b 100644 (file)
--- 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
 
     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
                            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.
                                  -- 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)
 
     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))
 
     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
                             (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
 
     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))
 
     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
                             (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
 
     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 "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 "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}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************

diff --git a/cbits/primFloat.c b/cbits/primFloat.c
index a8f4803..0e9f9b3 100644 (file)
--- a/cbits/primFloat.c
+++ b/cbits/primFloat.c
@@ -112,6 +112,16 @@ union stg_ieee754_dbl
 #ifdef IEEE_FLOATING_POINT
 
 HsInt
 #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;
 isDoubleNaN(HsDouble d)
 {
   union stg_ieee754_dbl u;


@@ -190,6 +200,14 @@ isDoubleNegativeZero(HsDouble d)
 
 
 HsInt
 
 
 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;
 isFloatNaN(HsFloat f)
 {
     union stg_ieee754_flt u;


@@ -426,11 +444,13 @@ rintDouble(HsDouble d)
 
 #else /* ! IEEE_FLOATING_POINT */
 
 
 #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 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; }
 HsInt isFloatNaN(f) HsFloat f; { return 0; }
 HsInt isFloatInfinite(f) HsFloat f; { return 0; }
 HsInt isFloatDenormalized(f) HsFloat f; { return 0; }