X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FFloat.lhs;h=fc52dd96487f05fa519d9948bd5d97086658e2f9;hb=ba2fa1aad38f8dab23977beb21d0cad826e5b564;hp=714c62176c4e8b1769fc5ea043315d024cbc8a48;hpb=5c99290b8ab03f819f7b630f374187a254b0cea1;p=ghc-base.git diff --git a/GHC/Float.lhs b/GHC/Float.lhs index 714c621..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 #-} ----------------------------------------------------------------------------- @@ -24,6 +26,7 @@ module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double# ) import Data.Maybe +import Data.Bits import GHC.Base import GHC.List import GHC.Enum @@ -56,6 +59,11 @@ class (Fractional a) => Floating a where sinh, cosh, tanh :: a -> a asinh, acosh, atanh :: a -> a + {-# INLINE (**) #-} + {-# INLINE logBase #-} + {-# INLINE sqrt #-} + {-# INLINE tan #-} + {-# INLINE tanh #-} x ** y = exp (log x * y) logBase x y = log y / log x sqrt x = x ** 0.5 @@ -123,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 @@ -148,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 @@ -199,16 +205,22 @@ instance RealFrac Float where {-# INLINE floor #-} {-# INLINE truncate #-} - properFraction x - = case (decodeFloat x) of { (m,n) -> - let b = floatRadix x in - if n >= 0 then - (fromInteger m * fromInteger b ^ n, 0.0) - else - case (quotRem m (b^(negate n))) of { (w,r) -> - (fromInteger w, encodeFloat r n) - } - } +-- We assume that FLT_RADIX is 2 so that we can use more efficient code +#if FLT_RADIX != 2 +#error FLT_RADIX must be 2 +#endif + properFraction (F# x#) + = case decodeFloat_Int# x# of + (# m#, n# #) -> + let m = I# m# + n = I# n# + in + if n >= 0 + then (fromIntegral m * (2 ^ n), 0.0) + else let i = if m >= 0 then m `shiftR` negate n + else negate (negate m `shiftR` negate n) + f = m - (i `shiftL` negate n) + in (fromIntegral i, encodeFloat (fromIntegral f) n) truncate x = case properFraction x of (n,_) -> n @@ -248,15 +260,15 @@ 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 floatDigits _ = FLT_MANT_DIG -- ditto floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto - decodeFloat (F# f#) = case decodeFloatInteger f# of - (# i, e #) -> (i, I# e) + decodeFloat (F# f#) = case decodeFloat_Int# f# of + (# i, e #) -> (smallInteger i, I# e) encodeFloat i (I# e) = F# (encodeFloatInteger i e) @@ -267,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 @@ -286,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 @@ -343,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 @@ -407,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 @@ -618,7 +620,9 @@ floatToDigits base x = -- Haskell promises that p-1 <= logBase b f < p. (p - 1 + e0) * 3 `div` 10 else - ceiling ((log (fromInteger (f+1)) + + -- f :: Integer, log :: Float -> Float, + -- ceiling :: Float -> Int + ceiling ((log (fromInteger (f+1) :: Float) + fromIntegral e * log (fromInteger b)) / log (fromInteger base)) --WAS: fromInt e * log (fromInteger b)) @@ -896,21 +900,12 @@ powerDouble (D# x) (D# y) = D# (x **## y) \end{code} \begin{code} -foreign import ccall unsafe "__encodeFloat" - encodeFloat# :: Int# -> ByteArray# -> Int -> Float -foreign import ccall unsafe "__int_encodeFloat" - int_encodeFloat# :: Int# -> Int -> Float - - 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 "__encodeDouble" - encodeDouble# :: Int# -> ByteArray# -> Int -> Double - foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int @@ -990,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}