X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FFloat.lhs;h=fc52dd96487f05fa519d9948bd5d97086658e2f9;hb=ba2fa1aad38f8dab23977beb21d0cad826e5b564;hp=9a4d4d9042d0290690c64ebae0dcd81020c2d836;hpb=de59ad189974c1a3b984f41d609e38a60f65b06a;p=ghc-base.git

diff --git a/GHC/Float.lhs b/GHC/Float.lhs
index 9a4d4d9..fc52dd9 100644
--- a/GHC/Float.lhs
+++ b/GHC/Float.lhs
@@ -1,5 +1,7 @@
 \begin{code}
 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
+-- We believe we could deorphan this module, by moving lots of things
+-- around, but we haven't got there yet:
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
@@ -129,9 +131,20 @@ 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+k)
+    scaleFloat k x      =  encodeFloat m (n + clamp b k)
                            where (m,n) = decodeFloat x
-                           
+                                 (l,h) = floatRange x
+                                 d     = floatDigits x
+                                 b     = h - l + 4*d
+                                 -- n+k may overflow, which would lead
+                                 -- to wrong results, hence we clamp the
+                                 -- scaling parameter.
+                                 -- If n + k would be larger than h,
+                                 -- n + clamp b k must be too, simliar
+                                 -- for smaller than l - d.
+                                 -- Add a little extra to keep clear
+                                 -- from the boundary cases.
+
     atan2 y x
       | x > 0            =  atan (y/x)
       | x == 0 && y > 0  =  pi/2
@@ -154,19 +167,6 @@ class  (RealFrac a, Floating a) => RealFloat a  where
 %*********************************************************
 
 \begin{code}
-instance Eq Float where
-    (F# x) == (F# y) = x `eqFloat#` y
-
-instance Ord Float where
-    (F# x) `compare` (F# y) | x `ltFloat#` y = LT
-                            | x `eqFloat#` y = EQ
-                            | otherwise      = GT
-
-    (F# x) <  (F# y) = x `ltFloat#`  y
-    (F# x) <= (F# y) = x `leFloat#`  y
-    (F# x) >= (F# y) = x `geFloat#`  y
-    (F# x) >  (F# y) = x `gtFloat#`  y
-
 instance  Num Float  where
     (+)         x y     =  plusFloat x y
     (-)         x y     =  minusFloat x y
@@ -260,7 +260,7 @@ instance  Floating Float  where
 
     asinh x = log (x + sqrt (1.0+x*x))
     acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
-    atanh x = log ((x+1.0) / sqrt (1.0-x*x))
+    atanh x = 0.5 * log ((1.0+x) / (1.0-x))
 
 instance  RealFloat Float  where
     floatRadix _        =  FLT_RADIX        -- from float.h
@@ -279,7 +279,9 @@ instance  RealFloat Float  where
                             (m,_) -> encodeFloat m (negate (floatDigits x))
 
     scaleFloat k x      = case decodeFloat x of
-                            (m,n) -> encodeFloat m (n+k)
+                            (m,n) -> encodeFloat m (n + clamp bf k)
+                        where bf = FLT_MAX_EXP - (FLT_MIN_EXP) + 4*FLT_MANT_DIG
+
     isNaN x          = 0 /= isFloatNaN x
     isInfinite x     = 0 /= isFloatInfinite x
     isDenormalized x = 0 /= isFloatDenormalized x
@@ -298,19 +300,6 @@ instance  Show Float  where
 %*********************************************************
 
 \begin{code}
-instance Eq Double where
-    (D# x) == (D# y) = x ==## y
-
-instance Ord Double where
-    (D# x) `compare` (D# y) | x <## y   = LT
-                            | x ==## y  = EQ
-                            | otherwise = GT
-
-    (D# x) <  (D# y) = x <##  y
-    (D# x) <= (D# y) = x <=## y
-    (D# x) >= (D# y) = x >=## y
-    (D# x) >  (D# y) = x >##  y
-
 instance  Num Double  where
     (+)         x y     =  plusDouble x y
     (-)         x y     =  minusDouble x y
@@ -355,7 +344,7 @@ instance  Floating Double  where
 
     asinh x = log (x + sqrt (1.0+x*x))
     acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
-    atanh x = log ((x+1.0) / sqrt (1.0-x*x))
+    atanh x = 0.5 * log ((1.0+x) / (1.0-x))
 
 {-# RULES "truncate/Double->Int" truncate = double2Int #-}
 instance  RealFrac Double  where
@@ -419,7 +408,8 @@ instance  RealFloat Double  where
                             (m,_) -> encodeFloat m (negate (floatDigits x))
 
     scaleFloat k x      = case decodeFloat x of
-                            (m,n) -> encodeFloat m (n+k)
+                            (m,n) -> encodeFloat m (n + clamp bd k)
+                        where bd = DBL_MAX_EXP - (DBL_MIN_EXP) + 4*DBL_MANT_DIG
 
     isNaN x             = 0 /= isDoubleNaN x
     isInfinite x        = 0 /= isDoubleInfinite x
@@ -995,3 +985,12 @@ showSignedFloat showPos p x
        = showParen (p > 6) (showChar '-' . showPos (-x))
    | otherwise = showPos x
 \end{code}
+
+We need to prevent over/underflow of the exponent in encodeFloat when
+called from scaleFloat, hence we clamp the scaling parameter.
+We must have a large enough range to cover the maximum difference of
+exponents returned by decodeFloat.
+\begin{code}
+clamp :: Int -> Int -> Int
+clamp bd k = max (-bd) (min bd k)
+\end{code}