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             ( (++) )
  11 import Prel             ( (^), (^^), otherwise )
  12 import PS               ( _PackedString, _unpackPS )
  13 import Text
  14 import TyComplex    -- for pragmas only
  15
  16 -- definitions of the boxed PrimOps; these will be
  17 -- used in the case of partial applications, etc.
  18
  19 plusDouble   (D# x) (D# y) = D# (plusDouble# x y)
  20 minusDouble  (D# x) (D# y) = D# (minusDouble# x y)
  21 timesDouble  (D# x) (D# y) = D# (timesDouble# x y)
  22 divideDouble (D# x) (D# y) = D# (divideDouble# x y)
  23 negateDouble (D# x)        = D# (negateDouble# x)
  24
  25 gtDouble    (D# x) (D# y) = gtDouble# x y
  26 geDouble    (D# x) (D# y) = geDouble# x y
  27 eqDouble    (D# x) (D# y) = eqDouble# x y
  28 neDouble    (D# x) (D# y) = neDouble# x y
  29 ltDouble    (D# x) (D# y) = ltDouble# x y
  30 leDouble    (D# x) (D# y) = leDouble# x y
  31
  32 double2Int   (D# x) = I# (double2Int#   x)
  33 int2Double   (I# x) = D# (int2Double#   x)
  34 double2Float (D# x) = F# (double2Float# x)
  35 float2Double (F# x) = D# (float2Double# x)
  36
  37 expDouble    (D# x) = D# (expDouble# x)
  38 logDouble    (D# x) = D# (logDouble# x)
  39 sqrtDouble   (D# x) = D# (sqrtDouble# x)
  40 sinDouble    (D# x) = D# (sinDouble# x)
  41 cosDouble    (D# x) = D# (cosDouble# x)
  42 tanDouble    (D# x) = D# (tanDouble# x)
  43 asinDouble   (D# x) = D# (asinDouble# x)
  44 acosDouble   (D# x) = D# (acosDouble# x)
  45 atanDouble   (D# x) = D# (atanDouble# x)
  46 sinhDouble   (D# x) = D# (sinhDouble# x)
  47 coshDouble   (D# x) = D# (coshDouble# x)
  48 tanhDouble   (D# x) = D# (tanhDouble# x)
  49
  50 powerDouble  (D# x) (D# y) = D# (powerDouble# x y)
  51
  52 ---------------------------------------------------------------
  53
  54 instance  Eq Double  where
  55     (==) x y = eqDouble x y
  56     (/=) x y = neDouble x y
  57
  58 instance  Ord Double  where
  59     (<=) x y = leDouble x y
  60     (<)  x y = ltDouble x y
  61     (>=) x y = geDouble x y
  62     (>)  x y = gtDouble x y
  63
  64     max a b = case _tagCmp a b of { _LT -> b; _EQ -> a;  _GT -> a }
  65     min a b = case _tagCmp a b of { _LT -> a; _EQ -> a;  _GT -> b }
  66
  67     _tagCmp (D# a#) (D# b#)
  68       = if      (eqDouble# a# b#) then _EQ
  69         else if (ltDouble# a# b#) then _LT else _GT
  70
  71 instance  Num Double  where
  72     (+)         x y     =  plusDouble x y
  73     (-)         x y     =  minusDouble x y
  74     negate      x       =  negateDouble x
  75     (*)         x y     =  timesDouble x y
  76     abs x | x >= 0      =  x
  77           | otherwise   =  negateDouble x
  78     signum x | x == 0    =  0
  79              | x > 0     =  1
  80              | otherwise = -1
  81     fromInteger n       =  encodeFloat n 0
  82     fromInt (I# n#)     =  case (int2Double# n#) of { d# -> D# d# }
  83
  84 instance  Real Double  where
  85     toRational x        =  (m%1)*(b%1)^^n -- i.e., realFloatToRational x
  86                            where (m,n) = decodeFloat x
  87                                  b     = floatRadix  x
  88
  89 instance  Fractional Double  where
  90     (/) x y             =  divideDouble x y
  91     fromRational x      =  fromRationalX x --ORIG: rationalToRealFloat x
  92     recip x             =  1 / x
  93
  94 instance  Floating Double  where
  95     pi                  =  3.141592653589793238
  96     exp x               =  expDouble x
  97     log x               =  logDouble x
  98     sqrt x              =  sqrtDouble x
  99     sin  x              =  sinDouble x
 100     cos  x              =  cosDouble x
 101     tan  x              =  tanDouble x
 102     asin x              =  asinDouble x
 103     acos x              =  acosDouble x
 104     atan x              =  atanDouble x
 105     sinh x              =  sinhDouble x
 106     cosh x              =  coshDouble x
 107     tanh x              =  tanhDouble x
 108     (**) x y            =  powerDouble x y
 109     logBase x y         =  log y / log x
 110
 111 {- WAS: but not all machines have these in their math library:
 112     asinh               =  asinhDouble
 113     acosh               =  acoshDouble
 114     atanh               =  atanhDouble
 115 -}
 116     asinh x = log (x + sqrt (1+x*x))
 117     acosh x = log (x + (x+1) * sqrt ((x-1)/(x+1)))
 118     atanh x = log ((x+1) / sqrt (1 - x*x))
 119
 120
 121 instance  RealFrac Double  where
 122     properFraction x = _properFraction x
 123
 124     -- just call the versions in Core.hs
 125     truncate x  =  _truncate x
 126     round x     =  _round x
 127     ceiling x   =  _ceiling x
 128     floor x     =  _floor x
 129 {- OLD:
 130     properFraction x
 131         | n >= 0        =  (fromInteger m * fromInteger b ^ n, 0)
 132         | otherwise     =  (fromInteger w, encodeFloat r n)
 133                         where (m,n) = decodeFloat x
 134                               b     = floatRadix x
 135                               (w,r) = quotRem m (b^(-n))
 136 -}
 137
 138 instance  RealFloat Double  where
 139     floatRadix _        =  FLT_RADIX        -- from float.h
 140     floatDigits _       =  DBL_MANT_DIG     -- ditto
 141     floatRange _        =  (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
 142
 143     decodeFloat (D# d#)
 144       = case decodeDouble# d#   of
 145           _ReturnIntAndGMP exp# a# s# d# ->
 146             (J# a# s# d#, I# exp#)
 147
 148     encodeFloat (J# a# s# d#) (I# e#)
 149       = case encodeDouble# a# s# d# e#  of { dbl# -> D# dbl# }
 150
 151 instance  Enum Double  where
 152 {- *** RAW PRELUDE ***
 153     enumFrom            =  numericEnumFrom
 154     enumFromThen        =  numericEnumFromThen
 155 -}
 156     enumFrom x = x : enumFrom (x `plusDouble` 1.0)
 157     enumFromThen m n = en' m (n `minusDouble` m)
 158             where en' m n = m : en' (m `plusDouble` n) n
 159
 160 instance  Text Double  where
 161     readsPrec p x = readSigned readFloat x
 162     showsPrec   x = showSigned showFloat x
 163
 164 instance _CCallable   Double
 165 instance _CReturnable Double
 166
 167 #if defined(__UNBOXED_INSTANCES__)
 168 ---------------------------------------------------------------
 169 -- Instances for Double#
 170 ---------------------------------------------------------------
 171
 172 instance  Eq Double#  where
 173     (==) x y = eqDouble# x y
 174     (/=) x y = neDouble# x y
 175
 176 instance  Ord Double#  where
 177     (<=) x y = leDouble# x y
 178     (<)  x y = ltDouble# x y
 179     (>=) x y = geDouble# x y
 180     (>)  x y = gtDouble# x y
 181
 182     max a b = case _tagCmp a b of { _LT -> b; _EQ -> a;  _GT -> a }
 183     min a b = case _tagCmp a b of { _LT -> a; _EQ -> a;  _GT -> b }
 184
 185     _tagCmp a b
 186       = if      (eqDouble# a b) then _EQ
 187         else if (ltDouble# a b) then _LT else _GT
 188
 189 instance  Num Double#  where
 190     (+)         x y     =  plusDouble# x y
 191     (-)         x y     =  minusDouble# x y
 192     negate      x       =  negateDouble# x
 193     (*)         x y     =  timesDouble# x y
 194     abs x | x >= 0      =  x
 195           | otherwise   =  negateDouble# x
 196     signum x | x == 0    =  0
 197              | x > 0     =  1
 198              | otherwise = -1
 199     fromInteger n       =  encodeFloat n 0
 200     fromInt (I# n#)     =  int2Double# n#
 201
 202 instance  Real Double#  where
 203     toRational x        =  (m%1)*(b%1)^^n -- i.e., realFloatToRational x
 204                            where (m,n) = decodeFloat x
 205                                  b     = floatRadix  x
 206
 207 instance  Fractional Double#  where
 208     (/) x y             =  divideDouble# x y
 209     fromRational x      =  _fromRational x --ORIG: rationalToRealFloat x
 210     recip x             =  1 / x
 211
 212 instance  Floating Double#  where
 213     pi                  =  3.141592653589793238##
 214     exp x               =  expDouble# x
 215     log x               =  logDouble# x
 216     sqrt x              =  sqrtDouble# x
 217     sin  x              =  sinDouble# x
 218     cos  x              =  cosDouble# x
 219     tan  x              =  tanDouble# x
 220     asin x              =  asinDouble# x
 221     acos x              =  acosDouble# x
 222     atan x              =  atanDouble# x
 223     sinh x              =  sinhDouble# x
 224     cosh x              =  coshDouble# x
 225     tanh x              =  tanhDouble# x
 226     (**) x y            =  powerDouble# x y
 227     logBase x y         =  log y / log x
 228
 229 {- WAS: but not all machines have these in their math library:
 230     asinh               =  asinhDouble#
 231     acosh               =  acoshDouble#
 232     atanh               =  atanhDouble#
 233 -}
 234     asinh x = log (x + sqrt (1+x*x))
 235     acosh x = log (x + (x+1) * sqrt ((x-1)/(x+1)))
 236     atanh x = log ((x+1) / sqrt (1 - x*x))
 237
 238
 239 instance  RealFrac Double#  where
 240     -- REPORT:
 241     -- properFraction = floatProperFraction
 242
 243     properFraction x
 244         | n >= 0        =  (fromInteger m * fromInteger b ^ n, 0)
 245         | otherwise     =  (fromInteger w, encodeFloat r n)
 246                         where (m,n) = decodeFloat x
 247                               b     = floatRadix x
 248                               (w,r) = quotRem m (b^(-n))
 249
 250     -- No default methods for unboxed values ...
 251     -- just call the versions in Core.hs
 252     truncate x  =  _truncate x
 253     round x     =  _round x
 254     ceiling x   =  _ceiling x
 255     floor x     =  _floor x
 256
 257 instance  RealFloat Double#  where
 258     floatRadix _        =  FLT_RADIX        -- from float.h
 259     floatDigits _       =  DBL_MANT_DIG     -- ditto
 260     floatRange _        =  (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
 261
 262     decodeFloat d#
 263       = case decodeDouble# d#   of
 264           _ReturnIntAndGMP exp# a# s# d# ->
 265             (J# a# s# d#, I# exp#)
 266
 267     encodeFloat (J# a# s# d#) (I# e#)
 268       = encodeDouble# a# s# d# e#
 269
 270     -- No default methods for unboxed values ...
 271     exponent x          =  if m == 0 then 0 else n + floatDigits x
 272                            where (m,n) = decodeFloat x
 273
 274     significand x       =  encodeFloat m (- (floatDigits x))
 275                            where (m,_) = decodeFloat x
 276
 277     scaleFloat k x      =  encodeFloat m (n+k)
 278                            where (m,n) = decodeFloat x
 279
 280 instance  Enum Double#  where
 281     enumFrom x           =  x : enumFrom (x `plusDouble#` 1.0##)
 282     enumFromThen m n     =  en' m (n `minusDouble#` m)
 283                             where en' m n = m : en' (m `plusDouble#` n) n
 284     -- default methods not specialised!
 285     enumFromTo n m       =  takeWhile (<= m) (enumFrom n)
 286     enumFromThenTo n m p =  takeWhile (if m >= n then (<= p) else (>= p))
 287                                       (enumFromThen n m)
 288
 289 -- ToDo: efficient Text Double# instance
 290 instance  Text Double#  where
 291     readsPrec p s = map (\ (D# d#, s) -> (d#, s)) (readsPrec p s)
 292     showsPrec p x = showsPrec p (D# x)
 293     readList s = map (\ (x, s) -> (map (\ (D# d#) -> d#) x, s)) (readList s)
 294     showList l = showList (map D# l)
 295
 296 instance _CCallable   Double#
 297 instance _CReturnable Double#
 298
 299 #endif {-UNBOXED INSTANCES-}