X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FFloat.lhs;h=1c6fd5f8d76204512f45f37c0bc1cd16332ad124;hb=HEAD;hp=79683f2eae1b06a4bbef95f4075041340c72ed8c;hpb=a5e4b9f4fbd1a148c80294a02e345e84d8945526;p=ghc-base.git diff --git a/GHC/Float.lhs b/GHC/Float.lhs index 79683f2..1c6fd5f 100644 --- a/GHC/Float.lhs +++ b/GHC/Float.lhs @@ -1,12 +1,21 @@ \begin{code} -{-# OPTIONS_GHC -fno-implicit-prelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , MagicHash + , UnboxedTuples + , ForeignFunctionInterface + #-} +-- 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 #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Float -- Copyright : (c) The University of Glasgow 1994-2002 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC Extensions) @@ -18,10 +27,13 @@ #include "ieee-flpt.h" -- #hide -module GHC.Float( module GHC.Float, Float#, Double# ) where +module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double# + , double2Int, int2Double, float2Int, int2Float ) + where import Data.Maybe +import Data.Bits import GHC.Base import GHC.List import GHC.Enum @@ -29,6 +41,10 @@ import GHC.Show import GHC.Num import GHC.Real import GHC.Arr +import GHC.Float.RealFracMethods +import GHC.Float.ConversionUtils +import GHC.Integer.Logarithms ( integerLogBase# ) +import GHC.Integer.Logarithms.Internals infixr 8 ** \end{code} @@ -54,6 +70,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 @@ -121,13 +142,24 @@ 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 - | x < 0 && y > 0 = pi + atan (y/x) + | x < 0 && y > 0 = pi + atan (y/x) |(x <= 0 && y < 0) || (x < 0 && isNegativeZero y) || (isNegativeZero x && isNegativeZero y) @@ -141,43 +173,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 @@ -193,39 +193,68 @@ instance Num Float where fromInteger i = F# (floatFromInteger i) instance Real Float where - toRational x = (m%1)*(b%1)^^n - where (m,n) = decodeFloat x - b = floatRadix x + toRational (F# x#) = + case decodeFloat_Int# x# of + (# m#, e# #) + | e# >=# 0# -> + (smallInteger m# `shiftLInteger` e#) :% 1 + | (int2Word# m# `and#` 1##) `eqWord#` 0## -> + case elimZerosInt# m# (negateInt# e#) of + (# n, d# #) -> n :% shiftLInteger 1 d# + | otherwise -> + smallInteger m# :% shiftLInteger 1 (negateInt# e#) instance Fractional Float where (/) x y = divideFloat x y - fromRational x = fromRat x + fromRational (n:%0) + | n == 0 = 0/0 + | n < 0 = (-1)/0 + | otherwise = 1/0 + fromRational (n:%d) + | n == 0 = encodeFloat 0 0 + | n < 0 = -(fromRat'' minEx mantDigs (-n) d) + | otherwise = fromRat'' minEx mantDigs n d + where + minEx = FLT_MIN_EXP + mantDigs = FLT_MANT_DIG recip x = 1.0 / x -{-# RULES "truncate/Float->Int" truncate = float2Int #-} +-- RULES for Integer and Int +{-# RULES +"properFraction/Float->Integer" properFraction = properFractionFloatInteger +"truncate/Float->Integer" truncate = truncateFloatInteger +"floor/Float->Integer" floor = floorFloatInteger +"ceiling/Float->Integer" ceiling = ceilingFloatInteger +"round/Float->Integer" round = roundFloatInteger +"properFraction/Float->Int" properFraction = properFractionFloatInt +"truncate/Float->Int" truncate = float2Int +"floor/Float->Int" floor = floorFloatInt +"ceiling/Float->Int" ceiling = ceilingFloatInt +"round/Float->Int" round = roundFloatInt + #-} instance RealFrac Float where - {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-} - {-# SPECIALIZE round :: Float -> Int #-} - - {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-} - {-# SPECIALIZE round :: Float -> Integer #-} - -- ceiling, floor, and truncate are all small - {-# INLINE ceiling #-} - {-# 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) - } - } + {-# INLINE [1] ceiling #-} + {-# INLINE [1] floor #-} + {-# INLINE [1] truncate #-} + +-- 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 @@ -265,15 +294,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) @@ -284,7 +313,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 @@ -293,7 +324,7 @@ instance RealFloat Float where instance Show Float where showsPrec x = showSignedFloat showFloat x - showList = showList__ (showsPrec 0) + showList = showList__ (showsPrec 0) \end{code} %********************************************************* @@ -303,19 +334,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 @@ -332,13 +350,30 @@ instance Num Double where instance Real Double where - toRational x = (m%1)*(b%1)^^n - where (m,n) = decodeFloat x - b = floatRadix x + toRational (D# x#) = + case decodeDoubleInteger x# of + (# m, e# #) + | e# >=# 0# -> + shiftLInteger m e# :% 1 + | (int2Word# (toInt# m) `and#` 1##) `eqWord#` 0## -> + case elimZerosInteger m (negateInt# e#) of + (# n, d# #) -> n :% shiftLInteger 1 d# + | otherwise -> + m :% shiftLInteger 1 (negateInt# e#) instance Fractional Double where (/) x y = divideDouble x y - fromRational x = fromRat x + fromRational (n:%0) + | n == 0 = 0/0 + | n < 0 = (-1)/0 + | otherwise = 1/0 + fromRational (n:%d) + | n == 0 = encodeFloat 0 0 + | n < 0 = -(fromRat'' minEx mantDigs (-n) d) + | otherwise = fromRat'' minEx mantDigs n d + where + minEx = DBL_MIN_EXP + mantDigs = DBL_MANT_DIG recip x = 1.0 / x instance Floating Double where @@ -360,29 +395,34 @@ 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 #-} +-- RULES for Integer and Int +{-# RULES +"properFraction/Double->Integer" properFraction = properFractionDoubleInteger +"truncate/Double->Integer" truncate = truncateDoubleInteger +"floor/Double->Integer" floor = floorDoubleInteger +"ceiling/Double->Integer" ceiling = ceilingDoubleInteger +"round/Double->Integer" round = roundDoubleInteger +"properFraction/Double->Int" properFraction = properFractionDoubleInt +"truncate/Double->Int" truncate = double2Int +"floor/Double->Int" floor = floorDoubleInt +"ceiling/Double->Int" ceiling = ceilingDoubleInt +"round/Double->Int" round = roundDoubleInt + #-} instance RealFrac Double where - {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-} - {-# SPECIALIZE round :: Double -> Int #-} - - {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-} - {-# SPECIALIZE round :: Double -> Integer #-} - -- ceiling, floor, and truncate are all small - {-# INLINE ceiling #-} - {-# INLINE floor #-} - {-# INLINE truncate #-} + {-# INLINE [1] ceiling #-} + {-# INLINE [1] floor #-} + {-# INLINE [1] 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) + (fromInteger m * 2 ^ n, 0.0) else - case (quotRem m (b^(negate n))) of { (w,r) -> + case (quotRem m (2^(negate n))) of { (w,r) -> (fromInteger w, encodeFloat r n) } } @@ -424,7 +464,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 @@ -434,7 +475,7 @@ instance RealFloat Double where instance Show Double where showsPrec x = showSignedFloat showFloat x - showList = showList__ (showsPrec 0) + showList = showList__ (showsPrec 0) \end{code} %********************************************************* @@ -452,7 +493,7 @@ how 0.1 is represented. NOTE: The instances for Float and Double do not make use of the default methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being -a `non-lossy' conversion to and from Ints. Instead we make use of the +a `non-lossy' conversion to and from Ints. Instead we make use of the 1.2 default methods (back in the days when Enum had Ord as a superclass) for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.) @@ -488,7 +529,7 @@ instance Enum Double where \begin{code} -- | Show a signed 'RealFloat' value to full precision --- using standard decimal notation for arguments whose absolute value lies +-- using standard decimal notation for arguments whose absolute value lies -- between @0.1@ and @9,999,999@, and scientific notation otherwise. showFloat :: (RealFloat a) => a -> ShowS showFloat x = showString (formatRealFloat FFGeneric Nothing x) @@ -503,7 +544,7 @@ formatRealFloat fmt decs x | isInfinite x = if x < 0 then "-Infinity" else "Infinity" | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x)) | otherwise = doFmt fmt (floatToDigits (toInteger base) x) - where + where base = 10 doFmt format (is, e) = @@ -520,6 +561,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 +607,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 @@ -582,7 +625,7 @@ roundTo base d is = -- This version uses a much slower logarithm estimator. It should be improved. -- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number, --- and returns a list of digits and an exponent. +-- and returns a list of digits and an exponent. -- In particular, if @x>=0@, and -- -- > floatToDigits base x = ([d1,d2,...,dn], e) @@ -598,7 +641,7 @@ roundTo base d is = floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) floatToDigits _ 0 = ([0], 0) floatToDigits base x = - let + let (f0, e0) = decodeFloat x (minExp0, _) = floatRange x p = floatDigits x @@ -606,34 +649,52 @@ floatToDigits base x = minExp = minExp0 - p -- the real minimum exponent -- Haskell requires that f be adjusted so denormalized numbers -- will have an impossibly low exponent. Adjust for this. - (f, e) = + (f, e) = let n = minExp - e0 in - if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) + if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0) (r, s, mUp, mDn) = if e >= 0 then - let be = b^ e in - if f == b^(p-1) then - (f*be*b*2, 2*b, be*b, b) + let be = expt b e in + if f == expt b (p-1) then + (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig else (f*be*2, 2, be, be) else - if e > minExp && f == b^(p-1) then - (f*b*2, b^(-e+1)*2, b, 1) + if e > minExp && f == expt b (p-1) then + (f*b*2, expt b (-e+1)*2, b, 1) else - (f*2, b^(-e)*2, 1, 1) + (f*2, expt b (-e)*2, 1, 1) k :: Int k = - let + let k0 :: Int k0 = if b == 2 && base == 10 then - -- logBase 10 2 is slightly bigger than 3/10 so - -- the following will err on the low side. Ignoring - -- the fraction will make it err even more. - -- Haskell promises that p-1 <= logBase b f < p. - (p - 1 + e0) * 3 `div` 10 + -- logBase 10 2 is very slightly larger than 8651/28738 + -- (about 5.3558e-10), so if log x >= 0, the approximation + -- k1 is too small, hence we add one and need one fixup step less. + -- If log x < 0, the approximation errs rather on the high side. + -- That is usually more than compensated for by ignoring the + -- fractional part of logBase 2 x, but when x is a power of 1/2 + -- or slightly larger and the exponent is a multiple of the + -- denominator of the rational approximation to logBase 10 2, + -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x, + -- we get a leading zero-digit we don't want. + -- With the approximation 3/10, this happened for + -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above. + -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x + -- for IEEE-ish floating point types with exponent fields + -- <= 17 bits and mantissae of several thousand bits, earlier + -- convergents to logBase 10 2 would fail for long double. + -- Using quot instead of div is a little faster and requires + -- fewer fixup steps for negative lx. + let lx = p - 1 + e0 + k1 = (lx * 8651) `quot` 28738 + in if lx >= 0 then k1 + 1 else k1 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)) @@ -648,7 +709,7 @@ floatToDigits base x = gen ds rn sN mUpN mDnN = let - (dn, rn') = (rn * base) `divMod` sN + (dn, rn') = (rn * base) `quotRem` sN mUpN' = mUpN * base mDnN' = mDnN * base in @@ -657,8 +718,8 @@ floatToDigits base x = (False, True) -> dn+1 : ds (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' - - rds = + + rds = if k >= 0 then gen [] r (s * expt base k) mUp mDn else @@ -701,7 +762,7 @@ fromRat :: (RealFloat a) => Rational -> a fromRat x = x' where x' = f e --- If the exponent of the nearest floating-point number to x +-- If the exponent of the nearest floating-point number to x -- is e, then the significand is the integer nearest xb^(-e), -- where b is the floating-point radix. We start with a good -- guess for e, and if it is correct, the exponent of the @@ -727,18 +788,20 @@ Now, here's Lennart's code (which works) \begin{code} -- | Converts a 'Rational' value into any type in class 'RealFloat'. -{-# SPECIALISE fromRat :: Rational -> Double, - Rational -> Float #-} +{-# RULES +"fromRat/Float" fromRat = (fromRational :: Rational -> Float) +"fromRat/Double" fromRat = (fromRational :: Rational -> Double) + #-} 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 @@ -764,7 +827,7 @@ fromRat' x = r -- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp. scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int) -scaleRat b minExp xMin xMax p x +scaleRat b minExp xMin xMax p x | p <= minExp = (x, p) | x >= xMax = scaleRat b minExp xMin xMax (p+1) (x/b) | x < xMin = scaleRat b minExp xMin xMax (p-1) (x*b) @@ -780,27 +843,106 @@ expt base n = if base == 2 && n >= minExpt && n <= maxExpt then expts!n else - base^n + if base == 10 && n <= maxExpt10 then + expts10!n + else + base^n expts :: Array Int Integer expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] +maxExpt10 :: Int +maxExpt10 = 324 + +expts10 :: Array Int Integer +expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]] + -- Compute the (floor of the) log of i in base b. -- Simplest way would be just divide i by b until it's smaller then b, but that would --- be very slow! We are just slightly more clever. +-- be very slow! We are just slightly more clever, except for base 2, where +-- we take advantage of the representation of Integers. +-- The general case could be improved by a lookup table for +-- approximating the result by integerLog2 i / integerLog2 b. integerLogBase :: Integer -> Integer -> Int integerLogBase b i | i < b = 0 - | otherwise = doDiv (i `div` (b^l)) l - where - -- Try squaring the base first to cut down the number of divisions. - l = 2 * integerLogBase (b*b) i + | b == 2 = I# (integerLog2# i) + | otherwise = I# (integerLogBase# b i) - doDiv :: Integer -> Int -> Int - doDiv x y - | x < b = y - | otherwise = doDiv (x `div` b) (y+1) +\end{code} +Unfortunately, the old conversion code was awfully slow due to +a) a slow integer logarithm +b) repeated calculation of gcd's + +For the case of Rational's coming from a Float or Double via toRational, +we can exploit the fact that the denominator is a power of two, which for +these brings a huge speedup since we need only shift and add instead +of division. + +The below is an adaption of fromRat' for the conversion to +Float or Double exploiting the know floatRadix and avoiding +divisions as much as possible. + +\begin{code} +{-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Float, + Int -> Int -> Integer -> Integer -> Double #-} +fromRat'' :: RealFloat a => Int -> Int -> Integer -> Integer -> a +fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d = + case integerLog2IsPowerOf2# d of + (# ld#, pw# #) + | pw# ==# 0# -> + case integerLog2# n of + ln# | ln# ># (ld# +# me#) -> + if ln# <# md# + then encodeFloat (n `shiftL` (I# (md# -# 1# -# ln#))) + (I# (ln# +# 1# -# ld# -# md#)) + else let n' = n `shiftR` (I# (ln# +# 1# -# md#)) + n'' = case roundingMode# n (ln# -# md#) of + 0# -> n' + 2# -> n' + 1 + _ -> case fromInteger n' .&. (1 :: Int) of + 0 -> n' + _ -> n' + 1 + in encodeFloat n'' (I# (ln# -# ld# +# 1# -# md#)) + | otherwise -> + case ld# +# (me# -# md#) of + ld'# | ld'# ># (ln# +# 1#) -> encodeFloat 0 0 + | ld'# ==# (ln# +# 1#) -> + case integerLog2IsPowerOf2# n of + (# _, 0# #) -> encodeFloat 0 0 + (# _, _ #) -> encodeFloat 1 (minEx - mantDigs) + | ld'# <=# 0# -> + encodeFloat n (I# ((me# -# md#) -# ld'#)) + | otherwise -> + let n' = n `shiftR` (I# ld'#) + in case roundingMode# n (ld'# -# 1#) of + 0# -> encodeFloat n' (minEx - mantDigs) + 1# -> if fromInteger n' .&. (1 :: Int) == 0 + then encodeFloat n' (minEx-mantDigs) + else encodeFloat (n' + 1) (minEx-mantDigs) + _ -> encodeFloat (n' + 1) (minEx-mantDigs) + | otherwise -> + let ln = I# (integerLog2# n) + ld = I# ld# + p0 = max minEx (ln - ld) + (n', d') + | p0 < mantDigs = (n `shiftL` (mantDigs - p0), d) + | p0 == mantDigs = (n, d) + | otherwise = (n, d `shiftL` (p0 - mantDigs)) + scale p a b + | p <= minEx-mantDigs = (p,a,b) + | a < (b `shiftL` (mantDigs-1)) = (p-1, a `shiftL` 1, b) + | (b `shiftL` mantDigs) <= a = (p+1, a, b `shiftL` 1) + | otherwise = (p, a, b) + (p', n'', d'') = scale (p0-mantDigs) n' d' + rdq = case n'' `quotRem` d'' of + (q,r) -> case compare (r `shiftL` 1) d'' of + LT -> q + EQ -> if fromInteger q .&. (1 :: Int) == 0 + then q else q+1 + GT -> q+1 + in encodeFloat rdq p' \end{code} @@ -831,12 +973,6 @@ neFloat (F# x) (F# y) = neFloat# x y ltFloat (F# x) (F# y) = ltFloat# x y leFloat (F# x) (F# y) = leFloat# x y -float2Int :: Float -> Int -float2Int (F# x) = I# (float2Int# x) - -int2Float :: Int -> Float -int2Float (I# x) = F# (int2Float# x) - expFloat, logFloat, sqrtFloat :: Float -> Float sinFloat, cosFloat, tanFloat :: Float -> Float asinFloat, acosFloat, atanFloat :: Float -> Float @@ -877,12 +1013,6 @@ neDouble (D# x) (D# y) = x /=## y ltDouble (D# x) (D# y) = x <## y leDouble (D# x) (D# y) = x <=## y -double2Int :: Double -> Int -double2Int (D# x) = I# (double2Int# x) - -int2Double :: Int -> Double -int2Double (I# x) = D# (int2Double# x) - double2Float :: Double -> Float double2Float (D# x) = F# (double2Float# x) @@ -911,21 +1041,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 +1067,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} @@ -966,3 +1126,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}