\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 #-}
-----------------------------------------------------------------------------
import Data.Maybe
+import Data.Bits
import GHC.Base
import GHC.List
import GHC.Enum
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
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
%*********************************************************
\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
{-# 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
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)
(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
%*********************************************************
\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
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
(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
-- 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))
\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
= 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}
projects / ghc-base.git / blobdiff