X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FFloat.lhs;h=dbb556fe50083e46c987a7a874647cc83fd7911e;hb=4dc0a6fa50f56444c76e84387a16b179df2549ee;hp=79683f2eae1b06a4bbef95f4075041340c72ed8c;hpb=a5e4b9f4fbd1a148c80294a02e345e84d8945526;p=ghc-base.git diff --git a/GHC/Float.lhs b/GHC/Float.lhs index 79683f2..dbb556f 100644 --- a/GHC/Float.lhs +++ b/GHC/Float.lhs @@ -1,5 +1,8 @@ \begin{code} -{-# OPTIONS_GHC -fno-implicit-prelude #-} +{-# 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 #-} ----------------------------------------------------------------------------- -- | @@ -18,10 +21,12 @@ #include "ieee-flpt.h" -- #hide -module GHC.Float( module GHC.Float, Float#, Double# ) where +module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double# ) + where import Data.Maybe +import Data.Bits import GHC.Base import GHC.List import GHC.Enum @@ -54,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 @@ -141,43 +151,11 @@ class (RealFrac a, Floating a) => RealFloat a where %********************************************************* %* * -\subsection{Type @Integer@, @Float@, @Double@} -%* * -%********************************************************* - -\begin{code} --- | Single-precision floating point numbers. --- It is desirable that this type be at least equal in range and precision --- to the IEEE single-precision type. -data Float = F# Float# - --- | Double-precision floating point numbers. --- It is desirable that this type be at least equal in range and precision --- to the IEEE double-precision type. -data Double = D# Double# -\end{code} - - -%********************************************************* -%* * \subsection{Type @Float@} %* * %********************************************************* \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 @@ -216,16 +194,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 @@ -272,8 +256,8 @@ instance RealFloat Float where 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) @@ -303,19 +287,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 @@ -520,6 +491,7 @@ formatRealFloat fmt decs x "0" -> "0.0e0" [d] -> d : ".0e" ++ show_e' (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' + [] -> error "formatRealFloat/doFmt/FFExponent: []" Just dec -> let dec' = max dec 1 in case is of @@ -565,6 +537,7 @@ roundTo base d is = case f d is of x@(0,_) -> x (1,xs) -> (1, 1:xs) + _ -> error "roundTo: bad Value" where b2 = base `div` 2 @@ -633,7 +606,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)) @@ -732,13 +707,13 @@ Now, here's Lennart's code (which works) fromRat :: (RealFloat a) => Rational -> a -- Deal with special cases first, delegating the real work to fromRat' -fromRat (n :% 0) | n > 0 = 1/0 -- +Infinity - | n == 0 = 0/0 -- NaN - | n < 0 = -1/0 -- -Infinity +fromRat (n :% 0) | n > 0 = 1/0 -- +Infinity + | n < 0 = -1/0 -- -Infinity + | otherwise = 0/0 -- NaN -fromRat (n :% d) | n > 0 = fromRat' (n :% d) - | n == 0 = encodeFloat 0 0 -- Zero - | n < 0 = - fromRat' ((-n) :% d) +fromRat (n :% d) | n > 0 = fromRat' (n :% d) + | n < 0 = - fromRat' ((-n) :% d) + | otherwise = encodeFloat 0 0 -- Zero -- Conversion process: -- Scale the rational number by the RealFloat base until @@ -911,21 +886,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 @@ -946,9 +912,48 @@ foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Doubl "realToFrac/Float->Double" realToFrac = float2Double "realToFrac/Double->Float" realToFrac = double2Float "realToFrac/Double->Double" realToFrac = id :: Double -> Double +"realToFrac/Int->Double" realToFrac = int2Double -- See Note [realToFrac int-to-float] +"realToFrac/Int->Float" realToFrac = int2Float -- ..ditto #-} \end{code} +Note [realToFrac int-to-float] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don found that the RULES for realToFrac/Int->Double and simliarly +Float made a huge difference to some stream-fusion programs. Here's +an example + + import Data.Array.Vector + + n = 40000000 + + main = do + let c = replicateU n (2::Double) + a = mapU realToFrac (enumFromToU 0 (n-1) ) :: UArr Double + print (sumU (zipWithU (*) c a)) + +Without the RULE we get this loop body: + + case $wtoRational sc_sY4 of ww_aM7 { (# ww1_aM9, ww2_aMa #) -> + case $wfromRat ww1_aM9 ww2_aMa of tpl_X1P { D# ipv_sW3 -> + Main.$s$wfold + (+# sc_sY4 1) + (+# wild_X1i 1) + (+## sc2_sY6 (*## 2.0 ipv_sW3)) + +And with the rule: + + Main.$s$wfold + (+# sc_sXT 1) + (+# wild_X1h 1) + (+## sc2_sXV (*## 2.0 (int2Double# sc_sXT))) + +The running time of the program goes from 120 seconds to 0.198 seconds +with the native backend, and 0.143 seconds with the C backend. + +A few more details in Trac #2251, and the patch message +"Add RULES for realToFrac from Int". + %********************************************************* %* * \subsection{Utils}