ghc/lib/prelude/IDouble.hs

   1 module PreludeCore ( Double(..) ) where
   2
   3 #include "../includes/ieee-flpt.h"
   4
   5 import Cls
   6 import Core
   7 import IInt
   8 import IInteger
   9 import IRatio
  10 import List             ( (++), map, takeWhile )
  11 import Prel             ( (^), (^^), otherwise )
  12 import PS               ( _PackedString, _unpackPS )
  13 import Text
  14 import TyArray
  15 import TyComplex
  16
  17 -- definitions of the boxed PrimOps; these will be
  18 -- used in the case of partial applications, etc.
  19
  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)
  25
  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
  32
  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)
  37
  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)
  50
  51 powerDouble  (D# x) (D# y) = D# (powerDouble# x y)
  52
  53 ---------------------------------------------------------------
  54
  55 instance  Eq Double  where
  56     (==) x y = eqDouble x y
  57     (/=) x y = neDouble x y
  58
  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
  64
  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 }
  67
  68     _tagCmp (D# a#) (D# b#)
  69       = if      (eqDouble# a# b#) then _EQ
  70         else if (ltDouble# a# b#) then _LT else _GT
  71
  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
  77     abs x | x >= 0.0    =  x
  78           | otherwise   =  negateDouble x
  79     signum x | x == 0.0  =  0
  80              | x > 0.0   =  1
  81              | otherwise = -1
  82     fromInteger n       =  encodeFloat n 0
  83     fromInt (I# n#)     =  case (int2Double# n#) of { d# -> D# d# }
  84
  85 instance  Real Double  where
  86     toRational x        =  (m%__i1)*(b%__i1)^^n
  87                            where (m,n) = decodeFloat x
  88                                  b     = floatRadix  x
  89
  90 instance  Fractional Double  where
  91     (/) x y             =  divideDouble x y
  92     fromRational x      =  _fromRational x
  93     recip x             =  1.0 / x
  94
  95 instance  Floating Double  where
  96     pi                  =  3.141592653589793238
  97     exp x               =  expDouble x
  98     log x               =  logDouble x
  99     sqrt x              =  sqrtDouble x
 100     sin  x              =  sinDouble x
 101     cos  x              =  cosDouble x
 102     tan  x              =  tanDouble x
 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
 111
 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))
 115
 116 instance  RealFrac Double  where
 117
 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 #-}
 123
 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 #-}
 129
 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# #-}
 136 #endif
 137
 138     properFraction x
 139       = case (decodeFloat x)      of { (m,n) ->
 140         let  b = floatRadix x     in
 141         if n >= 0 then
 142             (fromInteger m * fromInteger b ^ n, 0.0)
 143         else
 144             case (quotRem m (b^(-n))) of { (w,r) ->
 145             (fromInteger w, encodeFloat r n)
 146             }
 147         }
 148
 149     truncate x  = case properFraction x of
 150                      (n,_) -> n
 151
 152     round x     = case properFraction x of
 153                      (n,r) -> let
 154                                 m         = if r < 0.0 then n - __i1 else n + __i1
 155                                 half_down = abs r - 0.5
 156                               in
 157                               case (_tagCmp half_down 0.0) of
 158                                 _LT -> n
 159                                 _EQ -> if even n then n else m
 160                                 _GT -> m
 161
 162     ceiling x   = case properFraction x of
 163                     (n,r) -> if r > 0.0 then n + __i1 else n
 164
 165     floor x     = case properFraction x of
 166                     (n,r) -> if r < 0.0 then n - __i1 else n
 167
 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
 172
 173     decodeFloat (D# d#)
 174       = case decodeDouble# d#   of
 175           _ReturnIntAndGMP exp# a# s# d# ->
 176             (J# a# s# d#, I# exp#)
 177
 178     encodeFloat (J# a# s# d#) (I# e#)
 179       = case encodeDouble# a# s# d# e#  of { dbl# -> D# dbl# }
 180
 181     exponent x          = case decodeFloat x of
 182                             (m,n) -> if m == __i0 then 0 else n + floatDigits x
 183
 184     significand x       = case decodeFloat x of
 185                             (m,_) -> encodeFloat m (- (floatDigits x))
 186
 187     scaleFloat k x      = case decodeFloat x of
 188                             (m,n) -> encodeFloat m (n+k)
 189
 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))
 196                                      (enumFromThen n m)
 197
 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)
 203
 204 instance _CCallable   Double
 205 instance _CReturnable Double
 206
 207 #if defined(__UNBOXED_INSTANCES__)
 208 ---------------------------------------------------------------
 209 -- Instances for Double#
 210 ---------------------------------------------------------------
 211
 212 instance  Eq Double#  where
 213     (==) x y = eqDouble# x y
 214     (/=) x y = neDouble# x y
 215
 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
 221
 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 }
 224
 225     _tagCmp a b
 226       = if      (eqDouble# a b) then _EQ
 227         else if (ltDouble# a b) then _LT else _GT
 228
 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
 234     abs x | x >= 0.0    =  x
 235           | otherwise   =  negateDouble# x
 236     signum x | x == 0.0  =  0
 237              | x > 0.0   =  1
 238              | otherwise = -1
 239     fromInteger n       =  encodeFloat n 0
 240     fromInt (I# n#)     =  int2Double# n#
 241
 242 instance  Real Double#  where
 243     toRational x        =  (m%__i1)*(b%__i1)^^n
 244                            where (m,n) = decodeFloat x
 245                                  b     = floatRadix  x
 246
 247 instance  Fractional Double#  where
 248     (/) x y             =  divideDouble# x y
 249     fromRational x      =  _fromRational x
 250     recip x             =  1.0 / x
 251
 252 instance  Floating Double#  where
 253     pi                  =  3.141592653589793238##
 254     exp x               =  expDouble# x
 255     log x               =  logDouble# x
 256     sqrt x              =  sqrtDouble# x
 257     sin  x              =  sinDouble# x
 258     cos  x              =  cosDouble# x
 259     tan  x              =  tanDouble# 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
 268
 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))
 272
 273
 274 instance  RealFrac Double#  where
 275
 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 #-}
 281
 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 #-}
 287
 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# #-}
 293
 294     properFraction x
 295       = case (decodeFloat x)      of { (m,n) ->
 296         let  b = floatRadix x     in
 297         if n >= 0 then
 298             (fromInteger m * fromInteger b ^ n, 0.0)
 299         else
 300             case (quotRem m (b^(-n))) of { (w,r) ->
 301             (fromInteger w, encodeFloat r n)
 302             }
 303         }
 304
 305     truncate x  = case properFraction x of
 306                      (n,_) -> n
 307
 308     round x     = case properFraction x of
 309                      (n,r) -> let
 310                                 m         = if r < 0.0 then n - __i1 else n + __i1
 311                                 half_down = abs r - 0.5
 312                               in
 313                               case (_tagCmp half_down 0.0) of
 314                                 _LT -> n
 315                                 _EQ -> if even n then n else m
 316                                 _GT -> m
 317
 318     ceiling x   = case properFraction x of
 319                     (n,r) -> if r > 0.0 then n + __i1 else n
 320
 321     floor x     = case properFraction x of
 322                     (n,r) -> if r < 0.0 then n - __i1 else n
 323
 324
 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
 329
 330     decodeFloat d#
 331       = case decodeDouble# d#   of
 332           _ReturnIntAndGMP exp# a# s# d# ->
 333             (J# a# s# d#, I# exp#)
 334
 335     encodeFloat (J# a# s# d#) (I# e#)
 336       = encodeDouble# a# s# d# e#
 337
 338     exponent x          = case decodeFloat x of
 339                             (m,n) -> if m == __i0 then 0 else n + floatDigits x
 340
 341     significand x       = case decodeFloat x of
 342                             (m,_) -> encodeFloat m (- (floatDigits x))
 343
 344     scaleFloat k x      = case decodeFloat x of
 345                             (m,n) -> encodeFloat m (n+k)
 346
 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))
 353                                       (enumFromThen n m)
 354
 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)
 361
 362 instance _CCallable   Double#
 363 instance _CReturnable Double#
 364
 365 #endif {-UNBOXED INSTANCES-}