mlton/atoms/real-x.fun

   1 (* Copyright (C) 2009,2011-2012 Matthew Fluet.
   2  * Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor RealX (S: REAL_X_STRUCTS): REAL_X =
  10 struct
  11
  12 open S
  13
  14 structure P = Pervasive
  15 structure PR32 = P.Real32
  16 structure PR64 = P.Real64
  17 structure PIR = P.IEEEReal
  18
  19 datatype z = datatype RealSize.t
  20
  21 datatype t =
  22    Real32 of Real32.t
  23  | Real64 of Real64.t
  24
  25 fun zero s =
  26    case s of
  27       R32 => Real32 0.0
  28     | R64 => Real64 0.0
  29
  30 fun size r =
  31    case r of
  32       Real32 _ => R32
  33     | Real64 _ => R64
  34
  35 fun make (r: string, s: RealSize.t): t option =
  36    let
  37       fun doit (fromString, isFinite, con): t option =
  38          case fromString r of
  39             NONE => Error.bug "RealX.make: unexpected real constant"
  40           | SOME r =>
  41                if isFinite r
  42                   then SOME (con r)
  43                else NONE
  44    in
  45       case s of
  46          R32 => doit (Real32.fromString, Real32.isFinite, Real32)
  47        | R64 => doit (Real64.fromString, Real64.isFinite, Real64)
  48    end
  49
  50 (* RealX.equals determines if two floating-point constants are equal.
  51  * Must check the sign bit, since Real{32,64}.== ignores the sign of
  52  * zeros; the difference between 0.0 and ~0.0 is observable by
  53  * programs that examine the sign bit.
  54  * Should check for nan, since Real{32,64}.== returns false for any
  55  * comparison with nan values.  Ideally, should use bit-wise equality
  56  * since there are multiple representations for nan.  However, SML/NJ
  57  * doesn't support the PackReal structures that would be required to
  58  * compare real values as bit patterns.  Conservatively return
  59  * 'false'; constant-propagation and common-subexpression elimination
  60  * will not combine nan values.
  61  *)
  62 fun equals (r, r') =
  63    case (r, r') of
  64       (Real32 r, Real32 r') =>
  65          let
  66             open Real32
  67          in
  68             equals (r, r') andalso signBit r = signBit r'
  69          end
  70     | (Real64 r, Real64 r') =>
  71          let
  72             open Real64
  73          in
  74             equals (r, r') andalso signBit r = signBit r'
  75          end
  76     | _ => false
  77
  78 fun toString r =
  79    case r of
  80       Real32 r => Real32.format (r, Real32.Format.exact)
  81     | Real64 r => Real64.format (r, Real64.Format.exact)
  82
  83 val layout = Layout.str o toString
  84
  85 val hash = String.hash o toString
  86
  87 (* Disable constant folding when it might change the results. *)
  88 fun disableCF () =
  89    PR32.precision = PR64.precision
  90    orelse !Control.target <> Control.Self
  91
  92 local
  93    fun make (o32, o64) arg =
  94        if disableCF ()
  95           then NONE
  96        else SOME (case arg of
  97                      Real32 x => Real32 (o32 x)
  98                    | Real64 x => Real64 (o64 x))
  99 in
 100    val neg = make (Real32.~, Real64.~)
 101    val abs = make (Real32.abs, Real64.abs)
 102 end
 103
 104 datatype 'r r =
 105    R of {zero: 'r, half: 'r, one: 'r, inf: 'r, abs: 'r -> 'r,
 106          signBit: 'r -> bool, isNan: 'r -> bool,
 107          toManExp: 'r -> {exp: int, man: 'r},
 108          compareReal: 'r * 'r -> PIR.real_order,
 109          bits: Bits.t,
 110          subVec: P.Word8Vector.vector * int -> P.LargeWord.word,
 111          update: P.Word8Array.array * int * P.LargeWord.word -> unit,
 112          toBytes: 'r -> P.Word8Vector.vector,
 113          subArr: P.Word8Array.array * int -> 'r,
 114          tag: 'r -> t}
 115
 116 val r32 =
 117     R {zero = 0.0, half = 0.5, one = 1.0, inf = PR32.posInf,
 118        abs = PR32.abs, signBit = PR32.signBit, isNan = PR32.isNan,
 119        toManExp = PR32.toManExp, compareReal = PR32.compareReal,
 120        bits = Bits.inWord32,
 121        subVec = P.PackWord32Little.subVec,
 122        update = P.PackWord32Little.update,
 123        toBytes = P.PackReal32Little.toBytes,
 124        subArr = P.PackReal32Little.subArr,
 125        tag = Real32}
 126 val r64 =
 127     R {zero = 0.0, half = 0.5, one = 1.0, inf = PR64.posInf,
 128        abs = PR64.abs, signBit = PR64.signBit, isNan = PR64.isNan,
 129        toManExp = PR64.toManExp, compareReal = PR64.compareReal,
 130        bits = Bits.inWord64,
 131        subVec = P.PackWord64Little.subVec,
 132        update = P.PackWord64Little.update,
 133        toBytes = P.PackReal64Little.toBytes,
 134        subArr = P.PackReal64Little.subArr,
 135        tag = Real64}
 136
 137 local
 138    fun doit (R {compareReal, signBit, tag, ...}) (f, arg) =
 139        if disableCF ()
 140           then NONE
 141        else
 142           let
 143              val old = PIR.getRoundingMode ()
 144           in
 145              (* According to the Basis Library specification,
 146               * setRoundingMode can fail (raise an exception).
 147               *)
 148              let
 149                 val () = PIR.setRoundingMode PIR.TO_NEGINF
 150                 val min = f arg
 151                 val () = PIR.setRoundingMode PIR.TO_POSINF
 152                 val max = f arg
 153                 val () = PIR.setRoundingMode old
 154              in
 155                 if (PIR.EQUAL = compareReal (min, max)
 156                     andalso signBit min = signBit max)
 157                    then SOME (tag min)
 158                 else NONE
 159              end
 160              handle _ =>
 161                 (if PIR.getRoundingMode () = old
 162                     then ()
 163                  else PIR.setRoundingMode old
 164                  ; NONE)
 165           end
 166
 167    fun make1 (o32, o64) =
 168     fn Real32 x => doit r32 (o32, x)
 169      | Real64 x => doit r64 (o64, x)
 170
 171    fun make2 (o32, o64) =
 172     fn (Real32 x, Real32 y) => doit r32 (o32, (x, y))
 173      | (Real64 x, Real64 y) => doit r64 (o64, (x, y))
 174      | _ => Error.bug "impossible"
 175
 176    fun make3 (o32, o64) =
 177     fn (Real32 x, Real32 y, Real32 z) => doit r32 (o32, (x, y, z))
 178      | (Real64 x, Real64 y, Real64 z) => doit r64 (o64, (x, y, z))
 179      | _ => Error.bug "impossible"
 180 in
 181    val acos = make1 (PR32.Math.acos, PR64.Math.acos)
 182    val asin = make1 (PR32.Math.asin, PR64.Math.asin)
 183    val atan = make1 (PR32.Math.atan, PR64.Math.atan)
 184    val atan2 = make2 (PR32.Math.atan2, PR64.Math.atan2)
 185    val cos = make1 (PR32.Math.cos, PR64.Math.cos)
 186    val exp = make1 (PR32.Math.exp, PR64.Math.exp)
 187    val ln = make1 (PR32.Math.ln, PR64.Math.ln)
 188    val log10 = make1 (PR32.Math.log10, PR64.Math.log10)
 189    val sin = make1 (PR32.Math.sin, PR64.Math.sin)
 190    val sqrt = make1 (PR32.Math.sqrt, PR64.Math.sqrt)
 191    val tan = make1 (PR32.Math.tan, PR64.Math.tan)
 192
 193    val add = make2 (PR32.+, PR64.+)
 194    val op div = make2 (PR32./, PR64./)
 195    val mul = make2 (PR32.*, PR64.* )
 196    val sub = make2 (PR32.-, PR64.-)
 197
 198    val muladd = make3 (PR32.*+, PR64.*+)
 199    val mulsub = make3 (PR32.*-, PR64.*-)
 200
 201    fun fromIntInf (i, s) =
 202        case s of
 203           R32 => doit r32 (Real32.fromIntInf, i)
 204         | R64 => doit r64 (Real64.fromIntInf, i)
 205 end
 206
 207 local
 208    fun make (o32, o64) args =
 209        if disableCF ()
 210           then NONE
 211        else
 212           SOME (case args of
 213                    (Real32 r1, Real32 r2) => o32 (r1, r2)
 214                  | (Real64 r1, Real64 r2) => o64 (r1, r2)
 215                  | _ => Error.bug "impossible")
 216 in
 217    val equal = make (PR32.==, PR64.==)
 218    val le = make (PR32.<=, PR64.<=)
 219    val lt = make (PR32.<, PR64.<)
 220    val qequal = make (PR32.?=, PR64.?=)
 221 end
 222
 223 datatype decon =
 224    NAN
 225  | ZERO of {signBit: bool}
 226  | ONE of {signBit: bool}
 227  | POW2 of {signBit: bool, exp: Int.t} (* man = 0.5 *)
 228  | FIN of {signBit: bool, exp: Int.t, man: t}
 229  | INF of {signBit: bool}
 230
 231 local
 232    fun doit (R {zero, half, one, inf, abs, signBit, isNan, toManExp,
 233                 compareReal, tag, ...})
 234             value =
 235        if isNan value
 236           then NAN
 237        else let
 238              val signBit = signBit value
 239              val absValue = abs value
 240           in
 241              if PIR.EQUAL = compareReal (zero, absValue)
 242                 then ZERO {signBit = signBit}
 243              else if PIR.EQUAL = compareReal (one, absValue)
 244                 then ONE {signBit = signBit}
 245              else if PIR.EQUAL = compareReal (inf, absValue)
 246                 then INF {signBit = signBit}
 247              else let
 248                    val {man, exp} = toManExp absValue
 249                 in
 250                    if PIR.EQUAL = compareReal (half, man)
 251                       then POW2 {signBit = signBit, exp = exp}
 252                    else FIN {signBit = signBit, exp = exp, man = tag man}
 253                 end
 254           end
 255 in
 256    fun decon x =
 257        if disableCF ()
 258           then NONE
 259        else SOME (case x of
 260                      Real32 x => doit r32 x
 261                    | Real64 x => doit r64 x)
 262 end
 263
 264 local
 265    fun doit (R {bits, toBytes, subVec, ...}) x = let
 266    in
 267        (SOME o WordX.fromIntInf)
 268           (P.LargeWord.toLargeInt (subVec (toBytes x, 0)),
 269            WordX.WordSize.fromBits bits)
 270    end handle _ => NONE
 271 in
 272    fun castToWord x =
 273        if disableCF ()
 274           then NONE
 275        else
 276           (case x of
 277               Real32 x => doit r32 x
 278             | Real64 x => doit r64 x)
 279 end
 280
 281 local
 282    fun doit (R {bits, update, subArr, tag, isNan, ...}) w = let
 283       val a = P.Word8Array.array (Bytes.toInt (Bits.toBytes bits), 0w0)
 284       val () = update (a, 0, P.LargeWord.fromLargeInt (WordX.toIntInf w))
 285       val r = subArr (a, 0)
 286    in
 287       if isNan r
 288          then NONE
 289       else SOME (tag r)
 290    end handle _ => NONE
 291 in
 292    fun castFromWord w =
 293       if disableCF () then
 294          NONE
 295       else if WordX.WordSize.bits (WordX.size w) = Bits.inWord32 then
 296          doit r32 w
 297       else if WordX.WordSize.bits (WordX.size w) = Bits.inWord64 then
 298          doit r64 w
 299       else
 300          Error.bug "Invalid word size"
 301 end
 302
 303 end