import PrelBase
import PrelGHC
+import PrelEnum
+import PrelShow
import PrelNum
-import {-# SOURCE #-} PrelErr ( error )
+import PrelErr ( error )
import PrelList
import PrelMaybe
import Maybe ( fromMaybe )
signum x | x == 0.0 = 0
| x > 0.0 = 1
| otherwise = negate 1
+
+ {-# INLINE fromInteger #-}
fromInteger n = encodeFloat n 0
+ -- It's important that encodeFloat inlines here, and that
+ -- fromInteger in turn inlines,
+ -- so that if fromInteger is applied to an (S# i) the right thing happens
+
+ {-# INLINE fromInt #-}
fromInt i = int2Float i
instance Real Float where
floor x = case properFraction x of
(n,r) -> if r < 0.0 then n - 1 else n
+foreign import ccall "__encodeFloat" unsafe
+ encodeFloat# :: Int# -> ByteArray# -> Int -> Float
+foreign import ccall "__int_encodeFloat" unsafe
+ int_encodeFloat# :: Int# -> Int -> Float
+
+
+foreign import ccall "isFloatNaN" unsafe isFloatNaN :: Float -> Int
+foreign import ccall "isFloatInfinite" unsafe isFloatInfinite :: Float -> Int
+foreign import ccall "isFloatDenormalized" unsafe isFloatDenormalized :: Float -> Int
+foreign import ccall "isFloatNegativeZero" unsafe isFloatNegativeZero :: Float -> Int
+
instance RealFloat Float where
floatRadix _ = FLT_RADIX -- from float.h
floatDigits _ = FLT_MANT_DIG -- ditto
decodeFloat (F# f#)
= case decodeFloat# f# of
- (# exp#, a#, s#, d# #) -> (J# a# s# d#, I# exp#)
+ (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
- encodeFloat (J# a# s# d#) (I# e#)
- = case encodeFloat# a# s# d# e# of { flt# -> F# flt# }
+ encodeFloat (S# i) j = int_encodeFloat# i j
+ encodeFloat (J# s# d#) e = encodeFloat# s# d# e
exponent x = case decodeFloat x of
(m,n) -> if m == 0 then 0 else n + floatDigits x
scaleFloat k x = case decodeFloat x of
(m,n) -> encodeFloat m (n+k)
- isNaN x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatNaN x) {- a _pure_function! -}
- isInfinite x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatInfinite x) {- ditto! -}
- isDenormalized x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatDenormalized x) -- ..
- isNegativeZero x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatNegativeZero x) -- ...
- isIEEE _ = True
+ isNaN x = 0 /= isFloatNaN x
+ isInfinite x = 0 /= isFloatInfinite x
+ isDenormalized x = 0 /= isFloatDenormalized x
+ isNegativeZero x = 0 /= isFloatNegativeZero x
+ isIEEE _ = True
\end{code}
%*********************************************************
signum x | x == 0.0 = 0
| x > 0.0 = 1
| otherwise = negate 1
+
+ {-# INLINE fromInteger #-}
+ -- See comments with Num Float
fromInteger n = encodeFloat n 0
fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# }
{-# SPECIALIZE ceiling :: Double -> Integer #-}
{-# SPECIALIZE floor :: Double -> Integer #-}
-#if defined(__UNBOXED_INSTANCES__)
- {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-}
- {-# SPECIALIZE truncate :: Double -> Int# #-}
- {-# SPECIALIZE round :: Double -> Int# #-}
- {-# SPECIALIZE ceiling :: Double -> Int# #-}
- {-# SPECIALIZE floor :: Double -> Int# #-}
-#endif
-
properFraction x
= case (decodeFloat x) of { (m,n) ->
let b = floatRadix x in
floor x = case properFraction x of
(n,r) -> if r < 0.0 then n - 1 else n
+foreign import ccall "__encodeDouble" unsafe
+ encodeDouble# :: Int# -> ByteArray# -> Int -> Double
+foreign import ccall "__int_encodeDouble" unsafe
+ int_encodeDouble# :: Int# -> Int -> Double
+
+foreign import ccall "isDoubleNaN" unsafe isDoubleNaN :: Double -> Int
+foreign import ccall "isDoubleInfinite" unsafe isDoubleInfinite :: Double -> Int
+foreign import ccall "isDoubleDenormalized" unsafe isDoubleDenormalized :: Double -> Int
+foreign import ccall "isDoubleNegativeZero" unsafe isDoubleNegativeZero :: Double -> Int
+
instance RealFloat Double where
floatRadix _ = FLT_RADIX -- from float.h
floatDigits _ = DBL_MANT_DIG -- ditto
decodeFloat (D# x#)
= case decodeDouble# x# of
- (# exp#, a#, s#, d# #) -> (J# a# s# d#, I# exp#)
+ (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
- encodeFloat (J# a# s# d#) (I# e#)
- = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# }
+ encodeFloat (S# i) j = int_encodeDouble# i j
+ encodeFloat (J# s# d#) e = encodeDouble# s# d# e
exponent x = case decodeFloat x of
(m,n) -> if m == 0 then 0 else n + floatDigits x
scaleFloat k x = case decodeFloat x of
(m,n) -> encodeFloat m (n+k)
- isNaN x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleNaN x) {- a _pure_function! -}
- isInfinite x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleInfinite x) {- ditto -}
- isDenormalized x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleDenormalized x) -- ..
- isNegativeZero x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleNegativeZero x) -- ...
- isIEEE _ = True
+
+ isNaN x = 0 /= isDoubleNaN x
+ isInfinite x = 0 /= isDoubleInfinite x
+ isDenormalized x = 0 /= isDoubleDenormalized x
+ isNegativeZero x = 0 /= isDoubleNegativeZero x
+ isIEEE _ = True
instance Show Double where
showsPrec x = showSigned showFloat x
%*********************************************************
\begin{code}
-{- SPECIALIZE fromIntegral ::
+{-# SPECIALIZE fromIntegral ::
Int -> Rational,
Integer -> Rational,
Int -> Int,
fromIntegral :: (Integral a, Num b) => a -> b
fromIntegral = fromInteger . toInteger
-{- SPECIALIZE realToFrac ::
+{-# SPECIALIZE realToFrac ::
Double -> Rational,
Rational -> Double,
Float -> Rational,
s@(h:t) = show ((round (r * 10^n))::Integer)
e = e0+1
+#ifdef USE_REPORT_PRELUDE
+ takeN n ls rs = take n ls ++ rs
+#else
takeN (I# n#) ls rs = takeUInt_append n# ls rs
+#endif
drop0 :: String -> String -> String
drop0 [] rs = rs
Lennart's code follows, and it works...
\begin{pseudocode}
-{-# SPECIALISE fromRat ::
- Rational -> Double,
- Rational -> Float #-}
fromRat :: (RealFloat a) => Rational -> a
fromRat x = x'
where x' = f e
Now, here's Lennart's code.
\begin{code}
+{-# SPECIALISE fromRat ::
+ Rational -> Double,
+ Rational -> Float #-}
fromRat :: (RealFloat a) => Rational -> a
fromRat x
| x == 0 = encodeFloat 0 0 -- Handle exceptional cases
-- These are the format types. This type is not exported.
-data FFFormat = FFExponent | FFFixed | FFGeneric --no need: deriving (Eq, Ord, Show)
+data FFFormat = FFExponent | FFFixed | FFGeneric
formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
formatRealFloat fmt decs x
projects / ghc-hetmet.git / blobdiff