1 module PreludeCore ( Double(..) ) where
3 #include "../includes/ieee-flpt.h"
10 import List ( (++), map, takeWhile )
11 import Prel ( (^), (^^), otherwise )
12 import PS ( _PackedString, _unpackPS )
17 -- definitions of the boxed PrimOps; these will be
18 -- used in the case of partial applications, etc.
20 plusDouble (D# x) (D# y) = D# (plusDouble# x y)
21 minusDouble (D# x) (D# y) = D# (minusDouble# x y)
22 timesDouble (D# x) (D# y) = D# (timesDouble# x y)
23 divideDouble (D# x) (D# y) = D# (divideDouble# x y)
24 negateDouble (D# x) = D# (negateDouble# x)
26 gtDouble (D# x) (D# y) = gtDouble# x y
27 geDouble (D# x) (D# y) = geDouble# x y
28 eqDouble (D# x) (D# y) = eqDouble# x y
29 neDouble (D# x) (D# y) = neDouble# x y
30 ltDouble (D# x) (D# y) = ltDouble# x y
31 leDouble (D# x) (D# y) = leDouble# x y
33 double2Int (D# x) = I# (double2Int# x)
34 int2Double (I# x) = D# (int2Double# x)
35 double2Float (D# x) = F# (double2Float# x)
36 float2Double (F# x) = D# (float2Double# x)
38 expDouble (D# x) = D# (expDouble# x)
39 logDouble (D# x) = D# (logDouble# x)
40 sqrtDouble (D# x) = D# (sqrtDouble# x)
41 sinDouble (D# x) = D# (sinDouble# x)
42 cosDouble (D# x) = D# (cosDouble# x)
43 tanDouble (D# x) = D# (tanDouble# x)
44 asinDouble (D# x) = D# (asinDouble# x)
45 acosDouble (D# x) = D# (acosDouble# x)
46 atanDouble (D# x) = D# (atanDouble# x)
47 sinhDouble (D# x) = D# (sinhDouble# x)
48 coshDouble (D# x) = D# (coshDouble# x)
49 tanhDouble (D# x) = D# (tanhDouble# x)
51 powerDouble (D# x) (D# y) = D# (powerDouble# x y)
53 ---------------------------------------------------------------
55 instance Eq Double where
56 (==) x y = eqDouble x y
57 (/=) x y = neDouble x y
59 instance Ord Double where
60 (<=) x y = leDouble x y
61 (<) x y = ltDouble x y
62 (>=) x y = geDouble x y
63 (>) x y = gtDouble x y
65 max a b = case _tagCmp a b of { _LT -> b; _EQ -> a; _GT -> a }
66 min a b = case _tagCmp a b of { _LT -> a; _EQ -> a; _GT -> b }
68 _tagCmp (D# a#) (D# b#)
69 = if (eqDouble# a# b#) then _EQ
70 else if (ltDouble# a# b#) then _LT else _GT
72 instance Num Double where
73 (+) x y = plusDouble x y
74 (-) x y = minusDouble x y
75 negate x = negateDouble x
76 (*) x y = timesDouble x y
78 | otherwise = negateDouble x
79 signum x | x == 0.0 = 0
82 fromInteger n = encodeFloat n 0
83 fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# }
85 instance Real Double where
86 toRational x = (m%__i1)*(b%__i1)^^n
87 where (m,n) = decodeFloat x
90 instance Fractional Double where
91 (/) x y = divideDouble x y
92 fromRational x = _fromRational x
95 instance Floating Double where
96 pi = 3.141592653589793238
103 asin x = asinDouble x
104 acos x = acosDouble x
105 atan x = atanDouble x
106 sinh x = sinhDouble x
107 cosh x = coshDouble x
108 tanh x = tanhDouble x
109 (**) x y = powerDouble x y
110 logBase x y = log y / log x
112 asinh x = log (x + sqrt (1.0+x*x))
113 acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
114 atanh x = log ((x+1.0) / sqrt (1.0-x*x))
116 instance RealFrac Double where
118 {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}
119 {-# SPECIALIZE truncate :: Double -> Int #-}
120 {-# SPECIALIZE round :: Double -> Int #-}
121 {-# SPECIALIZE ceiling :: Double -> Int #-}
122 {-# SPECIALIZE floor :: Double -> Int #-}
124 {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
125 {-# SPECIALIZE truncate :: Double -> Integer #-}
126 {-# SPECIALIZE round :: Double -> Integer #-}
127 {-# SPECIALIZE ceiling :: Double -> Integer #-}
128 {-# SPECIALIZE floor :: Double -> Integer #-}
130 #if defined(__UNBOXED_INSTANCES__)
131 {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-}
132 {-# SPECIALIZE truncate :: Double -> Int# #-}
133 {-# SPECIALIZE round :: Double -> Int# #-}
134 {-# SPECIALIZE ceiling :: Double -> Int# #-}
135 {-# SPECIALIZE floor :: Double -> Int# #-}
139 = case (decodeFloat x) of { (m,n) ->
140 let b = floatRadix x in
142 (fromInteger m * fromInteger b ^ n, 0.0)
144 case (quotRem m (b^(-n))) of { (w,r) ->
145 (fromInteger w, encodeFloat r n)
149 truncate x = case properFraction x of
152 round x = case properFraction x of
154 m = if r < 0.0 then n - __i1 else n + __i1
155 half_down = abs r - 0.5
157 case (_tagCmp half_down 0.0) of
159 _EQ -> if even n then n else m
162 ceiling x = case properFraction x of
163 (n,r) -> if r > 0.0 then n + __i1 else n
165 floor x = case properFraction x of
166 (n,r) -> if r < 0.0 then n - __i1 else n
168 instance RealFloat Double where
169 floatRadix _ = FLT_RADIX -- from float.h
170 floatDigits _ = DBL_MANT_DIG -- ditto
171 floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
174 = case decodeDouble# d# of
175 _ReturnIntAndGMP exp# a# s# d# ->
176 (J# a# s# d#, I# exp#)
178 encodeFloat (J# a# s# d#) (I# e#)
179 = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# }
181 exponent x = case decodeFloat x of
182 (m,n) -> if m == __i0 then 0 else n + floatDigits x
184 significand x = case decodeFloat x of
185 (m,_) -> encodeFloat m (- (floatDigits x))
187 scaleFloat k x = case decodeFloat x of
188 (m,n) -> encodeFloat m (n+k)
190 instance Enum Double where
191 enumFrom x = x : enumFrom (x `plusDouble` 1.0)
192 enumFromThen m n = en' m (n `minusDouble` m)
193 where en' m n = m : en' (m `plusDouble` n) n
194 enumFromTo n m = takeWhile (<= m) (enumFrom n)
195 enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
198 instance Text Double where
199 readsPrec p x = readSigned readFloat x
200 showsPrec x = showSigned showFloat x
201 readList = _readList (readsPrec 0)
202 showList = _showList (showsPrec 0)
204 instance _CCallable Double
205 instance _CReturnable Double
207 #if defined(__UNBOXED_INSTANCES__)
208 ---------------------------------------------------------------
209 -- Instances for Double#
210 ---------------------------------------------------------------
212 instance Eq Double# where
213 (==) x y = eqDouble# x y
214 (/=) x y = neDouble# x y
216 instance Ord Double# where
217 (<=) x y = leDouble# x y
218 (<) x y = ltDouble# x y
219 (>=) x y = geDouble# x y
220 (>) x y = gtDouble# x y
222 max a b = case _tagCmp a b of { _LT -> b; _EQ -> a; _GT -> a }
223 min a b = case _tagCmp a b of { _LT -> a; _EQ -> a; _GT -> b }
226 = if (eqDouble# a b) then _EQ
227 else if (ltDouble# a b) then _LT else _GT
229 instance Num Double# where
230 (+) x y = plusDouble# x y
231 (-) x y = minusDouble# x y
232 negate x = negateDouble# x
233 (*) x y = timesDouble# x y
235 | otherwise = negateDouble# x
236 signum x | x == 0.0 = 0
239 fromInteger n = encodeFloat n 0
240 fromInt (I# n#) = int2Double# n#
242 instance Real Double# where
243 toRational x = (m%__i1)*(b%__i1)^^n
244 where (m,n) = decodeFloat x
247 instance Fractional Double# where
248 (/) x y = divideDouble# x y
249 fromRational x = _fromRational x
252 instance Floating Double# where
253 pi = 3.141592653589793238##
256 sqrt x = sqrtDouble# x
260 asin x = asinDouble# x
261 acos x = acosDouble# x
262 atan x = atanDouble# x
263 sinh x = sinhDouble# x
264 cosh x = coshDouble# x
265 tanh x = tanhDouble# x
266 (**) x y = powerDouble# x y
267 logBase x y = log y / log x
269 asinh x = log (x + sqrt (1.0+x*x))
270 acosh x = log (x + (x+1) * sqrt ((x-1.0)/(x+1.0)))
271 atanh x = log ((x+1.0) / sqrt (1.0-x*x))
274 instance RealFrac Double# where
276 {-# SPECIALIZE properFraction :: Double# -> (Int, Double#) #-}
277 {-# SPECIALIZE truncate :: Double# -> Int #-}
278 {-# SPECIALIZE round :: Double# -> Int #-}
279 {-# SPECIALIZE ceiling :: Double# -> Int #-}
280 {-# SPECIALIZE floor :: Double# -> Int #-}
282 {-# SPECIALIZE properFraction :: Double# -> (Integer, Double#) #-}
283 {-# SPECIALIZE truncate :: Double# -> Integer #-}
284 {-# SPECIALIZE round :: Double# -> Integer #-}
285 {-# SPECIALIZE ceiling :: Double# -> Integer #-}
286 {-# SPECIALIZE floor :: Double# -> Integer #-}
288 {-# SPECIALIZE properFraction :: Double# -> (Int#, Double#) #-}
289 {-# SPECIALIZE truncate :: Double# -> Int# #-}
290 {-# SPECIALIZE round :: Double# -> Int# #-}
291 {-# SPECIALIZE ceiling :: Double# -> Int# #-}
292 {-# SPECIALIZE floor :: Double# -> Int# #-}
295 = case (decodeFloat x) of { (m,n) ->
296 let b = floatRadix x in
298 (fromInteger m * fromInteger b ^ n, 0.0)
300 case (quotRem m (b^(-n))) of { (w,r) ->
301 (fromInteger w, encodeFloat r n)
305 truncate x = case properFraction x of
308 round x = case properFraction x of
310 m = if r < 0.0 then n - __i1 else n + __i1
311 half_down = abs r - 0.5
313 case (_tagCmp half_down 0.0) of
315 _EQ -> if even n then n else m
318 ceiling x = case properFraction x of
319 (n,r) -> if r > 0.0 then n + __i1 else n
321 floor x = case properFraction x of
322 (n,r) -> if r < 0.0 then n - __i1 else n
325 instance RealFloat Double# where
326 floatRadix _ = FLT_RADIX -- from float.h
327 floatDigits _ = DBL_MANT_DIG -- ditto
328 floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
331 = case decodeDouble# d# of
332 _ReturnIntAndGMP exp# a# s# d# ->
333 (J# a# s# d#, I# exp#)
335 encodeFloat (J# a# s# d#) (I# e#)
336 = encodeDouble# a# s# d# e#
338 exponent x = case decodeFloat x of
339 (m,n) -> if m == __i0 then 0 else n + floatDigits x
341 significand x = case decodeFloat x of
342 (m,_) -> encodeFloat m (- (floatDigits x))
344 scaleFloat k x = case decodeFloat x of
345 (m,n) -> encodeFloat m (n+k)
347 instance Enum Double# where
348 enumFrom x = x : enumFrom (x `plusDouble#` 1.0)
349 enumFromThen m n = en' m (n `minusDouble#` m)
350 where en' m n = m : en' (m `plusDouble#` n) n
351 enumFromTo n m = takeWhile (<= m) (enumFrom n)
352 enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
355 -- ToDo: efficient Text Double# instance
356 instance Text Double# where
357 readsPrec p s = map (\ (D# d#, s) -> (d#, s)) (readsPrec p s)
358 showsPrec p x = showsPrec p (D# x)
359 readList = _readList (readsPrec 0)
360 showList = _showList (showsPrec 0)
362 instance _CCallable Double#
363 instance _CReturnable Double#
365 #endif {-UNBOXED INSTANCES-}