[MLton-commit] r6847
Vesa Karvonen
vesak at mlton.org
Thu Sep 11 23:36:37 PDT 2008
Improved constant folding of floating point operations (FPCF). Aside from
using known FP identities, the basic idea is to evaluate floating point
operations in all (relevant) rounding modes to ensure that the results are
independent of rounding mode. To ensure correctness, FPCF is disabled
when cross compiling and when the compiler (used to compile MLton) does
not appear to support all FP formats.
(There is currently no command-line switch to disable FPCF, but that could
be nice to have.)
Tested on amd64 linux (and x86 linux when MLton is compiled with MLton)
and does not seem to introduce any (new) regressions.
----------------------------------------------------------------------
U mlton/trunk/lib/mlton/pervasive/pervasive.sml
U mlton/trunk/lib/mlton-stubs/sources.cm
U mlton/trunk/lib/mlton-stubs-in-smlnj/real.sml
U mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm
U mlton/trunk/lib/mlton-stubs-in-smlnj/word.sml
U mlton/trunk/mlton/atoms/atoms.fun
U mlton/trunk/mlton/atoms/const.sig
U mlton/trunk/mlton/atoms/prim.fun
U mlton/trunk/mlton/atoms/real-x.fun
U mlton/trunk/mlton/atoms/real-x.sig
U mlton/trunk/mlton/atoms/sources.cm
U mlton/trunk/mlton/atoms/sources.mlb
U mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun
----------------------------------------------------------------------
Modified: mlton/trunk/lib/mlton/pervasive/pervasive.sml
===================================================================
--- mlton/trunk/lib/mlton/pervasive/pervasive.sml 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/lib/mlton/pervasive/pervasive.sml 2008-09-12 06:36:31 UTC (rev 6847)
@@ -31,6 +31,10 @@
structure Math = Math
structure Option = Option
structure OS = OS
+ structure PackReal32Little = PackReal32Little
+ structure PackReal64Little = PackReal64Little
+ structure PackWord32Little = PackWord32Little
+ structure PackWord64Little = PackWord64Little
structure Position = Position
structure Posix = Posix
structure Real = Real
@@ -47,9 +51,11 @@
structure Vector = Vector
structure Word = Word
structure Word32 = Word32
+ structure Word64 = Word64
structure Word8 = Word8
structure Word16 = Word16
structure Word8Array = Word8Array
+ structure Word8Vector = Word8Vector
type unit = General.unit
type int = Int.int
Modified: mlton/trunk/lib/mlton-stubs/sources.cm
===================================================================
--- mlton/trunk/lib/mlton-stubs/sources.cm 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/lib/mlton-stubs/sources.cm 2008-09-12 06:36:31 UTC (rev 6847)
@@ -40,6 +40,10 @@
structure MLton
structure OS
structure Option
+structure PackReal32Little
+structure PackReal64Little
+structure PackWord32Little
+structure PackWord64Little
structure Position
structure Posix
structure Real
Modified: mlton/trunk/lib/mlton-stubs-in-smlnj/real.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs-in-smlnj/real.sml 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/lib/mlton-stubs-in-smlnj/real.sml 2008-09-12 06:36:31 UTC (rev 6847)
@@ -178,3 +178,27 @@
structure Real32 = Real
structure Real64 = Real
+
+(* Dummy implementation that will not be used at run-time. *)
+structure PackReal32Little = struct
+ type real = Real32.real
+ val bytesPerElem = 0
+ val isBigEndian = false
+ fun toBytes _ = raise Fail "PackReal32Little.toBytes"
+ fun fromBytes _ = raise Fail "PackReal32Little.fromBytes"
+ fun subVec _ = raise Fail "PackReal32Little.subVec"
+ fun subArr _ = raise Fail "PackReal32Little.subArr"
+ fun update _ = raise Fail "PackReal32Little.update"
+end
+
+(* Dummy implementation that will not be used at run-time. *)
+structure PackReal64Little = struct
+ type real = Real64.real
+ val bytesPerElem = 0
+ val isBigEndian = false
+ fun toBytes _ = raise Fail "PackReal64Little.toBytes"
+ fun fromBytes _ = raise Fail "PackReal64Little.fromBytes"
+ fun subVec _ = raise Fail "PackReal64Little.subVec"
+ fun subArr _ = raise Fail "PackReal64Little.subArr"
+ fun update _ = raise Fail "PackReal64Little.update"
+end
Modified: mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm
===================================================================
--- mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/lib/mlton-stubs-in-smlnj/sources.cm 2008-09-12 06:36:31 UTC (rev 6847)
@@ -42,6 +42,10 @@
structure MLton
structure OS
structure Option
+structure PackReal32Little
+structure PackReal64Little
+structure PackWord32Little
+structure PackWord64Little
structure Position
structure Posix
structure Real
Modified: mlton/trunk/lib/mlton-stubs-in-smlnj/word.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs-in-smlnj/word.sml 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/lib/mlton-stubs-in-smlnj/word.sml 2008-09-12 06:36:31 UTC (rev 6847)
@@ -122,3 +122,25 @@
structure Word = Word32
structure SysWord = Word32
structure LargeWord = Word64
+
+(* Dummy implementation that will not be used at run-time. *)
+structure PackWord32Little = struct
+ val bytesPerElem = 0
+ val isBigEndian = false
+ fun subVec _ = raise Fail "PackWord32Little.subVec"
+ fun subVecX _ = raise Fail "PackWord32Little.subVecX"
+ fun subArr _ = raise Fail "PackWord32Little.subArr"
+ fun subArrX _ = raise Fail "PackWord32Little.subArrX"
+ fun update _ = raise Fail "PackWord32Little.update"
+end
+
+(* Dummy implementation that will not be used at run-time. *)
+structure PackWord64Little = struct
+ val bytesPerElem = 0
+ val isBigEndian = false
+ fun subVec _ = raise Fail "PackWord64Little.subVec"
+ fun subVecX _ = raise Fail "PackWord64Little.subVecX"
+ fun subArr _ = raise Fail "PackWord64Little.subArr"
+ fun subArrX _ = raise Fail "PackWord64Little.subArrX"
+ fun update _ = raise Fail "PackWord64Little.update"
+end
Modified: mlton/trunk/mlton/atoms/atoms.fun
===================================================================
--- mlton/trunk/mlton/atoms/atoms.fun 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/mlton/atoms/atoms.fun 2008-09-12 06:36:31 UTC (rev 6847)
@@ -24,8 +24,9 @@
structure Con = Con ()
structure CType = CType (structure RealSize = RealSize
structure WordSize = WordSize)
- structure RealX = RealX (structure RealSize = RealSize)
structure WordX = WordX (structure WordSize = WordSize)
+ structure RealX = RealX (structure RealSize = RealSize
+ structure WordX = WordX)
structure WordXVector = WordXVector (structure WordSize = WordSize
structure WordX = WordX)
structure Func =
Modified: mlton/trunk/mlton/atoms/const.sig
===================================================================
--- mlton/trunk/mlton/atoms/const.sig 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/mlton/atoms/const.sig 2008-09-12 06:36:31 UTC (rev 6847)
@@ -13,7 +13,7 @@
structure RealX: REAL_X
structure WordX: WORD_X
structure WordXVector: WORD_X_VECTOR
- sharing WordX = WordXVector.WordX
+ sharing WordX = RealX.WordX = WordXVector.WordX
end
signature CONST =
Modified: mlton/trunk/mlton/atoms/prim.fun
===================================================================
--- mlton/trunk/mlton/atoms/prim.fun 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/mlton/atoms/prim.fun 2008-09-12 06:36:31 UTC (rev 6847)
@@ -20,6 +20,7 @@
local
open Const
in
+ structure RealX = RealX
structure WordX = WordX
structure WordXVector = WordXVector
end
@@ -1516,6 +1517,7 @@
datatype z = datatype t
datatype z = datatype Const.t
val bool = ApplyResult.Bool
+ val boolOpt = fn NONE => ApplyResult.Unknown | SOME b => bool b
val f = bool false
val t = bool true
fun seqIndexConst i =
@@ -1539,8 +1541,16 @@
else ApplyResult.Const (Const.intInf ii)
val intInfConst = intInf o IntInf.fromInt
val null = ApplyResult.Const Const.null
+ fun real (r: RealX.t): ('a, 'b) ApplyResult.t =
+ ApplyResult.Const (Const.real r)
+ val realOpt = fn NONE => ApplyResult.Unknown | SOME r => real r
+ fun realNeg (s, x): ('a, 'b) ApplyResult.t =
+ ApplyResult.Apply (Real_neg s, [x])
+ fun realAdd (s, x, y): ('a, 'b) ApplyResult.t =
+ ApplyResult.Apply (Real_add s, [x, y])
fun word (w: WordX.t): ('a, 'b) ApplyResult.t =
ApplyResult.Const (Const.word w)
+ val wordOpt = fn NONE => ApplyResult.Unknown | SOME w => word w
fun iio (f, c1, c2) = intInf (f (c1, c2))
fun wordS (f: WordX.t * WordX.t * {signed: bool} -> WordX.t,
(_: WordSize.t, sg),
@@ -1656,6 +1666,38 @@
seqIndexConst (IntInf.fromInt (WordXVector.length v))
| (Vector_sub, [WordVector v, Word i]) =>
word (WordXVector.sub (v, WordX.toInt i))
+ | (Real_neg _, [Real r]) => realOpt (RealX.neg r)
+ | (Real_abs _, [Real r]) => realOpt (RealX.abs r)
+ | (Real_Math_acos _, [Real r]) => realOpt (RealX.acos r)
+ | (Real_Math_asin _, [Real r]) => realOpt (RealX.asin r)
+ | (Real_Math_atan _, [Real r]) => realOpt (RealX.atan r)
+ | (Real_Math_atan2 _, [Real r1, Real r2]) =>
+ realOpt (RealX.atan2 (r1, r2))
+ | (Real_Math_cos _, [Real r]) => realOpt (RealX.cos r)
+ | (Real_Math_exp _, [Real r]) => realOpt (RealX.exp r)
+ | (Real_Math_ln _, [Real r]) => realOpt (RealX.ln r)
+ | (Real_Math_log10 _, [Real r]) => realOpt (RealX.log10 r)
+ | (Real_Math_sin _, [Real r]) => realOpt (RealX.sin r)
+ | (Real_Math_sqrt _, [Real r]) => realOpt (RealX.sqrt r)
+ | (Real_Math_tan _, [Real r]) => realOpt (RealX.tan r)
+ | (Real_add _, [Real r1, Real r2]) => realOpt (RealX.add (r1, r2))
+ | (Real_div _, [Real r1, Real r2]) => realOpt (RealX.div (r1, r2))
+ | (Real_mul _, [Real r1, Real r2]) => realOpt (RealX.mul (r1, r2))
+ | (Real_sub _, [Real r1, Real r2]) => realOpt (RealX.sub (r1, r2))
+ | (Real_muladd _, [Real r1, Real r2, Real r3]) =>
+ realOpt (RealX.muladd (r1, r2, r3))
+ | (Real_mulsub _, [Real r1, Real r2, Real r3]) =>
+ realOpt (RealX.mulsub (r1, r2, r3))
+ | (Real_equal _, [Real r1, Real r2]) => boolOpt (RealX.equal (r1, r2))
+ | (Real_le _, [Real r1, Real r2]) => boolOpt (RealX.le (r1, r2))
+ | (Real_lt _, [Real r1, Real r2]) => boolOpt (RealX.lt (r1, r2))
+ | (Real_qequal _, [Real r1, Real r2]) => boolOpt (RealX.qequal (r1, r2))
+ | (Real_castToWord _, [Real r]) => wordOpt (RealX.castToWord r)
+ | (Word_castToReal _, [Word w]) => realOpt (RealX.castFromWord w)
+ | (Word_rndToReal (_, s, {signed}), [Word w]) =>
+ realOpt
+ (RealX.fromIntInf
+ (if signed then WordX.toIntInfX w else WordX.toIntInf w, s))
| (Word_add _, [Word w1, Word w2]) => word (WordX.add (w1, w2))
| (Word_addCheck s, [Word w1, Word w2]) => wcheck (op +, s, w1, w2)
| (Word_andb _, [Word w1, Word w2]) => word (WordX.andb (w1, w2))
@@ -1752,6 +1794,56 @@
else Unknown
| _ => Unknown
end handle Exn.Overflow => Unknown
+ fun varReal (x, r, inOrder) =
+ let
+ datatype z = datatype RealX.decon
+ datatype z = datatype ApplyResult.t
+ fun negIf (s, signBit) =
+ if signBit then realNeg (s, x) else Var x
+ (* The SML Basis library does not distinguish between
+ different NaN values, so optimizations that may only
+ produce a different NaN value can be considered safe.
+ For example, SNaN*1.0 = SNaN/1.0 = QNaN, so it is
+ safe to optimize x*1.0 and x/1.0 to x. *)
+ in
+ case RealX.decon r of
+ NONE => Unknown
+ | SOME d =>
+ case d of
+ ZERO _ => Unknown
+ | ONE {signBit} =>
+ (case p of
+ Real_mul s => negIf (s, signBit)
+ | Real_div s => if inOrder
+ then negIf (s, signBit)
+ else Unknown
+ | _ => Unknown)
+ | NAN =>
+ (case p of
+ Real_Math_atan2 _ => real r
+ | Real_add _ => real r
+ | Real_div _ => real r
+ | Real_mul _ => real r
+ | Real_sub _ => real r
+ | Real_equal _ => bool false
+ | Real_qequal _ => bool true
+ | Real_le _ => bool false
+ | Real_lt _ => bool false
+ | _ => Unknown)
+ | POW2 {signBit, exp} =>
+ (case p of
+ Real_mul s =>
+ if not signBit andalso exp = 2
+ then realAdd (s, x, x)
+ else Unknown
+ | Real_div s =>
+ if not signBit andalso exp = 0
+ then realAdd (s, x, x)
+ else Unknown
+ | _ => Unknown)
+ | INF _ => Unknown
+ | FIN _ => Unknown
+ end
fun varWord (x, w, inOrder) =
let
val zero = word o WordX.zero
@@ -1889,6 +1981,8 @@
else t
else f
else Unknown
+ | (_, [Var x, Const (Real r)]) => varReal (x, r, true)
+ | (_, [Const (Real r), Var x]) => varReal (x, r, false)
| (_, [Var x, Const (Word i)]) => varWord (x, i, true)
| (_, [Const (Word i), Var x]) => varWord (x, i, false)
| (_, [Const (IntInf i1), Const (IntInf i2), _]) =>
Modified: mlton/trunk/mlton/atoms/real-x.fun
===================================================================
--- mlton/trunk/mlton/atoms/real-x.fun 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/mlton/atoms/real-x.fun 2008-09-12 06:36:31 UTC (rev 6847)
@@ -70,4 +70,218 @@
val hash = String.hash o toString
+structure P = Pervasive
+structure PR32 = P.Real32
+structure PR64 = P.Real64
+structure PIR = P.IEEEReal
+
+(* Disable constant folding when it might change the results. *)
+fun disableCF () =
+ PR32.precision = PR64.precision
+ orelse !Control.target <> Control.Self
+
+local
+ fun make (o32, o64) arg =
+ if disableCF ()
+ then NONE
+ else SOME (case arg of
+ Real32 x => Real32 (o32 x)
+ | Real64 x => Real64 (o64 x))
+in
+ val neg = make (Real32.~, Real64.~)
+ val abs = make (Real32.abs, Real64.abs)
end
+
+datatype 'r r =
+ R of {zero: 'r, half: 'r, one: 'r, inf: 'r, abs: 'r -> 'r,
+ signBit: 'r -> bool, isNan: 'r -> bool,
+ toManExp: 'r -> {exp: Int32.int, man: 'r},
+ compareReal: 'r * 'r -> PIR.real_order,
+ bits: Bits.t,
+ subVec: P.Word8Vector.vector * int -> P.LargeWord.word,
+ update: P.Word8Array.array * int * P.LargeWord.word -> unit,
+ toBytes: 'r -> P.Word8Vector.vector,
+ subArr: P.Word8Array.array * int -> 'r,
+ tag: 'r -> t}
+
+val r32 =
+ R {zero = 0.0, half = 0.5, one = 1.0, inf = PR32.posInf,
+ abs = PR32.abs, signBit = PR32.signBit, isNan = PR32.isNan,
+ toManExp = PR32.toManExp, compareReal = PR32.compareReal,
+ bits = Bits.inWord32,
+ subVec = P.PackWord32Little.subVec,
+ update = P.PackWord32Little.update,
+ toBytes = P.PackReal32Little.toBytes,
+ subArr = P.PackReal32Little.subArr,
+ tag = Real32}
+val r64 =
+ R {zero = 0.0, half = 0.5, one = 1.0, inf = PR64.posInf,
+ abs = PR64.abs, signBit = PR64.signBit, isNan = PR64.isNan,
+ toManExp = PR64.toManExp, compareReal = PR64.compareReal,
+ bits = Bits.inWord64,
+ subVec = P.PackWord64Little.subVec,
+ update = P.PackWord64Little.update,
+ toBytes = P.PackReal64Little.toBytes,
+ subArr = P.PackReal64Little.subArr,
+ tag = Real64}
+
+local
+ fun doit (R {compareReal, signBit, isNan, tag, ...}) (f, arg) =
+ if disableCF ()
+ then NONE
+ else
+ let
+ val old = PIR.getRoundingMode ()
+ (* According to the Basis library spec, setRoundingMode could
+ * fail (raise an exception), but the current implementation
+ * in MLton does not seem to do so. This code may need to be
+ * revisited if the behavior of setRoundingMode changes in
+ * MLton. The idea here is simply to evaluate the operation
+ * in all (relevant) rounding modes to ensure that the result
+ * is the same regardless of rounding mode.
+ *)
+ val () = PIR.setRoundingMode PIR.TO_NEGINF
+ val min = f arg
+ val () = PIR.setRoundingMode PIR.TO_POSINF
+ val max = f arg
+ val () = PIR.setRoundingMode old
+ in
+ if PIR.EQUAL = compareReal (min, max)
+ andalso signBit min = signBit max
+ orelse isNan min andalso isNan max
+ then SOME (tag min)
+ else NONE
+ end
+
+ fun make1 (o32, o64) =
+ fn Real32 x => doit r32 (o32, x)
+ | Real64 x => doit r64 (o64, x)
+
+ fun make2 (o32, o64) =
+ fn (Real32 x, Real32 y) => doit r32 (o32, (x, y))
+ | (Real64 x, Real64 y) => doit r64 (o64, (x, y))
+ | _ => Error.bug "impossible"
+
+ fun make3 (o32, o64) =
+ fn (Real32 x, Real32 y, Real32 z) => doit r32 (o32, (x, y, z))
+ | (Real64 x, Real64 y, Real64 z) => doit r64 (o64, (x, y, z))
+ | _ => Error.bug "impossible"
+in
+ val acos = make1 (PR32.Math.acos, PR64.Math.acos)
+ val asin = make1 (PR32.Math.asin, PR64.Math.asin)
+ val atan = make1 (PR32.Math.atan, PR64.Math.atan)
+ val atan2 = make2 (PR32.Math.atan2, PR64.Math.atan2)
+ val cos = make1 (PR32.Math.cos, PR64.Math.cos)
+ val exp = make1 (PR32.Math.exp, PR64.Math.exp)
+ val ln = make1 (PR32.Math.ln, PR64.Math.ln)
+ val log10 = make1 (PR32.Math.log10, PR64.Math.log10)
+ val sin = make1 (PR32.Math.sin, PR64.Math.sin)
+ val sqrt = make1 (PR32.Math.sqrt, PR64.Math.sqrt)
+ val tan = make1 (PR32.Math.tan, PR64.Math.tan)
+
+ val add = make2 (PR32.+, PR64.+)
+ val op div = make2 (PR32./, PR64./)
+ val mul = make2 (PR32.*, PR64.* )
+ val sub = make2 (PR32.-, PR64.-)
+
+ val muladd = make3 (PR32.*+, PR64.*+)
+ val mulsub = make3 (PR32.*-, PR64.*-)
+
+ fun fromIntInf (i, s) =
+ case s of
+ R32 => doit r32 (Real32.fromIntInf, i)
+ | R64 => doit r64 (Real64.fromIntInf, i)
+end
+
+local
+ fun make (o32, o64) args =
+ if disableCF ()
+ then NONE
+ else
+ SOME (case args of
+ (Real32 r1, Real32 r2) => o32 (r1, r2)
+ | (Real64 r1, Real64 r2) => o64 (r1, r2)
+ | _ => Error.bug "impossible")
+in
+ val equal = make (PR32.==, PR64.==)
+ val le = make (PR32.<=, PR64.<=)
+ val lt = make (PR32.<, PR64.<)
+ val qequal = make (PR32.?=, PR64.?=)
+end
+
+datatype decon =
+ NAN
+ | ZERO of {signBit: bool}
+ | ONE of {signBit: bool}
+ | POW2 of {signBit: bool, exp: Int.t} (* man = 0.5 *)
+ | FIN of {signBit: bool, exp: Int.t, man: t}
+ | INF of {signBit: bool}
+
+local
+ fun doit (R {zero, half, one, inf, abs, signBit, isNan, toManExp,
+ compareReal, tag, ...})
+ value =
+ if isNan value
+ then NAN
+ else let
+ val signBit = signBit value
+ val absValue = abs value
+ in
+ if PIR.EQUAL = compareReal (zero, absValue)
+ then ZERO {signBit = signBit}
+ else if PIR.EQUAL = compareReal (one, absValue)
+ then ONE {signBit = signBit}
+ else if PIR.EQUAL = compareReal (inf, absValue)
+ then INF {signBit = signBit}
+ else let
+ val {man, exp} = toManExp absValue
+ in
+ if PIR.EQUAL = compareReal (half, man)
+ then POW2 {signBit = signBit, exp = exp}
+ else FIN {signBit = signBit, exp = exp, man = tag man}
+ end
+ end
+in
+ fun decon x =
+ if disableCF ()
+ then NONE
+ else SOME (case x of
+ Real32 x => doit r32 x
+ | Real64 x => doit r64 x)
+end
+
+local
+ fun doit (R {bits, toBytes, subVec, ...}) x =
+ WordX.fromIntInf
+ (P.LargeWord.toLargeInt (subVec (toBytes x, 0)),
+ WordX.WordSize.fromBits bits)
+in
+ fun castToWord x =
+ if disableCF ()
+ then NONE
+ else
+ SOME (case x of
+ Real32 x => doit r32 x
+ | Real64 x => doit r64 x)
+end
+
+local
+ fun doit (R {bits, update, subArr, tag, ...}) w = let
+ val a = P.Word8Array.array (Bytes.toInt (Bits.toBytes bits), 0w0)
+ in
+ update (a, 0, P.LargeWord.fromLargeInt (WordX.toIntInf w))
+ ; SOME (tag (subArr (a, 0)))
+ end
+in
+ fun castFromWord w =
+ if disableCF () then
+ NONE
+ else if WordX.WordSize.bits (WordX.size w) = Bits.inWord32 then
+ doit r32 w
+ else if WordX.WordSize.bits (WordX.size w) = Bits.inWord64 then
+ doit r64 w
+ else
+ Error.bug "Invalid word size"
+end
+
+end
Modified: mlton/trunk/mlton/atoms/real-x.sig
===================================================================
--- mlton/trunk/mlton/atoms/real-x.sig 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/mlton/atoms/real-x.sig 2008-09-12 06:36:31 UTC (rev 6847)
@@ -10,6 +10,7 @@
signature REAL_X_STRUCTS =
sig
structure RealSize: REAL_SIZE
+ structure WordX: WORD_X
end
signature REAL_X =
@@ -19,11 +20,46 @@
(* reals of all RealSize.t sizes. *)
type t
+ datatype decon =
+ NAN
+ | ZERO of {signBit: bool}
+ | ONE of {signBit: bool}
+ | POW2 of {signBit: bool, exp: int} (* man = 0.5 *)
+ | FIN of {signBit: bool, exp: int, man: t}
+ | INF of {signBit: bool}
+
+ val abs: t -> t option
+ val acos: t -> t option
+ val add: t * t -> t option
+ val asin: t -> t option
+ val atan2: t * t -> t option
+ val atan: t -> t option
+ val castFromWord: WordX.t -> t option
+ val castToWord: t -> WordX.t option
+ val cos: t -> t option
+ val decon: t -> decon option
+ val div: t * t -> t option
+ val equal: t * t -> bool option
val equals: t * t -> bool
+ val exp: t -> t option
+ val fromIntInf: IntInf.t * RealSize.t -> t option
val hash: t -> word
val layout: t -> Layout.t
+ val le: t * t -> bool option
+ val ln: t -> t option
+ val log10: t -> t option
+ val lt: t * t -> bool option
val make: string * RealSize.t -> t option
+ val mul: t * t -> t option
+ val muladd: t * t * t -> t option
+ val mulsub: t * t * t -> t option
+ val neg: t -> t option
+ val qequal: t * t -> bool option
+ val sin: t -> t option
val size: t -> RealSize.t
+ val sqrt: t -> t option
+ val sub: t * t -> t option
+ val tan: t -> t option
val toString: t -> string
val zero: RealSize.t -> t
end
Modified: mlton/trunk/mlton/atoms/sources.cm
===================================================================
--- mlton/trunk/mlton/atoms/sources.cm 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/mlton/atoms/sources.cm 2008-09-12 06:36:31 UTC (rev 6847)
@@ -52,10 +52,10 @@
(* Windows doesn't like files named con, so use con- instead. *)
con-.sig
con-.fun
+word-x.sig
+word-x.fun
real-x.sig
real-x.fun
-word-x.sig
-word-x.fun
word-x-vector.sig
word-x-vector.fun
c-type.sig
Modified: mlton/trunk/mlton/atoms/sources.mlb
===================================================================
--- mlton/trunk/mlton/atoms/sources.mlb 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/mlton/atoms/sources.mlb 2008-09-12 06:36:31 UTC (rev 6847)
@@ -16,10 +16,10 @@
(* Windows doesn't like files named con, so use con- instead. *)
con-.sig
con-.fun
+ word-x.sig
+ word-x.fun
real-x.sig
real-x.fun
- word-x.sig
- word-x.fun
word-x-vector.sig
word-x-vector.fun
c-type.sig
Modified: mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun
===================================================================
--- mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun 2008-09-11 19:01:52 UTC (rev 6846)
+++ mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun 2008-09-12 06:36:31 UTC (rev 6847)
@@ -45,12 +45,19 @@
fun toC (r: t): string =
let
- (* The only difference between SML reals and C floats/doubles is that
+ (* The main difference between SML reals and C floats/doubles is that
* SML uses "~" while C uses "-".
*)
val s =
String.translate (toString r,
fn #"~" => "-" | c => String.fromChar c)
+ (* Also, inf is spelled INFINITY and nan is NAN in C. *)
+ val s =
+ case s of
+ "-inf" => "-INFINITY"
+ | "inf" => "INFINITY"
+ | "nan" => "NAN"
+ | other => other
in
case size r of
R32 => concat ["(Real32)", s]
More information about the MLton-commit
mailing list