ghc/lib/prelude/IFloat.hs

   1 module PreludeCore ( Float(..) ) 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             ( (++), 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 plusFloat   (F# x) (F# y) = F# (plusFloat# x y)
  21 minusFloat  (F# x) (F# y) = F# (minusFloat# x y)
  22 timesFloat  (F# x) (F# y) = F# (timesFloat# x y)
  23 divideFloat (F# x) (F# y) = F# (divideFloat# x y)
  24 negateFloat (F# x)        = F# (negateFloat# x)
  25
  26 gtFloat     (F# x) (F# y) = gtFloat# x y
  27 geFloat     (F# x) (F# y) = geFloat# x y
  28 eqFloat     (F# x) (F# y) = eqFloat# x y
  29 neFloat     (F# x) (F# y) = neFloat# x y
  30 ltFloat     (F# x) (F# y) = ltFloat# x y
  31 leFloat     (F# x) (F# y) = leFloat# x y
  32
  33 float2Int   (F# x) = I# (float2Int# x)
  34 int2Float   (I# x) = F# (int2Float# x)
  35
  36 expFloat    (F# x) = F# (expFloat# x)
  37 logFloat    (F# x) = F# (logFloat# x)
  38 sqrtFloat   (F# x) = F# (sqrtFloat# x)
  39 sinFloat    (F# x) = F# (sinFloat# x)
  40 cosFloat    (F# x) = F# (cosFloat# x)
  41 tanFloat    (F# x) = F# (tanFloat# x)
  42 asinFloat   (F# x) = F# (asinFloat# x)
  43 acosFloat   (F# x) = F# (acosFloat# x)
  44 atanFloat   (F# x) = F# (atanFloat# x)
  45 sinhFloat   (F# x) = F# (sinhFloat# x)
  46 coshFloat   (F# x) = F# (coshFloat# x)
  47 tanhFloat   (F# x) = F# (tanhFloat# x)
  48
  49 powerFloat  (F# x) (F# y) = F# (powerFloat# x y)
  50
  51 ---------------------------------------------------------------
  52
  53 instance  Eq Float  where
  54     (==) x y = eqFloat x y
  55     (/=) x y = neFloat x y
  56
  57 instance  Ord Float  where
  58     (<=) x y = leFloat x y
  59     (<)  x y = ltFloat x y
  60     (>=) x y = geFloat x y
  61     (>)  x y = gtFloat x y
  62
  63     max a b = case _tagCmp a b of { _LT -> b; _EQ -> a;  _GT -> a }
  64     min a b = case _tagCmp a b of { _LT -> a; _EQ -> a;  _GT -> b }
  65
  66     _tagCmp (F# a#) (F# b#)
  67       = if      (eqFloat# a# b#) then _EQ
  68         else if (ltFloat# a# b#) then _LT else _GT
  69
  70 instance  Num Float  where
  71     (+)         x y     =  plusFloat x y
  72     (-)         x y     =  minusFloat x y
  73     negate      x       =  negateFloat x
  74     (*)         x y     =  timesFloat x y
  75     abs x | x >= 0.0    =  x
  76           | otherwise   =  negateFloat x
  77     signum x | x == 0.0  =  0
  78              | x > 0.0   =  1
  79              | otherwise = -1
  80     fromInteger n       =  encodeFloat n 0
  81     fromInt i           =  int2Float i
  82
  83 instance  Real Float  where
  84     toRational x        =  (m%__i1)*(b%__i1)^^n
  85                            where (m,n) = decodeFloat x
  86                                  b     = floatRadix  x
  87
  88 instance  Fractional Float  where
  89     (/) x y             =  divideFloat x y
  90     fromRational x      =  _fromRational x
  91     recip x             =  1.0 / x
  92
  93 instance  Floating Float  where
  94     pi                  =  3.141592653589793238
  95     exp x               =  expFloat x
  96     log x               =  logFloat x
  97     sqrt x              =  sqrtFloat x
  98     sin x               =  sinFloat x
  99     cos x               =  cosFloat x
 100     tan x               =  tanFloat x
 101     asin x              =  asinFloat x
 102     acos x              =  acosFloat x
 103     atan x              =  atanFloat x
 104     sinh x              =  sinhFloat x
 105     cosh x              =  coshFloat x
 106     tanh x              =  tanhFloat x
 107     (**) x y            =  powerFloat x y
 108     logBase x y         =  log y / log x
 109
 110     asinh x = log (x + sqrt (1.0+x*x))
 111     acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
 112     atanh x = log ((x+1.0) / sqrt (1.0-x*x))
 113
 114 instance  RealFrac Float  where
 115
 116     {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}
 117     {-# SPECIALIZE truncate :: Float -> Int #-}
 118     {-# SPECIALIZE round    :: Float -> Int #-}
 119     {-# SPECIALIZE ceiling  :: Float -> Int #-}
 120     {-# SPECIALIZE floor    :: Float -> Int #-}
 121
 122     {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
 123     {-# SPECIALIZE truncate :: Float -> Integer #-}
 124     {-# SPECIALIZE round    :: Float -> Integer #-}
 125     {-# SPECIALIZE ceiling  :: Float -> Integer #-}
 126     {-# SPECIALIZE floor    :: Float -> Integer #-}
 127
 128     properFraction x
 129       = case (decodeFloat x)      of { (m,n) ->
 130         let  b = floatRadix x     in
 131         if n >= 0 then
 132             (fromInteger m * fromInteger b ^ n, 0.0)
 133         else
 134             case (quotRem m (b^(-n))) of { (w,r) ->
 135             (fromInteger w, encodeFloat r n)
 136             }
 137         }
 138
 139     truncate x  = case properFraction x of
 140                      (n,_) -> n
 141
 142     round x     = case properFraction x of
 143                      (n,r) -> let
 144                                 m         = if r < 0.0 then n - __i1 else n + __i1
 145                                 half_down = abs r - 0.5
 146                               in
 147                               case (_tagCmp half_down 0.0) of
 148                                 _LT -> n
 149                                 _EQ -> if even n then n else m
 150                                 _GT -> m
 151
 152     ceiling x   = case properFraction x of
 153                     (n,r) -> if r > 0.0 then n + __i1 else n
 154
 155     floor x     = case properFraction x of
 156                     (n,r) -> if r < 0.0 then n - __i1 else n
 157
 158 instance  RealFloat Float  where
 159     floatRadix _        =  FLT_RADIX        -- from float.h
 160     floatDigits _       =  FLT_MANT_DIG     -- ditto
 161     floatRange _        =  (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
 162
 163     decodeFloat (F# f#)
 164       = case decodeFloat# f#    of
 165           _ReturnIntAndGMP exp# a# s# d# ->
 166             (J# a# s# d#, I# exp#)
 167
 168     encodeFloat (J# a# s# d#) (I# e#)
 169       = case encodeFloat# a# s# d# e# of { flt# -> F# flt# }
 170
 171     exponent x          = case decodeFloat x of
 172                             (m,n) -> if m == __i0 then 0 else n + floatDigits x
 173
 174     significand x       = case decodeFloat x of
 175                             (m,_) -> encodeFloat m (- (floatDigits x))
 176
 177     scaleFloat k x      = case decodeFloat x of
 178                             (m,n) -> encodeFloat m (n+k)
 179
 180 instance  Enum Float  where
 181     enumFrom x           =  x : enumFrom (x `plusFloat` 1.0)
 182     enumFromThen m n     =  en' m (n `minusFloat` m)
 183                             where en' m n = m : en' (m `plusFloat` n) n
 184     enumFromTo n m       =  takeWhile (<= m) (enumFrom n)
 185     enumFromThenTo n m p =  takeWhile (if m >= n then (<= p) else (>= p))
 186                                       (enumFromThen n m)
 187
 188 instance  Text Float  where
 189     readsPrec p x = readSigned readFloat x
 190     showsPrec   x = showSigned showFloat x
 191     readList = _readList (readsPrec 0)
 192     showList = _showList (showsPrec 0)
 193
 194 ---------------------------------------------------------------
 195 instance _CCallable   Float
 196 instance _CReturnable Float