[MLton-devel] cvs commit: (almost) full support for Real32
Matthew Fluet
fluet@users.sourceforge.net
Fri, 25 Jul 2003 13:14:48 -0700
fluet 03/07/25 13:14:48
Modified: basis-library/libs build
basis-library/libs/basis-2002/top-level basis.sig
overloads.sml
basis-library/misc primitive.sml
basis-library/real real.sig
include c-chunk.h x86-main.h
mlton/atoms c-type.sig prim.fun prim.sig
mlton/codegen/x86-codegen x86-allocate-registers.fun
x86-codegen.fun x86-generate-transfers.fun
x86-live-transfers.fun x86-mlton-basic.fun
x86-mlton-basic.sig x86-mlton.fun x86-pseudo.sig
x86-translate.fun x86.fun x86.sig
runtime Makefile
runtime/basis/Real class.c gdtoa.c isFinite.c isNan.c
isNormal.c nextAfter.c real.c signBit.c
Added: basis-library/real real.fun real32.sml real64.sml
regression real32.ok
runtime/basis/Real copysign.c frexp.c modf.c pow.c strto.c
trig.c
Removed: basis-library/real real.sml
runtime/basis/Real toReal.c
Log:
After getting Real32 support for the x86-codegen, it didn't seem like
it would be that much more work to get full support for Real32.
Most _import-ed Real32 functions that don't have a float specific
version are implemented by casting back and forth to double.
Both Real32 and Real64 are implemented by a Real functor. So, I'm not
100% sure that Real32.{toDecimal,fmt,toString,{to,from}LargeInt} are
correct.
I don't know exactly how Real64_gdtoa works, so I don't know if my
implementation of Real32_gdtoa by casting to Real64 is correct.
I changed Prim.Real_toReal from RealSize.t to RealSize.t * RealSize.t,
and implemented the appropriate coercions in c-chunk.h.
Currently, the x86 codegen implementations of Prim.Real_toReal(s,s')
where s <> s' are handled "lazily"; that is the source is copied to
the destination, but is not necessarily written and read from memory
(i.e., forcing the conversion). So, something like:
val a = Real64.Math.pi
val b = Real64.Math.sqrt a
val c = Real32.fromLarge b
val d = Real32.* (c, c)
val e = Real32.toLarge d
will almost certainly all be done in floating-point registers, so the
whole computation will be carried out at 80-bits. That means the
Real32.* will really be carried out at much higher precision than it
should be. The -native-strict-ieee true should solve it, at the
penalty of writing every floating point result to memory.
Revision Changes Path
1.20 +3 -1 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- build 26 Jun 2003 03:28:19 -0000 1.19
+++ build 25 Jul 2003 20:14:46 -0000 1.20
@@ -69,7 +69,9 @@
real/IEEE-real.sml
real/math.sig
real/real.sig
-real/real.sml
+real/real.fun
+real/real32.sml
+real/real64.sml
integer/patch.sml
top-level/overloads.sml
1.12 +6 -6 mlton/basis-library/libs/basis-2002/top-level/basis.sig
Index: basis.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- basis.sig 24 Jul 2003 19:47:09 -0000 1.11
+++ basis.sig 25 Jul 2003 20:14:46 -0000 1.12
@@ -187,7 +187,7 @@
structure RealVector : MONO_VECTOR
structure RealVectorSlice : MONO_VECTOR_SLICE
structure RealArray2 : MONO_ARRAY2
- structure Real32 : REAL32
+ structure Real32 : REAL
structure Real32Array : MONO_ARRAY
structure Real32ArraySlice : MONO_ARRAY_SLICE
structure Real32Vector : MONO_VECTOR
@@ -394,16 +394,16 @@
sharing type RealVectorSlice.vector = RealVector.vector
sharing type RealArray2.elem = real
sharing type RealArray2.vector = RealVector.vector
- (* sharing type Real32Array.elem = Real32.real *)
+ sharing type Real32Array.elem = Real32.real
sharing type Real32Array.vector = Real32Vector.vector
- (* sharing type Real32ArraySlice.elem = Real32.real *)
+ sharing type Real32ArraySlice.elem = Real32.real
sharing type Real32ArraySlice.array = Real32Array.array
sharing type Real32ArraySlice.vector = Real32Vector.vector
sharing type Real32ArraySlice.vector_slice = Real32VectorSlice.slice
- (* sharing type Real32Vector.elem = Real32.real *)
- (* sharing type Real32VectorSlice.elem = Real32.real *)
+ sharing type Real32Vector.elem = Real32.real
+ sharing type Real32VectorSlice.elem = Real32.real
sharing type Real32VectorSlice.vector = Real32Vector.vector
- (* sharing type Real32Array2.elem = Real32.real *)
+ sharing type Real32Array2.elem = Real32.real
sharing type Real32Array2.vector = Real32Vector.vector
sharing type Real64Array.elem = Real64.real
sharing type Real64Array.vector = Real64Vector.vector
1.3 +107 -4 mlton/basis-library/libs/basis-2002/top-level/overloads.sml
Index: overloads.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/overloads.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- overloads.sml 24 Nov 2002 01:19:38 -0000 1.2
+++ overloads.sml 25 Jul 2003 20:14:46 -0000 1.3
@@ -8,31 +8,71 @@
_overload ~ : ('a -> 'a)
as Int.~
+and Int64.~
+and Int32.~
+and Int16.~
+and Int8.~
and IntInf.~
+and Position.~
and Word.~
+and Word32.~
+and Word16.~
and Word8.~
+and SysWord.~
and Real.~
+and Real64.~
+and Real32.~
_overload + : ('a * 'a -> 'a)
as Int.+
+and Int64.+
+and Int32.+
+and Int16.+
+and Int8.+
and IntInf.+
+and Position.+
and Word.+
+and Word32.+
+and Word16.+
and Word8.+
+and SysWord.+
and Real.+
+and Real64.+
+and Real32.+
_overload - : ('a * 'a -> 'a)
as Int.-
+and Int64.-
+and Int32.-
+and Int16.-
+and Int8.-
and IntInf.-
+and Position.-
and Word.-
+and Word32.-
+and Word16.-
and Word8.-
+and SysWord.-
and Real.-
+and Real64.-
+and Real32.-
_overload * : ('a * 'a -> 'a)
as Int.*
+and Int64.*
+and Int32.*
+and Int16.*
+and Int8.*
and IntInf.*
+and Position.*
and Word.*
+and Word32.*
+and Word16.*
and Word8.*
+and SysWord.*
and Real.*
+and Real64.*
+and Real32.*
(* Can't use the following overload, because then
* fun f (x, y) = x + y / y
@@ -51,54 +91,117 @@
_overload div: ('a * 'a -> 'a)
as Int.div
+and Int64.div
+and Int32.div
+and Int16.div
+and Int8.div
and IntInf.div
+and Position.div
and Word.div
+and Word32.div
+and Word16.div
and Word8.div
+and SysWord.div
_overload mod: ('a * 'a -> 'a)
as Int.mod
+and Int64.mod
+and Int32.mod
+and Int16.mod
+and Int8.mod
and IntInf.mod
+and Position.mod
and Word.mod
+and Word32.mod
+and Word16.mod
and Word8.mod
+and SysWord.mod
_overload < : ('a * 'a -> bool)
as Int.<
+and Int64.<
+and Int32.<
+and Int16.<
+and Int8.<
and IntInf.<
+and Position.<
and Word.<
+and Word32.<
+and Word16.<
and Word8.<
+and SysWord.<
and Real.<
-and Char.<
+and Real64.<
+and Real32.<
and String.<
+and Char.<
_overload <= : ('a * 'a -> bool)
as Int.<=
+and Int64.<=
+and Int32.<=
+and Int16.<=
+and Int8.<=
and IntInf.<=
+and Position.<=
and Word.<=
+and Word32.<=
+and Word16.<=
and Word8.<=
+and SysWord.<=
and Real.<=
-and Char.<=
+and Real64.<=
+and Real32.<=
and String.<=
+and Char.<=
_overload > : ('a * 'a -> bool)
as Int.>
+and Int64.>
+and Int32.>
+and Int16.>
+and Int8.>
and IntInf.>
+and Position.>
and Word.>
+and Word32.>
+and Word16.>
and Word8.>
+and SysWord.>
and Real.>
-and Char.>
+and Real64.>
+and Real32.>
and String.>
+and Char.>
_overload >= : ('a * 'a -> bool)
as Int.>=
+and Int64.>=
+and Int32.>=
+and Int16.>=
+and Int8.>=
and IntInf.>=
+and Position.>=
and Word.>=
+and Word32.>=
+and Word16.>=
and Word8.>=
+and SysWord.>=
and Real.>=
-and Char.>=
+and Real64.>=
+and Real32.>=
and String.>=
+and Char.>=
_overload abs: ('a -> 'a)
as Int.abs
+and Int64.abs
+and Int32.abs
+and Int16.abs
+and Int8.abs
and IntInf.abs
+and Position.abs
and Real.abs
+and Real64.abs
+and Real32.abs
1.67 +75 -12 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- primitive.sml 24 Jul 2003 19:47:10 -0000 1.66
+++ primitive.sml 25 Jul 2003 20:14:46 -0000 1.67
@@ -77,7 +77,6 @@
structure Int = Int32
type int = Int.int
-structure LargeReal = Real64
structure Real = Real64
type real = Real.real
structure Word = Word32
@@ -736,8 +735,67 @@
struct
type real = Real32.real
- val fromLarge = _import "Real64_toReal32": LargeReal.real -> real;
- val toLarge = _import "Real32_toReal64": real -> LargeReal.real;
+ structure Math =
+ struct
+ type real = real
+
+ val acos = _prim "Real32_Math_acos": real -> real;
+ val asin = _prim "Real32_Math_asin": real -> real;
+ val atan = _prim "Real32_Math_atan": real -> real;
+ val atan2 = _prim "Real32_Math_atan2": real * real -> real;
+ val cos = _prim "Real32_Math_cos": real -> real;
+ val cosh = _import "Real32_Math_cosh": real -> real;
+ val e = _import "Real32_Math_e": real;
+ val exp = _prim "Real32_Math_exp": real -> real;
+ val ln = _prim "Real32_Math_ln": real -> real;
+ val log10 = _prim "Real32_Math_log10": real -> real;
+ val pi = _import "Real32_Math_pi": real;
+ val pow = _import "Real32_Math_pow": real * real -> real;
+ val sin = _prim "Real32_Math_sin": real -> real;
+ val sinh = _import "Real32_Math_sinh": real -> real;
+ val sqrt = _prim "Real32_Math_sqrt": real -> real;
+ val tan = _prim "Real32_Math_tan": real -> real;
+ val tanh = _import "Real32_Math_tanh": real -> real;
+ end
+
+ val * = _prim "Real32_mul": real * real -> real;
+ val *+ = _prim "Real32_muladd": real * real * real -> real;
+ val *- = _prim "Real32_mulsub": real * real * real -> real;
+ val + = _prim "Real32_add": real * real -> real;
+ val - = _prim "Real32_sub": real * real -> real;
+ val / = _prim "Real32_div": real * real -> real;
+ val < = _prim "Real32_lt": real * real -> bool;
+ val <= = _prim "Real32_le": real * real -> bool;
+ val == = _prim "Real32_equal": real * real -> bool;
+ val > = _prim "Real32_gt": real * real -> bool;
+ val >= = _prim "Real32_ge": real * real -> bool;
+ val ?= = _prim "Real32_qequal": real * real -> bool;
+ val abs = _prim "Real32_abs": real -> real;
+ val class = _import "Real32_class": real -> int;
+ val copySign = _import "Real32_copysign": real * real -> real;
+ val frexp = _import "Real32_frexp": real * int ref -> real;
+ val gdtoa =
+ _import "Real32_gdtoa": real * int * int * int ref -> cstring;
+ val fromInt = _prim "Int32_toReal32": int -> real;
+ val isFinite = _import "Real32_isFinite": real -> bool;
+ val isNan = _import "Real32_isNan": real -> bool;
+ val isNormal = _import "Real32_isNormal": real -> bool;
+ val ldexp = _prim "Real32_ldexp": real * int -> real;
+ val maxFinite = _import "Real32_maxFinite": real;
+ val minNormalPos = _import "Real32_minNormalPos": real;
+ val minPos = _import "Real32_minPos": real;
+ val modf = _import "Real32_modf": real * real ref -> real;
+ val nextAfter = _import "Real32_nextAfter": real * real -> real;
+ val round = _prim "Real32_round": real -> real;
+ val signBit = _import "Real32_signBit": real -> bool;
+ val strto = _import "Real32_strto": nullString -> real;
+ val toInt = _prim "Real32_toInt32": real -> int;
+ val ~ = _prim "Real32_neg": real -> real;
+
+ val fromLarge = _prim "Real64_toReal32": real64 -> real;
+ val toLarge = _prim "Real32_toReal64": real -> real64;
+ val precision : int = 23
+ val radix : int = 2
end
structure Real64 =
@@ -753,18 +811,18 @@
val atan = _prim "Real64_Math_atan": real -> real;
val atan2 = _prim "Real64_Math_atan2": real * real -> real;
val cos = _prim "Real64_Math_cos": real -> real;
- val cosh = _import "cosh": real -> real;
+ val cosh = _import "Real64_Math_cosh": real -> real;
val e = _import "Real64_Math_e": real;
val exp = _prim "Real64_Math_exp": real -> real;
val ln = _prim "Real64_Math_ln": real -> real;
val log10 = _prim "Real64_Math_log10": real -> real;
val pi = _import "Real64_Math_pi": real;
- val pow = _import "pow": real * real -> real;
+ val pow = _import "Real64_Math_pow": real * real -> real;
val sin = _prim "Real64_Math_sin": real -> real;
- val sinh = _import "sinh": real -> real;
+ val sinh = _import "Real64_Math_sinh": real -> real;
val sqrt = _prim "Real64_Math_sqrt": real -> real;
val tan = _prim "Real64_Math_tan": real -> real;
- val tanh = _import "tanh": real -> real;
+ val tanh = _import "Real64_Math_tanh": real -> real;
end
val * = _prim "Real64_mul": real * real -> real;
@@ -781,8 +839,8 @@
val ?= = _prim "Real64_qequal": real * real -> bool;
val abs = _prim "Real64_abs": real -> real;
val class = _import "Real64_class": real -> int;
- val copySign = _import "copysign": real * real -> real;
- val frexp = _import "frexp": real * int ref -> real;
+ val copySign = _import "Real64_copysign": real * real -> real;
+ val frexp = _import "Real64_frexp": real * int ref -> real;
val gdtoa =
_import "Real64_gdtoa": real * int * int * int ref -> cstring;
val fromInt = _prim "Int32_toReal64": int -> real;
@@ -793,13 +851,18 @@
val maxFinite = _import "Real64_maxFinite": real;
val minNormalPos = _import "Real64_minNormalPos": real;
val minPos = _import "Real64_minPos": real;
- val modf = _import "modf": real * real ref -> real;
+ val modf = _import "Real64_modf": real * real ref -> real;
val nextAfter = _import "Real64_nextAfter": real * real -> real;
val round = _prim "Real64_round": real -> real;
val signBit = _import "Real64_signBit": real -> bool;
- val strtod = _import "Real64_strtod": nullString -> real;
- val toInt = _prim "Real64_toInt": real -> int;
+ val strto = _import "Real64_strto": nullString -> real;
+ val toInt = _prim "Real64_toInt32": real -> int;
val ~ = _prim "Real64_neg": real -> real;
+
+ val fromLarge : real -> real = fn x => x
+ val toLarge : real -> real = fn x => x
+ val precision : int = 52
+ val radix : int = 2
end
structure Ref =
1.8 +50 -10 mlton/basis-library/real/real.sig
Index: real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- real.sig 24 Jul 2003 19:47:11 -0000 1.7
+++ real.sig 25 Jul 2003 20:14:46 -0000 1.8
@@ -8,10 +8,58 @@
type real = real
end
+signature PRE_REAL_GLOBAL =
+ sig
+ type real
+ structure Math: MATH where type real = real
+ end
+
+signature PRE_REAL =
+ sig
+ include PRE_REAL_GLOBAL
+
+ val * : real * real -> real
+ val *+ : real * real * real -> real
+ val *- : real * real * real -> real
+ val + : real * real -> real
+ val - : real * real -> real
+ val / : real * real -> real
+ val < : real * real -> bool
+ val <= : real * real -> bool
+ val == : real * real -> bool
+ val > : real * real -> bool
+ val >= : real * real -> bool
+ val ?= : real * real -> bool
+ val ~ : real -> real
+ val abs: real -> real
+ val class: real -> int
+ val copySign: real * real -> real
+ val frexp: real * int ref -> real;
+ val gdtoa: real * int * int * int ref -> Primitive.cstring;
+ val fromInt: int -> real
+ val isFinite: real -> bool
+ val isNan: real -> bool
+ val isNormal: real -> bool
+ val ldexp: real * int -> real
+ val maxFinite: real
+ val minNormalPos: real
+ val minPos: real
+ val modf: real * real ref -> real
+ val nextAfter: real * real -> real
+ val round: real -> real
+ val signBit: real -> bool
+ val strto: nullString -> real
+ val toInt: real -> int
+
+ val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
+ val toLarge: real -> LargeReal.real
+ val precision: int
+ val radix: int
+ end
+
signature REAL_GLOBAL =
sig
- type real
- structure Math: MATH where type real = real
+ include PRE_REAL_GLOBAL
val round: real -> Int.int
val trunc: real -> Int.int
@@ -80,12 +128,4 @@
val toManExp: real -> {man: real, exp: int}
val toString: real -> string
val unordered: real * real -> bool
- end
-
-signature REAL32 =
- sig
- type real
-
- val toLarge: real -> LargeReal.real
- val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
end
1.1 mlton/basis-library/real/real.fun
Index: real.fun
===================================================================
functor Real (R: PRE_REAL): REAL =
struct
structure Prim = R
local
open IEEEReal
in
datatype z = datatype float_class
datatype z = datatype rounding_mode
end
infix 4 == != ?=
type real = Prim.real
local
open Prim
in
val *+ = *+
val *- = *-
val abs = abs
val copySign = copySign
val fromInt = fromInt
val isFinite = isFinite
val isNan = isNan
val isNormal = isNormal
val maxFinite = maxFinite
val minNormalPos = minNormalPos
val minPos = minPos
val nextAfter = nextAfter
val op * = op *
val op + = op +
val op - = op -
val op / = op /
val op / = op /
val op < = op <
val op <= = op <=
val op == = op ==
val op > = op >
val op >= = op >=
val op ?= = op ?=
val signBit = signBit
val ~ = ~
end
val op ?= =
if Primitive.MLton.native
then op ?=
else fn (r, r') => isNan r orelse isNan r' orelse r == r'
val radix: int = Prim.radix
val precision: int = Prim.precision
val toLarge = Prim.toLarge
val fromLarge = Prim.fromLarge
val zero = fromLarge IEEEReal.TO_NEAREST 0.0
val one = fromLarge IEEEReal.TO_NEAREST 1.0
val two = fromLarge IEEEReal.TO_NEAREST 2.0
val half = one / two
val posInf = one / zero
val negInf = ~one / zero
val nan = posInf + negInf
structure Math =
struct
open Prim.Math
structure MLton = Primitive.MLton
structure Platform = MLton.Platform
(* Patches for Cygwin and SunOS, whose math libraries do not handle
* out-of-range args.
*)
val (acos, asin, ln, log10) =
if not MLton.native
andalso (case Platform.os of
Platform.Cygwin => true
| Platform.SunOS => true
| _ => false)
then
let
fun patch f x =
if x < ~one orelse x > one
then nan
else f x
val acos = patch acos
val asin = patch asin
fun patch f x = if x < zero then nan else f x
val ln = patch ln
val log10 = patch log10
in
(acos, asin, ln, log10)
end
else (acos, asin, ln, log10)
end
val op != = not o op ==
fun min (x, y) = if x < y orelse isNan y then x else y
fun max (x, y) = if x > y orelse isNan y then x else y
fun sign (x: real): int =
if x > zero then 1
else if x < zero then ~1
else if isNan x then raise Domain
else 0
fun sameSign (x, y) = Prim.signBit x = Prim.signBit y
local
datatype z = datatype General.order
in
fun compare (x, y) =
if x < y then LESS
else if x > y then GREATER
else if x == y then EQUAL
else raise IEEEReal.Unordered
end
local
datatype z = datatype IEEEReal.real_order
in
fun compareReal (x, y) =
if x < y then LESS
else if x > y then GREATER
else if x == y then EQUAL
else UNORDERED
end
fun unordered (x, y) = isNan x orelse isNan y
(* See runtime/basis/Real.c for the integers returned by class. *)
fun class x =
case Prim.class x of
0 => NAN (* QUIET *)
| 1 => NAN (* SIGNALLING *)
| 2 => INF
| 3 => ZERO
| 4 => NORMAL
| 5 => SUBNORMAL
| _ => raise Fail "Primitive.Real.class returned bogus integer"
val toManExp =
let
val r: int ref = ref 0
in
fn x => if x == zero
then {exp = 0, man = zero}
else
let
val man = Prim.frexp (x, r)
in
{man = man * two, exp = Int.- (!r, 1)}
end
end
fun fromManExp {man, exp} = Prim.ldexp (man, exp)
local
val int = ref zero
in
fun split x =
let
val frac = Prim.modf (x, int)
in
{frac = frac,
whole = ! int}
end
end
val realMod = #frac o split
fun checkFloat x =
case class x of
INF => raise Overflow
| NAN => raise Div
| _ => x
val maxInt = fromInt Int.maxInt'
val minInt = fromInt Int.minInt'
fun toInt mode x =
let
fun doit () = IEEEReal.withRoundingMode (mode, fn () =>
Prim.toInt (Prim.round x))
in
case class x of
NAN => raise Domain
| INF => raise Overflow
| ZERO => 0
| NORMAL =>
if minInt <= x
then if x <= maxInt
then doit ()
else if x < maxInt + one
then (case mode of
TO_NEGINF => Int.maxInt'
| TO_POSINF => raise Overflow
| TO_ZERO => Int.maxInt'
| TO_NEAREST =>
(* Depends on maxInt being odd. *)
if x - maxInt >= half
then raise Overflow
else Int.maxInt')
else raise Overflow
else if x > minInt - one
then (case mode of
TO_NEGINF => raise Overflow
| TO_POSINF => Int.minInt'
| TO_ZERO => Int.minInt'
| TO_NEAREST =>
(* Depends on minInt being even. *)
if x - minInt < ~half
then raise Overflow
else Int.minInt')
else raise Overflow
| SUBNORMAL => doit ()
end
val floor = toInt TO_NEGINF
val ceil = toInt TO_POSINF
val trunc = toInt TO_ZERO
val round = toInt TO_NEAREST
local
fun round mode x =
case class x of
NAN => x
| INF => x
| _ => IEEEReal.withRoundingMode (mode, fn () => Prim.round x)
in
val realFloor = round TO_NEGINF
val realCeil = round TO_POSINF
val realTrunc = round TO_ZERO
end
fun rem (x, y) =
case class x of
INF => nan
| NAN => nan
| ZERO => zero
| _ =>
case class y of
INF => x
| NAN => nan
| ZERO => nan
| _ => x - realTrunc (x/y) * y
(* fromDecimal, scan, fromString: decimal -> binary conversions *)
exception Bad
fun fromDecimal ({class, digits, exp, sign}: IEEEReal.decimal_approx) =
let
fun doit () =
let
val exp =
if Int.< (exp, 0)
then concat ["-", Int.toString (Int.~ exp)]
else Int.toString exp
val x =
concat ["0.",
implode (List.map
(fn d =>
if Int.< (d, 0) orelse Int.> (d, 9)
then raise Bad
else Char.chr (Int.+ (d, Char.ord #"0")))
digits),
"E", exp, "\000"]
val x = Prim.strto x
in
if sign
then ~ x
else x
end
in
SOME (case class of
INF => if sign then negInf else posInf
| NAN => nan
| NORMAL => doit ()
| SUBNORMAL => doit ()
| ZERO => zero)
handle Bad => NONE
end
fun scan reader state =
case IEEEReal.scan reader state of
NONE => NONE
| SOME (da, state) => SOME (valOf (fromDecimal da), state)
val fromString = StringCvt.scanString scan
(* toDecimal, fmt, toString: binary -> decimal conversions. *)
datatype mode = Fix | Gen | Sci
local
val decpt: int ref = ref 0
in
fun gdtoa (x: real, mode: mode, ndig: int) =
let
val mode =
case mode of
Fix => 3
| Gen => 0
| Sci => 2
val cs = Prim.gdtoa (x, mode, ndig, decpt)
in
(cs, !decpt)
end
end
fun toDecimal (x: real): IEEEReal.decimal_approx =
case class x of
NAN => {class = NAN,
digits = [],
exp = 0,
sign = false}
| INF => {class = INF,
digits = [],
exp = 0,
sign = x < zero}
| ZERO => {class = ZERO,
digits = [],
exp = 0,
sign = false}
| c =>
let
val (cs, decpt) = gdtoa (x, Gen, 0)
fun loop (i, ac) =
if Int.< (i, 0)
then ac
else loop (Int.- (i, 1),
(Int.- (Char.ord (C.CS.sub (cs, i)),
Char.ord #"0"))
:: ac)
val digits = loop (Int.- (C.CS.length cs, 1), [])
val exp = decpt
in
{class = NORMAL,
digits = digits,
exp = exp,
sign = x < zero}
end
datatype realfmt = datatype StringCvt.realfmt
fun add1 n = Int.+ (n, 1)
local
fun fix (sign: string, cs: C.CS.t, decpt: int, ndig: int): string =
let
val length = C.CS.length cs
in
if Int.< (decpt, 0)
then
concat [sign,
"0.",
String.new (Int.~ decpt, #"0"),
C.CS.toString cs,
String.new (Int.+ (Int.- (ndig, length),
decpt),
#"0")]
else
let
val whole =
if decpt = 0
then "0"
else
String.tabulate (decpt, fn i =>
if Int.< (i, length)
then C.CS.sub (cs, i)
else #"0")
in
if 0 = ndig
then concat [sign, whole]
else
let
val frac =
String.tabulate
(ndig, fn i =>
let
val j = Int.+ (i, decpt)
in
if Int.< (j, length)
then C.CS.sub (cs, j)
else #"0"
end)
in
concat [sign, whole, ".", frac]
end
end
end
fun sci (sign: string, cs: C.CS.t, decpt: int, ndig: int): string =
let
val length = C.CS.length cs
val whole = String.tabulate (1, fn _ => C.CS.sub (cs, 0))
val frac =
if 0 = ndig
then ""
else concat [".",
String.tabulate
(ndig, fn i =>
let
val j = Int.+ (i, 1)
in
if Int.< (j, length)
then C.CS.sub (cs, j)
else #"0"
end)]
val exp = Int.- (decpt, 1)
val exp =
let
val (exp, sign) =
if Int.< (exp, 0)
then (Int.~ exp, "~")
else (exp, "")
in
concat [sign, Int.toString exp]
end
in
concat [sign, whole, frac, "E", exp]
end
in
fun fmt spec =
let
val doit =
case spec of
EXACT => IEEEReal.toString o toDecimal
| FIX opt =>
let
val n =
case opt of
NONE => 6
| SOME n =>
if Primitive.safe andalso Int.< (n, 0)
then raise Size
else n
in
fn x =>
let
val sign = if x < zero then "~" else ""
val (cs, decpt) = gdtoa (x, Fix, n)
in
fix (sign, cs, decpt, n)
end
end
| GEN opt =>
let
val n =
case opt of
NONE => 12
| SOME n =>
if Primitive.safe andalso Int.< (n, 1)
then raise Size
else n
in
fn x =>
let
val sign = if x < zero then "~" else ""
val (cs, decpt) = gdtoa (x, Sci, n)
val length = C.CS.length cs
in
if Int.<= (decpt, ~4)
orelse Int.> (decpt, Int.+ (5, length))
then sci (sign, cs, decpt, Int.- (length, 1))
else fix (sign, cs, decpt,
if Int.< (length, decpt)
then 0
else Int.- (length, decpt))
end
end
| SCI opt =>
let
val n =
case opt of
NONE => 6
| SOME n =>
if Primitive.safe andalso Int.< (n, 0)
then raise Size
else n
in
fn x =>
let
val sign = if x < zero then "~" else ""
val (cs, decpt) = gdtoa (x, Sci, add1 n)
in
sci (sign, cs, decpt, n)
end
end
in
fn x =>
case class x of
NAN => "nan"
| INF => if x > zero then "inf" else "~inf"
| _ => doit x
end
end
val toString = fmt (StringCvt.GEN NONE)
local
fun negateMode m =
case m of
TO_NEAREST => TO_NEAREST
| TO_NEGINF => TO_POSINF
| TO_POSINF => TO_NEGINF
| TO_ZERO => TO_ZERO
val m: int = precision (* The number of mantissa bits in IEEE 854. *)
val half_i = Int.quot (m, 2)
val two_ii = IntInf.fromInt 2
val twoPowHalf_ii = IntInf.pow (two_ii, half_i)
in
fun fromLargeInt (i: IntInf.int): real =
let
fun pos (i: IntInf.int, mode): real =
case SOME (IntInf.log2 i) handle Overflow => NONE of
NONE => posInf
| SOME exp =>
if Int.< (exp, Int.- (valOf Int.precision, 1))
then fromInt (IntInf.toInt i)
else if Int.>= (exp, 1024)
then posInf
else
let
val shift = Int.- (exp, m)
val (man: IntInf.int, extra: IntInf.int) =
if Int.>= (shift, 0)
then
let
val (q, r) =
IntInf.quotRem
(i, IntInf.pow (two_ii, shift))
val extra =
case mode of
TO_NEAREST =>
if IntInf.> (r, 0)
andalso IntInf.log2 r =
Int.- (shift, 1)
then 1
else 0
| TO_NEGINF => 0
| TO_POSINF =>
if IntInf.> (r, 0)
then 1
else 0
| TO_ZERO => 0
in
(q, extra)
end
else
(IntInf.* (i, IntInf.pow (two_ii, Int.~ shift)),
0)
(* 2^m <= man < 2^(m+1) *)
val (q, r) = IntInf.quotRem (man, twoPowHalf_ii)
fun conv (man, exp) =
fromManExp {man = fromInt (IntInf.toInt man),
exp = exp}
in
conv (q, Int.+ (half_i, shift))
+ conv (IntInf.+ (r, extra), shift)
end
val mode = IEEEReal.getRoundingMode ()
in
case IntInf.compare (i, IntInf.fromInt 0) of
General.LESS => ~ (pos (IntInf.~ i, negateMode mode))
| General.EQUAL => zero
| General.GREATER => pos (i, mode)
end
val toLargeInt: IEEEReal.rounding_mode -> real -> IntInf.int =
fn mode => fn x =>
(IntInf.fromInt (toInt mode x)
handle Overflow =>
case class x of
INF => raise Overflow
| _ =>
let
fun pos (x, mode) =
let
val {frac, whole} = split x
val extra =
if mode = TO_NEAREST
andalso half == frac
then
if half == realMod (whole / two)
then 1
else 0
else IntInf.fromInt (toInt mode frac)
val {man, exp} = toManExp whole
(* 1 <= man < 2 *)
val man = fromManExp {man = man, exp = half_i}
(* 2^half <= man < 2^(half+1) *)
val {frac = lower, whole = upper} = split man
val upper = IntInf.* (IntInf.fromInt (floor upper),
twoPowHalf_ii)
(* 2^m <= upper < 2^(m+1) *)
val {whole = lower, ...} =
split (fromManExp {man = lower, exp = half_i})
(* 0 <= lower < 2^half *)
val lower = IntInf.fromInt (floor lower)
val int = IntInf.+ (upper, lower)
(* 2^m <= int < 2^(m+1) *)
val shift = Int.- (exp, m)
val int =
if Int.>= (shift, 0)
then IntInf.* (int, IntInf.pow (2, shift))
else IntInf.quot (int,
IntInf.pow (2, Int.~ shift))
in
IntInf.+ (int, extra)
end
in
if x > zero
then pos (x, mode)
else IntInf.~ (pos (~ x, negateMode mode))
end)
end
end
1.1 mlton/basis-library/real/real32.sml
Index: real32.sml
===================================================================
structure Real32 =
Real
(structure P = Primitive.Real32
open P
fun fromLarge m r =
IEEEReal.withRoundingMode (m, fn () => P.fromLarge r)
)
1.1 mlton/basis-library/real/real64.sml
Index: real64.sml
===================================================================
structure Real64 =
Real
(structure P = Primitive.Real64
open P
fun fromLarge m r = P.fromLarge r
)
structure Real = Real64
val real = Real.fromInt
structure RealGlobal: REAL_GLOBAL = Real
open RealGlobal
structure LargeReal = Real64
1.10 +43 -1 mlton/include/c-chunk.h
Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- c-chunk.h 26 Jun 2003 03:28:19 -0000 1.9
+++ c-chunk.h 25 Jul 2003 20:14:46 -0000 1.10
@@ -617,15 +617,33 @@
static inline t f##_to##t (f x) { \
return (t)x; \
}
+//coerce (Int64, Int64)
+//coerce (Int64, Int32)
+//coerce (Int64, Int16)
+//coerce (Int64, Int8)
+//coerce (Int32, Int64)
coerce (Int32, Int32)
coerce (Int32, Int16)
coerce (Int32, Int8)
+//coerce (Int16, Int64)
coerce (Int16, Int32)
coerce (Int16, Int16)
coerce (Int16, Int8)
+//coerce (Int8, Int64)
coerce (Int8, Int32)
coerce (Int8, Int16)
coerce (Int8, Int8)
+//coerce (Int64, Real64)
+//coerce (Int64, Real32)
+coerce (Int32, Real64)
+coerce (Int32, Real32)
+coerce (Int16, Real64)
+coerce (Int16, Real32)
+coerce (Int8, Real64)
+coerce (Int8, Real32)
+//coerce (Int64, Word32)
+//coerce (Int64, Word16)
+//coerce (Int64, Word8)
coerce (Int32, Word32)
coerce (Int32, Word16)
coerce (Int32, Word8)
@@ -635,13 +653,27 @@
coerce (Int8, Word32)
coerce (Int8, Word16)
coerce (Int8, Word8)
-coerce (Int32, Real64)
+//coerce (Real64, Int64)
+coerce (Real64, Int32)
+coerce (Real64, Int16)
+coerce (Real64, Int8)
+//coerce (Real32, Int64)
+coerce (Real32, Int32)
+coerce (Real32, Int16)
+coerce (Real32, Int8)
+coerce (Real64, Real64)
+coerce (Real64, Real32)
+coerce (Real32, Real64)
+coerce (Real32, Real32)
+//coerce (Word32, Int64)
coerce (Word32, Int32)
coerce (Word32, Int16)
coerce (Word32, Int8)
+//coerce (Word16, Int64)
coerce (Word16, Int32)
coerce (Word16, Int16)
coerce (Word16, Int8)
+//coerce (Word8, Int64)
coerce (Word8, Int32)
coerce (Word8, Int16)
coerce (Word8, Int8)
@@ -660,18 +692,28 @@
static inline t Word##size##_to##t##X (Word##size x) { \
return (t)(Int##size)x; \
}
+//coerceX (64, Int64)
+//coerceX (64, Int32)
+//coerceX (64, Int16)
+//coerceX (64, Int8)
+//coerceX (64, Word32)
+//coerceX (64, Word16)
+//coerceX (64, Word8)
+//coerceX (64, Int64)
coerceX (32, Int32)
coerceX (32, Int16)
coerceX (32, Int8)
coerceX (32, Word32)
coerceX (32, Word16)
coerceX (32, Word8)
+//coerceX (16, Int64)
coerceX (16, Int32)
coerceX (16, Int16)
coerceX (16, Int8)
coerceX (16, Word32)
coerceX (16, Word16)
coerceX (16, Word8)
+//coerceX (8, Int64)
coerceX (8, Int32)
coerceX (8, Int16)
coerceX (8, Int8)
1.7 +8 -6 mlton/include/x86-main.h
Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- x86-main.h 5 Jul 2003 23:30:25 -0000 1.6
+++ x86-main.h 25 Jul 2003 20:14:46 -0000 1.7
@@ -6,21 +6,23 @@
/* Globals */
word applyFFTemp;
word checkTemp;
-char cReturnTempB;
-double cReturnTempD;
-word cReturnTempL;
+word cReturnTemp[16];
word c_stackP;
word divTemp;
word fileTemp;
+word fildTemp;
word fpswTemp;
word indexTemp;
word intInfTemp;
char MLton_bug_msg[] = "cps machine";
word raTemp1;
double raTemp2;
-double realTemp1;
-double realTemp2;
-double realTemp3;
+double realTemp1D;
+double realTemp2D;
+double realTemp3D;
+float realTemp1S;
+float realTemp2S;
+float realTemp3S;
word spill[16];
word stackTopTemp;
word statusTemp;
1.2 +1 -1 mlton/mlton/atoms/c-type.sig
Index: c-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- c-type.sig 19 Jul 2003 01:23:26 -0000 1.1
+++ c-type.sig 25 Jul 2003 20:14:46 -0000 1.2
@@ -29,7 +29,7 @@
val equals: t * t -> bool
val isPointer: t -> bool
val memo: (t -> 'a) -> t -> 'a
- (* name: R{32,64} I{8,16,32,64] P W[8,16,32] *)
+ (* name: R{32,64} I[8,16,32,64] P W[8,16,32] *)
val name: t -> string
val pointer: t
val layout: t -> Layout.t
1.59 +5 -3 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- prim.fun 20 Jul 2003 18:07:58 -0000 1.58
+++ prim.fun 25 Jul 2003 20:14:46 -0000 1.59
@@ -163,7 +163,8 @@
| Real_qequal of RealSize.t (* codegen *)
| Real_round of RealSize.t (* codegen *)
| Real_sub of RealSize.t (* codegen *)
- | Real_toInt of RealSize.t (* codegen *)
+ | Real_toInt of RealSize.t * IntSize.t (* codegen *)
+ | Real_toReal of RealSize.t * RealSize.t (* codegen *)
| Ref_assign (* backend *)
| Ref_deref (* backend *)
| Ref_ref (* backend *)
@@ -302,8 +303,7 @@
(Real_neg, Functional, "neg"),
(Real_qequal, Functional, "qequal"),
(Real_round, Functional, "round"),
- (Real_sub, Functional, "sub"),
- (Real_toInt, Functional, "toInt")],
+ (Real_sub, Functional, "sub")],
fn (makeName, kind, str) =>
(makeName s, kind, concat ["Real", RealSize.toString s, "_", str]))
@@ -443,6 +443,8 @@
List.concat [coerces (Int_toInt, int, int),
coerces (Int_toReal, int, real),
coerces (Int_toWord, int, word),
+ coerces (Real_toInt, real, int),
+ coerces (Real_toReal, real, real),
coerces (Word_toInt, word, int),
coercesX (Word_toIntX, word, int),
coerces (Word_toWord, word, word),
1.46 +2 -1 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- prim.sig 20 Jul 2003 18:07:58 -0000 1.45
+++ prim.sig 25 Jul 2003 20:14:46 -0000 1.46
@@ -153,7 +153,8 @@
| Real_qequal of RealSize.t (* codegen *)
| Real_round of RealSize.t (* codegen *)
| Real_sub of RealSize.t (* codegen *)
- | Real_toInt of RealSize.t (* codegen *)
+ | Real_toInt of RealSize.t * IntSize.t (* codegen *)
+ | Real_toReal of RealSize.t * RealSize.t (* codegen *)
| Ref_assign (* backend *)
| Ref_deref (* backend *)
| Ref_ref (* backend *)
1.30 +261 -247 mlton/mlton/codegen/x86-codegen/x86-allocate-registers.fun
Index: x86-allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-allocate-registers.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- x86-allocate-registers.fun 25 Jun 2003 23:15:31 -0000 1.29
+++ x86-allocate-registers.fun 25 Jul 2003 20:14:46 -0000 1.30
@@ -6550,6 +6550,255 @@
registerAllocation = registerAllocation}
end
+ fun pfmov {instruction, info as {dead, commit, remove, ...},
+ registerAllocation,
+ src, dst, srcsize, dstsize} =
+ let
+ fun default ()
+ = let
+ val {uses,defs,kills}
+ = Instruction.uses_defs_kills instruction
+ val {assembly = assembly_pre,
+ registerAllocation}
+ = RA.pre {uses = uses,
+ defs = defs,
+ kills = kills,
+ info = info,
+ registerAllocation = registerAllocation}
+
+ val {operand = final_src,
+ assembly = assembly_src,
+ fltrename = fltrename_src,
+ registerAllocation}
+ = RA.allocateFltOperand
+ {operand = src,
+ options = {fltregister = true,
+ address = true},
+ info = info,
+ size = srcsize,
+ move = true,
+ supports = [dst],
+ saves = [],
+ top = SOME false,
+ registerAllocation
+ = registerAllocation}
+
+ val {operand = final_dst,
+ assembly = assembly_dst,
+ fltrename = fltrename_dst,
+ registerAllocation}
+ = RA.allocateFltOperand
+ {operand = dst,
+ options = {fltregister = true,
+ address = false},
+ info = info,
+ size = dstsize,
+ move = false,
+ supports = [],
+ saves = [src,final_src],
+ top = NONE,
+ registerAllocation
+ = registerAllocation}
+
+ val final_src = (RA.fltrenameLift fltrename_dst) final_src
+
+ val instruction
+ = Instruction.FLD
+ {src = final_src,
+ size = srcsize}
+
+ val {uses = final_uses,
+ defs = final_defs,
+ ...}
+ = Instruction.uses_defs_kills instruction
+
+ val {assembly = assembly_post,
+ registerAllocation}
+ = RA.post {uses = uses,
+ final_uses = final_uses,
+ defs = defs,
+ final_defs = final_defs,
+ kills = kills,
+ info = info,
+ registerAllocation = registerAllocation}
+ in
+ {assembly
+ = AppendList.appends
+ [assembly_pre,
+ assembly_src,
+ assembly_dst,
+ AppendList.single
+ (Assembly.instruction instruction),
+ assembly_post],
+ registerAllocation = registerAllocation}
+ end
+
+ fun default' ()
+ = let
+ val {uses,defs,kills}
+ = Instruction.uses_defs_kills instruction
+ val {assembly = assembly_pre,
+ registerAllocation}
+ = RA.pre {uses = uses,
+ defs = defs,
+ kills = kills,
+ info = info,
+ registerAllocation = registerAllocation}
+
+ val {operand = final_src,
+ assembly = assembly_src,
+ fltrename = fltrename_src,
+ registerAllocation}
+ = RA.allocateFltOperand
+ {operand = src,
+ options = {fltregister = true,
+ address = false},
+ info = info,
+ size = srcsize,
+ move = true,
+ supports = [dst],
+ saves = [],
+ top = SOME true,
+ registerAllocation = registerAllocation}
+
+ val {operand = final_dst,
+ assembly = assembly_dst,
+ fltrename = fltrename_dst,
+ registerAllocation}
+ = RA.allocateFltOperand
+ {operand = dst,
+ options = {fltregister = false,
+ address = true},
+ info = info,
+ size = dstsize,
+ move = false,
+ supports = [],
+ saves = [src,final_src],
+ top = SOME false,
+ registerAllocation = registerAllocation}
+
+ val final_src = (RA.fltrenameLift fltrename_dst) final_src
+
+ val instruction
+ = Instruction.FST
+ {dst = final_dst,
+ size = dstsize,
+ pop = true}
+
+ val {fltrename = fltrename_pop,
+ registerAllocation}
+ = RA.fltpop {registerAllocation = registerAllocation}
+
+ val {uses = final_uses,
+ defs = final_defs,
+ ...}
+ = Instruction.uses_defs_kills instruction
+
+ val final_uses
+ = List.revMap(final_uses, RA.fltrenameLift fltrename_pop)
+ val final_defs
+ = List.revMap(final_defs, RA.fltrenameLift fltrename_pop)
+
+ val {assembly = assembly_post,
+ registerAllocation}
+ = RA.post {uses = uses,
+ final_uses = final_uses,
+ defs = defs,
+ final_defs = final_defs,
+ kills = kills,
+ info = info,
+ registerAllocation = registerAllocation}
+ in
+ {assembly
+ = AppendList.appends
+ [assembly_pre,
+ assembly_src,
+ assembly_dst,
+ AppendList.single
+ (Assembly.instruction instruction),
+ assembly_post],
+ registerAllocation = registerAllocation}
+ end
+ in
+ case (src,dst)
+ of (Operand.MemLoc memloc_src,
+ Operand.MemLoc memloc_dst)
+ => (case (RA.fltallocated {memloc = memloc_src,
+ registerAllocation
+ = registerAllocation},
+ RA.fltallocated {memloc = memloc_dst,
+ registerAllocation
+ = registerAllocation})
+ of (SOME {fltregister = fltregister_src,
+ sync = sync_src,
+ commit = commit_src,
+ ...},
+ NONE)
+ => if MemLocSet.contains(dead,memloc_src)
+ orelse
+ (MemLocSet.contains(remove,memloc_src)
+ andalso
+ sync_src)
+ then if MemLocSet.contains(remove,
+ memloc_dst)
+ then default' ()
+ else let
+ val registerAllocation
+ = RA.fltupdate
+ {value = {fltregister
+ = fltregister_src,
+ memloc
+ = memloc_dst,
+ weight = 1024,
+ sync = false,
+ commit
+ = commit_src},
+ registerAllocation
+ = registerAllocation}
+
+ val {uses,defs,kills}
+ = Instruction.uses_defs_kills
+ instruction
+ val {assembly = assembly_pre,
+ registerAllocation}
+ = RA.pre
+ {uses = uses,
+ defs = defs,
+ kills = kills,
+ info = info,
+ registerAllocation
+ = registerAllocation}
+
+ val final_uses = []
+ val final_defs
+ = [Operand.fltregister
+ fltregister_src]
+
+ val {assembly = assembly_post,
+ registerAllocation}
+ = RA.post
+ {uses = uses,
+ final_uses = final_uses,
+ defs = defs,
+ final_defs = final_defs,
+ kills = kills,
+ info = info,
+ registerAllocation
+ = registerAllocation}
+ in
+ {assembly
+ = AppendList.appends
+ [assembly_pre,
+ assembly_post],
+ registerAllocation
+ = registerAllocation}
+ end
+ else default ()
+ | _ => default ())
+ | _ => default ()
+ end
+
+
fun removable {memloc,
info as {dead, commit, remove, ...}: Liveness.t,
registerAllocation}
@@ -8615,253 +8864,18 @@
assembly_post],
registerAllocation = registerAllocation}
end
- | pFMOV {src, dst, size}
- (* Pseudo floating-point move.
- *)
- => let
- fun default ()
- = let
- val {uses,defs,kills}
- = Instruction.uses_defs_kills instruction
- val {assembly = assembly_pre,
- registerAllocation}
- = RA.pre {uses = uses,
- defs = defs,
- kills = kills,
- info = info,
- registerAllocation = registerAllocation}
-
- val {operand = final_src,
- assembly = assembly_src,
- fltrename = fltrename_src,
- registerAllocation}
- = RA.allocateFltOperand
- {operand = src,
- options = {fltregister = true,
- address = true},
- info = info,
- size = size,
- move = true,
- supports = [dst],
- saves = [],
- top = SOME false,
- registerAllocation
- = registerAllocation}
-
- val {operand = final_dst,
- assembly = assembly_dst,
- fltrename = fltrename_dst,
- registerAllocation}
- = RA.allocateFltOperand
- {operand = dst,
- options = {fltregister = true,
- address = false},
- info = info,
- size = size,
- move = false,
- supports = [],
- saves = [src,final_src],
- top = NONE,
- registerAllocation
- = registerAllocation}
-
- val final_src = (RA.fltrenameLift fltrename_dst) final_src
-
- val instruction
- = Instruction.FLD
- {src = final_src,
- size = size}
-
- val {uses = final_uses,
- defs = final_defs,
- ...}
- = Instruction.uses_defs_kills instruction
-
- val {assembly = assembly_post,
- registerAllocation}
- = RA.post {uses = uses,
- final_uses = final_uses,
- defs = defs,
- final_defs = final_defs,
- kills = kills,
- info = info,
- registerAllocation = registerAllocation}
- in
- {assembly
- = AppendList.appends
- [assembly_pre,
- assembly_src,
- assembly_dst,
- AppendList.single
- (Assembly.instruction instruction),
- assembly_post],
- registerAllocation = registerAllocation}
- end
-
- fun default' ()
- = let
- val {uses,defs,kills}
- = Instruction.uses_defs_kills instruction
- val {assembly = assembly_pre,
- registerAllocation}
- = RA.pre {uses = uses,
- defs = defs,
- kills = kills,
- info = info,
- registerAllocation = registerAllocation}
-
- val {operand = final_src,
- assembly = assembly_src,
- fltrename = fltrename_src,
- registerAllocation}
- = RA.allocateFltOperand
- {operand = src,
- options = {fltregister = true,
- address = false},
- info = info,
- size = size,
- move = true,
- supports = [dst],
- saves = [],
- top = SOME true,
- registerAllocation = registerAllocation}
-
- val {operand = final_dst,
- assembly = assembly_dst,
- fltrename = fltrename_dst,
- registerAllocation}
- = RA.allocateFltOperand
- {operand = dst,
- options = {fltregister = false,
- address = true},
- info = info,
- size = size,
- move = false,
- supports = [],
- saves = [src,final_src],
- top = SOME false,
- registerAllocation = registerAllocation}
-
- val final_src = (RA.fltrenameLift fltrename_dst) final_src
-
- val instruction
- = Instruction.FST
- {dst = final_dst,
- size = size,
- pop = true}
-
- val {fltrename = fltrename_pop,
- registerAllocation}
- = RA.fltpop {registerAllocation = registerAllocation}
-
- val {uses = final_uses,
- defs = final_defs,
- ...}
- = Instruction.uses_defs_kills instruction
-
- val final_uses
- = List.revMap(final_uses, RA.fltrenameLift fltrename_pop)
- val final_defs
- = List.revMap(final_defs, RA.fltrenameLift fltrename_pop)
-
- val {assembly = assembly_post,
- registerAllocation}
- = RA.post {uses = uses,
- final_uses = final_uses,
- defs = defs,
- final_defs = final_defs,
- kills = kills,
- info = info,
- registerAllocation = registerAllocation}
- in
- {assembly
- = AppendList.appends
- [assembly_pre,
- assembly_src,
- assembly_dst,
- AppendList.single
- (Assembly.instruction instruction),
- assembly_post],
- registerAllocation = registerAllocation}
- end
- in
- case (src,dst)
- of (Operand.MemLoc memloc_src,
- Operand.MemLoc memloc_dst)
- => (case (RA.fltallocated {memloc = memloc_src,
- registerAllocation
- = registerAllocation},
- RA.fltallocated {memloc = memloc_dst,
- registerAllocation
- = registerAllocation})
- of (SOME {fltregister = fltregister_src,
- sync = sync_src,
- commit = commit_src,
- ...},
- NONE)
- => if MemLocSet.contains(dead,memloc_src)
- orelse
- (MemLocSet.contains(remove,memloc_src)
- andalso
- sync_src)
- then if MemLocSet.contains(remove,
- memloc_dst)
- then default' ()
- else let
- val registerAllocation
- = RA.fltupdate
- {value = {fltregister
- = fltregister_src,
- memloc
- = memloc_dst,
- weight = 1024,
- sync = false,
- commit
- = commit_src},
- registerAllocation
- = registerAllocation}
-
- val {uses,defs,kills}
- = Instruction.uses_defs_kills
- instruction
- val {assembly = assembly_pre,
- registerAllocation}
- = RA.pre
- {uses = uses,
- defs = defs,
- kills = kills,
- info = info,
- registerAllocation
- = registerAllocation}
-
- val final_uses = []
- val final_defs
- = [Operand.fltregister
- fltregister_src]
-
- val {assembly = assembly_post,
- registerAllocation}
- = RA.post
- {uses = uses,
- final_uses = final_uses,
- defs = defs,
- final_defs = final_defs,
- kills = kills,
- info = info,
- registerAllocation
- = registerAllocation}
- in
- {assembly
- = AppendList.appends
- [assembly_pre,
- assembly_post],
- registerAllocation
- = registerAllocation}
- end
- else default ()
- | _ => default ())
- | _ => default ()
- end
+ | pFMOV {src, dst, size} => pfmov {instruction = instruction, info = info,
+ registerAllocation = registerAllocation,
+ src = src, dst = dst,
+ srcsize = size, dstsize = size}
+ | pFMOVX {src, dst, srcsize, dstsize} => pfmov {instruction = instruction, info = info,
+ registerAllocation = registerAllocation,
+ src = src, dst = dst,
+ srcsize = srcsize, dstsize = dstsize}
+ | pFXVOM {src, dst, srcsize, dstsize} => pfmov {instruction = instruction, info = info,
+ registerAllocation = registerAllocation,
+ src = src, dst = dst,
+ srcsize = srcsize, dstsize = dstsize}
| pFLDC {oper, dst, size}
(* Pseudo floating-point load constant.
*)
1.46 +16 -10 mlton/mlton/codegen/x86-codegen/x86-codegen.fun
Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- x86-codegen.fun 19 Jul 2003 01:23:27 -0000 1.45
+++ x86-codegen.fun 25 Jul 2003 20:14:47 -0000 1.46
@@ -273,16 +273,22 @@
of Fail s => s
| _ => "?"))
- val _
- = Assert.assert
- ("x86CodeGen.output: invalid",
- fn () => x86Validate.validate
- {assembly = allocated_assembly}
- handle exn
- => Error.bug ("x86Validate.validate::" ^
- (case exn
- of Fail s => s
- | _ => "?")))
+ val _ =
+(*
+ Assert.assert
+ ("x86CodeGen.output: invalid",
+ fn () =>
+*)
+ (ignore (x86Validate.validate
+ {assembly = allocated_assembly}))
+ handle exn =>
+ Error.warning ("x86Validate.validate::" ^
+ (case exn of
+ Fail s => s
+ | _ => "?"))
+(*
+ )
+*)
val validated_assembly = allocated_assembly
1.43 +16 -4 mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun
Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- x86-generate-transfers.fun 19 Jul 2003 01:23:27 -0000 1.42
+++ x86-generate-transfers.fun 25 Jul 2003 20:14:47 -0000 1.43
@@ -518,7 +518,7 @@
(x86.Assembly.instruction_mov
{dst = dst,
src = Operand.memloc
- (MemLoc.cReturnTempContents
+ (MemLoc.cReturnTempContent
dstsize),
size = dstsize})
| Size.FLT
@@ -526,7 +526,7 @@
(x86.Assembly.instruction_pfmov
{dst = dst,
src = Operand.memloc
- (MemLoc.cReturnTempContents
+ (MemLoc.cReturnTempContent
dstsize),
size = dstsize})
| _ => Error.bug "CReturn")
@@ -1085,6 +1085,7 @@
= livenessTransfer {transfer = transfer,
liveInfo = liveInfo}
val c_stackP = x86MLton.c_stackPContentsOperand
+ val c_stackPDerefFloat = x86MLton.c_stackPDerefFloatOperand
val c_stackPDerefDouble = x86MLton.c_stackPDerefDoubleOperand
val applyFFTemp = x86MLton.applyFFTempContentsOperand
val (pushArgs, size_args)
@@ -1103,6 +1104,17 @@
{src = arg,
dst = c_stackPDerefDouble,
size = size}]
+ else if Size.eq (size, Size.SNGL)
+ then AppendList.fromList
+ [Assembly.instruction_binal
+ {oper = Instruction.SUB,
+ dst = c_stackP,
+ src = Operand.immediate_const_int 4,
+ size = pointerSize},
+ Assembly.instruction_pfmov
+ {src = arg,
+ dst = c_stackPDerefFloat,
+ size = size}]
else if Size.eq (size, Size.BYTE)
then AppendList.fromList
[Assembly.instruction_movx
@@ -1280,11 +1292,11 @@
of Size.INT
=> AppendList.single
(Assembly.directive_return
- {memloc = MemLoc.cReturnTempContents dstsize})
+ {memloc = MemLoc.cReturnTempContent dstsize})
| Size.FLT
=> AppendList.single
(Assembly.directive_fltreturn
- {memloc = MemLoc.cReturnTempContents dstsize})
+ {memloc = MemLoc.cReturnTempContent dstsize})
| _ => Error.bug "CCall")
val fixCStack =
if size_args > 0
1.13 +2 -2 mlton/mlton/codegen/x86-codegen/x86-live-transfers.fun
Index: x86-live-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-live-transfers.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- x86-live-transfers.fun 12 Jul 2002 01:00:19 -0000 1.12
+++ x86-live-transfers.fun 25 Jul 2003 20:14:47 -0000 1.13
@@ -868,14 +868,14 @@
| SOME dstsize
=> (case Size.class dstsize
of Size.INT
- => ([(MemLoc.cReturnTempContents
+ => ([(MemLoc.cReturnTempContent
dstsize,
Register.return dstsize,
ref true)],
[])
| Size.FLT
=> ([],
- [(MemLoc.cReturnTempContents
+ [(MemLoc.cReturnTempContent
dstsize,
ref true)])
| _ => Error.bug "CCall")}
1.21 +74 -23 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- x86-mlton-basic.fun 19 Jul 2003 01:23:27 -0000 1.20
+++ x86-mlton-basic.fun 25 Jul 2003 20:14:47 -0000 1.21
@@ -211,6 +211,14 @@
class = Classes.CStack}
val c_stackPDerefDoubleOperand
= Operand.memloc c_stackPDerefDouble
+ val c_stackPDerefFloat
+ = MemLoc.simple {base = c_stackPContents,
+ index = Immediate.const_int 0,
+ scale = wordScale,
+ size = Size.SNGL,
+ class = Classes.CStack}
+ val c_stackPDerefFloatOperand
+ = Operand.memloc c_stackPDerefFloat
val threadTemp = Label.fromString "threadTemp"
val threadTempContents
@@ -244,29 +252,65 @@
val applyFFTempContentsOperand
= Operand.memloc applyFFTempContents
- val realTemp1 = Label.fromString "realTemp1"
- val realTemp1Contents
- = makeContents {base = Immediate.label realTemp1,
- size = floatSize,
- class = Classes.StaticTemp}
- val realTemp1ContentsOperand
- = Operand.memloc realTemp1Contents
-
- val realTemp2 = Label.fromString "realTemp2"
- val realTemp2Contents
- = makeContents {base = Immediate.label realTemp2,
- size = floatSize,
- class = Classes.StaticTemp}
- val realTemp2ContentsOperand
- = Operand.memloc realTemp2Contents
-
- val realTemp3 = Label.fromString "realTemp3"
- val realTemp3Contents
- = makeContents {base = Immediate.label realTemp3,
- size = floatSize,
- class = Classes.StaticTemp}
- val realTemp3ContentsOperand
- = Operand.memloc realTemp3Contents
+ val realTemp1D = Label.fromString "realTemp1D"
+ val realTemp1ContentsD
+ = makeContents {base = Immediate.label realTemp1D,
+ size = Size.DBLE,
+ class = Classes.StaticTemp}
+ val realTemp1ContentsOperandD
+ = Operand.memloc realTemp1ContentsD
+ val realTemp1S = Label.fromString "realTemp1S"
+ val realTemp1ContentsS
+ = makeContents {base = Immediate.label realTemp1S,
+ size = Size.SNGL,
+ class = Classes.StaticTemp}
+ val realTemp1ContentsOperandS
+ = Operand.memloc realTemp1ContentsS
+ fun realTemp1ContentsOperand floatSize
+ = case floatSize of
+ Size.DBLE => realTemp1ContentsOperandD
+ | Size.SNGL => realTemp1ContentsOperandD
+ | _ => Error.bug "realTemp1ContentsOperand: floatSize"
+
+ val realTemp2D = Label.fromString "realTemp2D"
+ val realTemp2ContentsD
+ = makeContents {base = Immediate.label realTemp2D,
+ size = Size.DBLE,
+ class = Classes.StaticTemp}
+ val realTemp2ContentsOperandD
+ = Operand.memloc realTemp2ContentsD
+ val realTemp2S = Label.fromString "realTemp2S"
+ val realTemp2ContentsS
+ = makeContents {base = Immediate.label realTemp2S,
+ size = Size.SNGL,
+ class = Classes.StaticTemp}
+ val realTemp2ContentsOperandS
+ = Operand.memloc realTemp2ContentsS
+ fun realTemp2ContentsOperand floatSize
+ = case floatSize of
+ Size.DBLE => realTemp2ContentsOperandD
+ | Size.SNGL => realTemp2ContentsOperandD
+ | _ => Error.bug "realTemp2ContentsOperand: floatSize"
+
+ val realTemp3D = Label.fromString "realTemp3D"
+ val realTemp3ContentsD
+ = makeContents {base = Immediate.label realTemp3D,
+ size = Size.DBLE,
+ class = Classes.StaticTemp}
+ val realTemp3ContentsOperandD
+ = Operand.memloc realTemp3ContentsD
+ val realTemp3S = Label.fromString "realTemp3S"
+ val realTemp3ContentsS
+ = makeContents {base = Immediate.label realTemp3S,
+ size = Size.SNGL,
+ class = Classes.StaticTemp}
+ val realTemp3ContentsOperandS
+ = Operand.memloc realTemp3ContentsS
+ fun realTemp3ContentsOperand floatSize
+ = case floatSize of
+ Size.DBLE => realTemp3ContentsOperandD
+ | Size.SNGL => realTemp3ContentsOperandD
+ | _ => Error.bug "realTemp3ContentsOperand: floatSize"
val fpswTemp = Label.fromString "fpswTemp"
val fpswTempContents
@@ -275,6 +319,13 @@
class = Classes.StaticTemp}
val fpswTempContentsOperand
= Operand.memloc fpswTempContents
+ val fildTemp = Label.fromString "fildTemp"
+ val fildTempContents
+ = makeContents {base = Immediate.label fildTemp,
+ size = Size.WORD,
+ class = Classes.StaticTemp}
+ val fildTempContentsOperand
+ = Operand.memloc fildTempContents
local
val localI_base =
1.26 +5 -3 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- x86-mlton-basic.sig 19 Jul 2003 01:23:27 -0000 1.25
+++ x86-mlton-basic.sig 25 Jul 2003 20:14:47 -0000 1.26
@@ -76,14 +76,16 @@
val c_stackPContentsOperand : x86.Operand.t
val c_stackPDerefOperand : x86.Operand.t
val c_stackPDerefDoubleOperand : x86.Operand.t
+ val c_stackPDerefFloatOperand : x86.Operand.t
(* Static temps defined in x86-main.h *)
val applyFFTempContentsOperand : x86.Operand.t
val threadTempContentsOperand : x86.Operand.t
val fileTempContentsOperand : x86.Operand.t
- val realTemp1ContentsOperand : x86.Operand.t
- val realTemp2ContentsOperand : x86.Operand.t
- val realTemp3ContentsOperand : x86.Operand.t
+ val realTemp1ContentsOperand : x86.Size.t -> x86.Operand.t
+ val realTemp2ContentsOperand : x86.Size.t -> x86.Operand.t
+ val realTemp3ContentsOperand : x86.Size.t -> x86.Operand.t
+ val fildTempContentsOperand : x86.Operand.t
val fpswTempContentsOperand : x86.Operand.t
val statusTempContentsOperand : x86.Operand.t
1.47 +251 -67 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- x86-mlton.fun 19 Jul 2003 01:23:27 -0000 1.46
+++ x86-mlton.fun 25 Jul 2003 20:14:47 -0000 1.47
@@ -595,61 +595,151 @@
| _ => Error.bug "prim: FFI"],
transfer = NONE}]
end
- | Int_ge _ => cmp Instruction.GE
- | Int_gt _ => cmp Instruction.G
- | Int_le _ => cmp Instruction.LE
- | Int_lt _ => cmp Instruction.L
+ | Int_add s =>
+ (case s of
+ I8 => binal Instruction.ADD
+ | I16 => binal Instruction.ADD
+ | I32 => binal Instruction.ADD
+ | I64 => Error.bug "FIXME")
+ | Int_ge s =>
+ (case s of
+ I8 => cmp Instruction.GE
+ | I16 => cmp Instruction.GE
+ | I32 => cmp Instruction.GE
+ | I64 => Error.bug "FIXME")
+ | Int_gt s =>
+ (case s of
+ I8 => cmp Instruction.G
+ | I16 => cmp Instruction.G
+ | I32 => cmp Instruction.G
+ | I64 => Error.bug "FIXME")
+ | Int_le s =>
+ (case s of
+ I8 => cmp Instruction.LE
+ | I16 => cmp Instruction.LE
+ | I32 => cmp Instruction.LE
+ | I64 => Error.bug "FIXME")
+ | Int_lt s =>
+ (case s of
+ I8 => cmp Instruction.L
+ | I16 => cmp Instruction.L
+ | I32 => cmp Instruction.L
+ | I64 => Error.bug "FIXME")
| Int_mul s =>
- (case s of
- I8 => pmd Instruction.IMUL
- | I16 => imul2 ()
- | I32 => imul2 ()
- | I64 => Error.bug "FIXME")
- | Int_neg _ => unal Instruction.NEG
- | Int_quot _ => pmd Instruction.IDIV
- | Int_rem _ => pmd Instruction.IMOD
- | Int_sub _ => binal Instruction.SUB
- | Int_add _ => binal Instruction.ADD
+ (case s of
+ I8 => pmd Instruction.IMUL
+ | I16 => imul2 ()
+ | I32 => imul2 ()
+ | I64 => Error.bug "FIXME")
+ | Int_neg s =>
+ (case s of
+ I8 => unal Instruction.NEG
+ | I16 => unal Instruction.NEG
+ | I32 => unal Instruction.NEG
+ | I64 => Error.bug "FIXME")
+ | Int_quot s =>
+ (case s of
+ I8 => pmd Instruction.IDIV
+ | I16 => pmd Instruction.IDIV
+ | I32 => pmd Instruction.IDIV
+ | I64 => Error.bug "FIXME")
+ | Int_rem s =>
+ (case s of
+ I8 => pmd Instruction.IMOD
+ | I16 => pmd Instruction.IMOD
+ | I32 => pmd Instruction.IMOD
+ | I64 => Error.bug "FIXME")
+ | Int_sub s =>
+ (case s of
+ I8 => binal Instruction.SUB
+ | I16 => binal Instruction.SUB
+ | I32 => binal Instruction.SUB
+ | I64 => Error.bug "FIXME")
| Int_toInt (s, s') =>
(case (s, s') of
- (I32, I32) => mov ()
- | (I32, I16) => xvom ()
- | (I32, I8) => xvom ()
- | (I16, I32) => movx Instruction.MOVSX
- | (I16, I16) => mov ()
- | (I16, I8) => xvom ()
- | (I8, I32) => movx Instruction.MOVSX
- | (I8, I16) => movx Instruction.MOVSX
- | (I8, I8) => mov ()
- | _ => Error.bug (Prim.toString prim))
- | Int_toReal _
- => let
- val (dst,dstsize) = getDst ()
- val (src,srcsize) = getSrc1 ()
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_pfmovfi
- {dst = dst,
- src = src,
- srcsize = srcsize,
- dstsize = dstsize}],
- transfer = NONE}]
- end
+ (I64, I64) => Error.bug "FIXME"
+ | (I64, I32) => Error.bug "FIXME"
+ | (I64, I16) => Error.bug "FIXME"
+ | (I64, I8) => Error.bug "FIXME"
+ | (I32, I64) => Error.bug "FIXME"
+ | (I32, I32) => mov ()
+ | (I32, I16) => xvom ()
+ | (I32, I8) => xvom ()
+ | (I16, I64) => Error.bug "FIXME"
+ | (I16, I32) => movx Instruction.MOVSX
+ | (I16, I16) => mov ()
+ | (I16, I8) => xvom ()
+ | (I8, I64) => Error.bug "FIXME"
+ | (I8, I32) => movx Instruction.MOVSX
+ | (I8, I16) => movx Instruction.MOVSX
+ | (I8, I8) => mov ())
+ | Int_toReal (s, s')
+ => let
+ fun default () =
+ let
+ val (dst,dstsize) = getDst ()
+ val (src,srcsize) = getSrc1 ()
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfmovfi
+ {src = src,
+ dst = dst,
+ srcsize = srcsize,
+ dstsize = dstsize}],
+ transfer = NONE}]
+ end
+ fun default' () =
+ let
+ val (dst,dstsize) = getDst ()
+ val (src,srcsize) = getSrc1 ()
+ val (tmp,tmpsize) =
+ (fildTempContentsOperand, Size.WORD)
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_movx
+ {oper = Instruction.MOVSX,
+ src = src,
+ dst = tmp,
+ dstsize = tmpsize,
+ srcsize = srcsize},
+ Assembly.instruction_pfmovfi
+ {src = tmp,
+ dst = dst,
+ srcsize = tmpsize,
+ dstsize = dstsize}],
+ transfer = NONE}]
+ end
+ in
+ case (s, s') of
+ (I64, R64) => Error.bug "FIXME"
+ | (I64, R32) => Error.bug "FIXME"
+ | (I32, R64) => default ()
+ | (I32, R32) => default ()
+ | (I16, R64) => default ()
+ | (I16, R32) => default ()
+ | (I8, R64) => default' ()
+ | (I8, R32) => default' ()
+ end
| Int_toWord (s, s') =>
(case (s, s') of
- (I32, W32) => mov ()
- | (I32, W16) => xvom ()
- | (I32, W8) => xvom ()
- | (I16, W32) => movx Instruction.MOVSX
- | (I16, W16) => mov ()
- | (I16, W8) => xvom ()
- | (I8, W32) => movx Instruction.MOVSX
- | (I8, W16) => movx Instruction.MOVSX
- | (I8, W8) => mov ()
- | _ => Error.bug (Prim.toString prim))
+ (I64, W32) => Error.bug "FIXME"
+ | (I64, W16) => Error.bug "FIXME"
+ | (I64, W8) => Error.bug "FIXME"
+ | (I32, W32) => mov ()
+ | (I32, W16) => xvom ()
+ | (I32, W8) => xvom ()
+ | (I16, W32) => movx Instruction.MOVSX
+ | (I16, W16) => mov ()
+ | (I16, W8) => xvom ()
+ | (I8, W32) => movx Instruction.MOVSX
+ | (I8, W16) => movx Instruction.MOVSX
+ | (I8, W8) => mov ())
| MLton_eq => cmp Instruction.E
| Real_Math_acos _
=> let
@@ -659,6 +749,9 @@
= Assert.assert
("applyPrim: Real_Math_acos, dstsize/srcsize",
fn () => srcsize = dstsize)
+ val realTemp1ContentsOperand = realTemp1ContentsOperand srcsize
+ val realTemp2ContentsOperand = realTemp2ContentsOperand srcsize
+ val realTemp3ContentsOperand = realTemp3ContentsOperand srcsize
in
AppendList.fromList
[Block.mkBlock'
@@ -709,6 +802,9 @@
= Assert.assert
("applyPrim: Real_Math_asin, dstsize/srcsize",
fn () => srcsize = dstsize)
+ val realTemp1ContentsOperand = realTemp1ContentsOperand srcsize
+ val realTemp2ContentsOperand = realTemp2ContentsOperand srcsize
+ val realTemp3ContentsOperand = realTemp3ContentsOperand srcsize
in
AppendList.fromList
[Block.mkBlock'
@@ -721,25 +817,25 @@
Assembly.instruction_pfmov
{dst = realTemp1ContentsOperand,
src = dst,
- size = srcsize},
+ size = dstsize},
Assembly.instruction_pfbina
{oper = Instruction.FMUL,
dst = realTemp1ContentsOperand,
src = realTemp1ContentsOperand,
- size = srcsize},
+ size = dstsize},
Assembly.instruction_pfldc
{oper = Instruction.ONE,
dst = realTemp2ContentsOperand,
- size = srcsize},
+ size = dstsize},
Assembly.instruction_pfbina
{oper = Instruction.FSUB,
dst = realTemp2ContentsOperand,
src = realTemp1ContentsOperand,
- size = srcsize},
+ size = dstsize},
Assembly.instruction_pfuna
{oper = Instruction.FSQRT,
dst = realTemp2ContentsOperand,
- size = srcsize},
+ size = dstsize},
Assembly.instruction_pfbinasp
{oper = Instruction.FPATAN,
src = realTemp2ContentsOperand,
@@ -755,6 +851,9 @@
= Assert.assert
("applyPrim: Real_Math_atan, dstsize/srcsize",
fn () => srcsize = dstsize)
+ val realTemp1ContentsOperand = realTemp1ContentsOperand srcsize
+ val realTemp2ContentsOperand = realTemp2ContentsOperand srcsize
+ val realTemp3ContentsOperand = realTemp3ContentsOperand srcsize
in
AppendList.fromList
[Block.mkBlock'
@@ -810,6 +909,9 @@
= Assert.assert
("applyPrim: Real_Math_exp, dstsize/srcsize",
fn () => srcsize = dstsize)
+ val realTemp1ContentsOperand = realTemp1ContentsOperand srcsize
+ val realTemp2ContentsOperand = realTemp2ContentsOperand srcsize
+ val realTemp3ContentsOperand = realTemp3ContentsOperand srcsize
in
AppendList.fromList
[Block.mkBlock'
@@ -1081,21 +1183,100 @@
transfer = NONE}]
end
| Real_abs _ => funa Instruction.FABS
- | Real_toInt _
+ | Real_toInt (s, s')
+ => let
+ fun default () =
+ let
+ val (dst,dstsize) = getDst ()
+ val (src,srcsize) = getSrc1 ()
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfmovti
+ {dst = dst,
+ src = src,
+ srcsize = srcsize,
+ dstsize = dstsize}],
+ transfer = NONE}]
+ end
+ fun default' () =
+ let
+ val (dst,dstsize) = getDst ()
+ val (src,srcsize) = getSrc1 ()
+ val (tmp,tmpsize) =
+ (fildTempContentsOperand, Size.WORD)
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfmovti
+ {dst = dst,
+ src = src,
+ srcsize = srcsize,
+ dstsize = dstsize},
+ Assembly.instruction_xvom
+ {src = tmp,
+ dst = dst,
+ dstsize = dstsize,
+ srcsize = tmpsize}],
+ transfer = NONE}]
+ end
+ in
+ case (s, s') of
+ (R64, I64) => Error.bug "FIXME"
+ | (R64, I32) => default ()
+ | (R64, I16) => default ()
+ | (R64, I8) => default' ()
+ | (R32, I64) => Error.bug "FIXME"
+ | (R32, I32) => default ()
+ | (R32, I16) => default ()
+ | (R32, I8) => default' ()
+ end
+ | Real_toReal (s, s')
=> let
val (dst,dstsize) = getDst ()
val (src,srcsize) = getSrc1 ()
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_pfmovti
- {dst = dst,
- src = src,
- srcsize = srcsize,
- dstsize = dstsize}],
- transfer = NONE}]
+ fun mov () =
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfmov
+ {dst = dst,
+ src = src,
+ size = srcsize}],
+ transfer = NONE}]
+ fun movx () =
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfmovx
+ {dst = dst,
+ src = src,
+ srcsize = srcsize,
+ dstsize = dstsize}],
+ transfer = NONE}]
+ fun xvom () =
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfxvom
+ {dst = dst,
+ src = src,
+ srcsize = srcsize,
+ dstsize = dstsize}],
+ transfer = NONE}]
+ in
+ case (s, s') of
+ (R64, R64) => mov ()
+ | (R64, R32) => xvom ()
+ | (R32, R64) => movx ()
+ | (R32, R32) => mov ()
end
| Real_ldexp _
=> let
@@ -1110,6 +1291,9 @@
= Assert.assert
("applyPrim: Real_qequal, src2size",
fn () => src2size = Size.LONG)
+ val realTemp1ContentsOperand = realTemp1ContentsOperand src1size
+ val realTemp2ContentsOperand = realTemp2ContentsOperand src1size
+ val realTemp3ContentsOperand = realTemp3ContentsOperand src1size
in
AppendList.fromList
[Block.mkBlock'
1.19 +9 -1 mlton/mlton/codegen/x86-codegen/x86-pseudo.sig
Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- x86-pseudo.sig 19 Jul 2003 01:23:27 -0000 1.18
+++ x86-pseudo.sig 25 Jul 2003 20:14:47 -0000 1.19
@@ -10,7 +10,7 @@
signature X86_PSEUDO =
sig
- structure CFunction: C_FUNCTION
+ structure CFunction: C_FUNCTION
structure Label : HASH_ID
structure Runtime: RUNTIME
sharing CFunction.CType = Runtime.CType
@@ -351,6 +351,14 @@
val instruction_pfmov : {src: Operand.t,
dst: Operand.t,
size: Size.t} -> t
+ val instruction_pfmovx : {src: Operand.t,
+ dst: Operand.t,
+ srcsize: Size.t,
+ dstsize: Size.t} -> t
+ val instruction_pfxvom : {src: Operand.t,
+ dst: Operand.t,
+ srcsize: Size.t,
+ dstsize: Size.t} -> t
val instruction_pfldc : {oper: Instruction.fldc,
dst: Operand.t,
size: Size.t} -> t
1.46 +1 -1 mlton/mlton/codegen/x86-codegen/x86-translate.fun
Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- x86-translate.fun 19 Jul 2003 01:23:27 -0000 1.45
+++ x86-translate.fun 25 Jul 2003 20:14:47 -0000 1.46
@@ -440,7 +440,7 @@
=> x86.Assembly.instruction_pfmov
{dst = dst,
src = value,
- size = size}
+ size = size}
| _ => Error.bug "toX86Blocks: Allocate")::l
end
in
1.40 +62 -25 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- x86.fun 19 Jul 2003 01:23:27 -0000 1.39
+++ x86.fun 25 Jul 2003 20:14:47 -0000 1.40
@@ -1200,31 +1200,24 @@
size = size,
class = class}
local
- open CType
- val cReturnTempBYTE = Label.fromString "cReturnTempB"
- val cReturnTempBYTEContents
- = makeContents {base = Immediate.label cReturnTempBYTE,
- size = Size.BYTE,
- class = Class.StaticTemp}
- val cReturnTempDBLE = Label.fromString "cReturnTempD"
- val cReturnTempDBLEContents
- = makeContents {base = Immediate.label cReturnTempDBLE,
- size = Size.DBLE,
- class = Class.StaticTemp}
- val cReturnTempLONG = Label.fromString "cReturnTempL"
- val cReturnTempLONGContents
- = makeContents {base = Immediate.label cReturnTempLONG,
- size = Size.LONG,
- class = Class.StaticTemp}
+ val cReturnTemp = Label.fromString "cReturnTemp"
+ fun cReturnTempContent (index, size) =
+ imm
+ {base = Immediate.label cReturnTemp,
+ index = Immediate.const_int index,
+ scale = Scale.One,
+ size = size,
+ class = Class.StaticTemp}
in
- fun cReturnTempContents size
- = case size
- of Size.BYTE => cReturnTempBYTEContents
- | Size.DBLE => cReturnTempDBLEContents
- | Size.LONG => cReturnTempLONGContents
- | _ => Error.bug "cReturnTempContents: size"
+ fun cReturnTempContents sizes =
+ (List.rev o #1)
+ (List.fold
+ (sizes, ([],0), fn (size, (contents, index)) =>
+ ((cReturnTempContent (index, size))::contents,
+ index + Size.toBytes size)))
+ fun cReturnTempContent size =
+ List.first(cReturnTempContents [size])
end
-
end
local
@@ -1761,6 +1754,18 @@
| pFMOV of {src: Operand.t,
dst: Operand.t,
size: Size.t}
+ (* Pseudo floating-point move with extension.
+ *)
+ | pFMOVX of {src: Operand.t,
+ dst: Operand.t,
+ srcsize: Size.t,
+ dstsize: Size.t}
+ (* Pseudo floating-point move with contraction.
+ *)
+ | pFXVOM of {src: Operand.t,
+ dst: Operand.t,
+ srcsize: Size.t,
+ dstsize: Size.t}
(* Pseudo floating-point load constant.
*)
| pFLDC of {oper: fldc,
@@ -2030,6 +2035,18 @@
Size.layout size,
Operand.layout src,
Operand.layout dst)
+ | pFMOVX {src, dst, srcsize, dstsize}
+ => bin (str "fmovx",
+ seq [Size.layout srcsize,
+ Size.layout dstsize],
+ Operand.layout src,
+ Operand.layout dst)
+ | pFXVOM {src, dst, srcsize, dstsize}
+ => bin (str "fmov",
+ seq [Size.layout srcsize,
+ Size.layout dstsize],
+ Operand.layout src,
+ Operand.layout dst)
| pFLDC {oper, dst, size}
=> un (fldc_layout oper,
Size.layout size,
@@ -2303,6 +2320,10 @@
=> {uses = [src], defs = [dst], kills = []}
| pFMOV {src, dst, size}
=> {uses = [src], defs = [dst], kills = []}
+ | pFMOVX {src, dst, srcsize, dstsize}
+ => {uses = [src], defs = [dst], kills = []}
+ | pFXVOM {src, dst, srcsize, dstsize}
+ => {uses = [src], defs = [dst], kills = []}
| pFLDC {oper, dst, size}
=> {uses = [], defs = [dst], kills = []}
| pFMOVFI {src, dst, srcsize, dstsize}
@@ -2601,6 +2622,10 @@
=> {srcs = SOME [src], dsts = SOME [dst]}
| pFMOV {src, dst, size}
=> {srcs = SOME [src], dsts = SOME [dst]}
+ | pFMOVX {src, dst, srcsize, dstsize}
+ => {srcs = SOME [src], dsts = SOME [dst]}
+ | pFXVOM {src, dst, srcsize, dstsize}
+ => {srcs = SOME [src], dsts = SOME [dst]}
| pFLDC {oper, dst, size}
=> {srcs = SOME [], dsts = SOME [dst]}
| pFMOVFI {src, dst, srcsize, dstsize}
@@ -2775,6 +2800,14 @@
=> pFMOV {src = replacer {use = true, def = false} src,
dst = replacer {use = false, def = true} dst,
size = size}
+ | pFMOVX {src, dst, srcsize, dstsize}
+ => pFMOVX {src = replacer {use = true, def = false} src,
+ dst = replacer {use = false, def = true} dst,
+ srcsize = srcsize, dstsize = dstsize}
+ | pFXVOM {src, dst, srcsize, dstsize}
+ => pFXVOM {src = replacer {use = true, def = false} src,
+ dst = replacer {use = false, def = true} dst,
+ srcsize = srcsize, dstsize = dstsize}
| pFLDC {oper, dst, size}
=> pFLDC {oper = oper,
dst = replacer {use = false, def = true} dst,
@@ -2895,6 +2928,8 @@
val xvom = XVOM
val lea = LEA
val pfmov = pFMOV
+ val pfmovx = pFMOVX
+ val pfxvom = pFXVOM
val pfldc = pFLDC
val pfmovfi = pFMOVFI
val pfmovti = pFMOVTI
@@ -3569,6 +3604,8 @@
val instruction_xvom = Instruction o Instruction.xvom
val instruction_lea = Instruction o Instruction.lea
val instruction_pfmov = Instruction o Instruction.pfmov
+ val instruction_pfmovx = Instruction o Instruction.pfmovx
+ val instruction_pfxvom = Instruction o Instruction.pfxvom
val instruction_pfldc = Instruction o Instruction.pfldc
val instruction_pfmovfi = Instruction o Instruction.pfmovfi
val instruction_pfmovti = Instruction o Instruction.pfmovti
@@ -3685,7 +3722,7 @@
val uses_defs_kills
= fn CReturn {dst = SOME (dst, dstsize), ...}
- => {uses = [Operand.memloc (MemLoc.cReturnTempContents dstsize)],
+ => {uses = [Operand.memloc (MemLoc.cReturnTempContent dstsize)],
defs = [dst], kills = []}
| _ => {uses = [], defs = [], kills = []}
@@ -4003,7 +4040,7 @@
defs = case dstsize
of NONE => []
| SOME dstsize
- => [Operand.memloc (MemLoc.cReturnTempContents dstsize)],
+ => [Operand.memloc (MemLoc.cReturnTempContent dstsize)],
kills = []}
| _ => {uses = [], defs = [], kills = []}
1.28 +21 -1 mlton/mlton/codegen/x86-codegen/x86.sig
Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- x86.sig 19 Jul 2003 01:23:27 -0000 1.27
+++ x86.sig 25 Jul 2003 20:14:47 -0000 1.28
@@ -251,7 +251,7 @@
size: Size.t,
class: Class.t} -> t
(* CReturn locations *)
- val cReturnTempContents : Size.t -> t
+ val cReturnTempContent : Size.t -> t
end
structure ClassSet : SET
@@ -523,6 +523,18 @@
| pFMOV of {src: Operand.t,
dst: Operand.t,
size: Size.t}
+ (* Pseudo floating-point move with extension.
+ *)
+ | pFMOVX of {src: Operand.t,
+ dst: Operand.t,
+ srcsize: Size.t,
+ dstsize: Size.t}
+ (* Pseudo floating-point move with contraction.
+ *)
+ | pFXVOM of {src: Operand.t,
+ dst: Operand.t,
+ srcsize: Size.t,
+ dstsize: Size.t}
(* Pseudo floating-point load constant.
*)
| pFLDC of {oper: fldc,
@@ -950,6 +962,14 @@
val instruction_pfmov : {src: Operand.t,
dst: Operand.t,
size: Size.t} -> t
+ val instruction_pfmovx : {src: Operand.t,
+ dst: Operand.t,
+ srcsize: Size.t,
+ dstsize: Size.t} -> t
+ val instruction_pfxvom : {src: Operand.t,
+ dst: Operand.t,
+ srcsize: Size.t,
+ dstsize: Size.t} -> t
val instruction_pfldc : {oper: Instruction.fldc,
dst: Operand.t,
size: Size.t} -> t
1.1 mlton/regression/real32.ok
Index: real32.ok
===================================================================
~inf ~inf
~inf ~inf
~inf ~inf
~inf ~inf
~0.17976931348623157E309 ~inf
~0.17976931348623157E309 ~inf
~0.17976931348623157E309 ~0.34028234663852886E39
~0.17976931348623157E309 ~0.34028234663852886E39
~0.1E1 ~0.1E1
~0.1E1 ~0.1E1
~0.1E1 ~0.1E1
~0.1E1 ~0.1E1
~0.22250738585072014E~307 0.0
~0.22250738585072014E~307 ~0.1401298464324817E~44
~0.22250738585072014E~307 0.0
~0.22250738585072014E~307 0.0
~0.5E~323 0.0
~0.5E~323 ~0.1401298464324817E~44
~0.5E~323 0.0
~0.5E~323 0.0
0.0 0.0
0.0 0.0
0.0 0.0
0.0 0.0
0.5E~323 0.0
0.5E~323 0.0
0.5E~323 0.1401298464324817E~44
0.5E~323 0.0
0.22250738585072014E~307 0.0
0.22250738585072014E~307 0.0
0.22250738585072014E~307 0.1401298464324817E~44
0.22250738585072014E~307 0.0
0.1E1 0.1E1
0.1E1 0.1E1
0.1E1 0.1E1
0.1E1 0.1E1
0.17976931348623157E309 inf
0.17976931348623157E309 0.34028234663852886E39
0.17976931348623157E309 inf
0.17976931348623157E309 0.34028234663852886E39
inf inf
inf inf
inf inf
inf inf
nan nan
nan nan
nan nan
nan nan
1.69 +12 -4 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.68
retrieving revision 1.69
diff -u -r1.68 -r1.69
--- Makefile 24 Jul 2003 19:47:11 -0000 1.68
+++ Makefile 25 Jul 2003 20:14:47 -0000 1.69
@@ -78,16 +78,20 @@
basis/Ptrace/ptrace2.o \
basis/Ptrace/ptrace4.o \
basis/Real/class.o \
+ basis/Real/copysign.o \
+ basis/Real/frexp.o \
basis/Real/gdtoa.o \
basis/Real/isFinite.o \
basis/Real/isNan.o \
basis/Real/isNormal.o \
+ basis/Real/modf.o \
basis/Real/nextAfter.o \
+ basis/Real/pow.o \
basis/Real/real.o \
basis/Real/round.o \
basis/Real/signBit.o \
- basis/Real/strtod.o \
- basis/Real/toReal.o \
+ basis/Real/strto.o \
+ basis/Real/trig.o \
basis/Stdio.o \
basis/Thread.o \
basis/Time.o \
@@ -246,16 +250,20 @@
basis/Ptrace/ptrace2-gdb.o \
basis/Ptrace/ptrace4-gdb.o \
basis/Real/class-gdb.o \
+ basis/Real/copysign-gdb.o \
+ basis/Real/frexp-gdb.o \
basis/Real/gdtoa-gdb.o \
basis/Real/isFinite-gdb.o \
basis/Real/isNan-gdb.o \
basis/Real/isNormal-gdb.o \
+ basis/Real/modf-gdb.o \
basis/Real/nextAfter-gdb.o \
+ basis/Real/pow-gdb.o \
basis/Real/real-gdb.o \
basis/Real/round-gdb.o \
basis/Real/signBit-gdb.o \
- basis/Real/strtod-gdb.o \
- basis/Real/toReal-gdb.o \
+ basis/Real/strto-gdb.o \
+ basis/Real/trig-gdb.o \
basis/Stdio-gdb.o \
basis/Thread-gdb.o \
basis/Time-gdb.o \
1.5 +58 -10 mlton/runtime/basis/Real/class.c
Index: class.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/class.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- class.c 24 Jun 2003 21:26:11 -0000 1.4
+++ class.c 25 Jul 2003 20:14:48 -0000 1.5
@@ -23,6 +23,16 @@
* bits 51-48 of mantissa
* d[7] sign bit
* bits 10-4 of exponent
+ *
+ *
+ * In memory, the 32 bits of a float are layed out as follows.
+ *
+ * d[0] bits 7-0 of mantissa
+ * d[1] bits 15-8 of mantissa
+ * d[2] bit 0 of exponent
+ * bits 22-16 of mantissa
+ * d[7] sign bit
+ * bits 7-2 of exponent
*/
#define Real_Class_nanQuiet 0
@@ -35,10 +45,10 @@
#if (defined __i386__)
/* masks for word 1 */
-#define EXPONENT_MASK 0x7FF00000
-#define MANTISSA_MASK 0x000FFFFF
-#define SIGNBIT_MASK 0x80000000
-#define MANTISSA_HIGHBIT_MASK 0x00080000
+#define EXPONENT_MASK64 0x7FF00000
+#define MANTISSA_MASK64 0x000FFFFF
+#define SIGNBIT_MASK64 0x80000000
+#define MANTISSA_HIGHBIT_MASK64 0x00080000
Int Real64_class (Real64 d) {
Word word0, word1;
@@ -47,11 +57,11 @@
word0 = ((Word *)&d)[0];
word1 = ((Word *)&d)[1];
- if ((word1 & EXPONENT_MASK) == EXPONENT_MASK) {
+ if ((word1 & EXPONENT_MASK64) == EXPONENT_MASK64) {
/* NAN_QUIET, NAN_SIGNALLING, or INF */
- if (word0 or (word1 & MANTISSA_MASK)) {
+ if (word0 or (word1 & MANTISSA_MASK64)) {
/* NAN_QUIET or NAN_SIGNALLING -- look at the highest bit of mantissa */
- if (word1 & MANTISSA_HIGHBIT_MASK)
+ if (word1 & MANTISSA_HIGHBIT_MASK64)
res = Real_Class_nanQuiet;
else
res = Real_Class_nanSignalling;
@@ -59,15 +69,51 @@
res = Real_Class_inf;
} else {
/* ZERO, NORMAL, or SUBNORMAL */
- if (word1 & EXPONENT_MASK)
+ if (word1 & EXPONENT_MASK64)
res = Real_Class_normal;
- else if (word0 or (word1 & MANTISSA_MASK))
+ else if (word0 or (word1 & MANTISSA_MASK64))
res = Real_Class_subnormal;
else
res = Real_Class_zero;
}
if (DEBUG)
- fprintf (stderr, "%d = Real_class (%g)\n", (int)res, d);
+ fprintf (stderr, "%d = Real64_class (%g)\n", (int)res, d);
+ return res;
+}
+
+/* masks for word 0 */
+#define EXPONENT_MASK32 0x7F800000
+#define MANTISSA_MASK32 0x007FFFFF
+#define SIGNBIT_MASK32 0x80000000
+#define MANTISSA_HIGHBIT_MASK32 0x00400000
+
+Int Real32_class (Real32 f) {
+ Word word0;
+ Int res;
+
+ word0 = ((Word *)&f)[0];
+
+ if ((word0 & EXPONENT_MASK32) == EXPONENT_MASK32) {
+ /* NAN_QUIET, NAN_SIGNALLING, or INF */
+ if (word0 & MANTISSA_MASK32) {
+ /* NAN_QUIET or NAN_SIGNALLING -- look at the highest bit of mantissa */
+ if (word0 & MANTISSA_HIGHBIT_MASK32)
+ res = Real_Class_nanQuiet;
+ else
+ res = Real_Class_nanSignalling;
+ } else
+ res = Real_Class_inf;
+ } else {
+ /* ZERO, NORMAL, or SUBNORMAL */
+ if (word0 & EXPONENT_MASK32)
+ res = Real_Class_normal;
+ else if (word0 & MANTISSA_MASK32)
+ res = Real_Class_subnormal;
+ else
+ res = Real_Class_zero;
+ }
+ if (DEBUG)
+ fprintf (stderr, "%d = Real32_class (%g)\n", (int)res, f);
return res;
}
@@ -92,6 +138,8 @@
die ("Real_class error: invalid class %d\n", c);
}
}
+
+#error Real32_class not defined
#else
1.3 +4 -0 mlton/runtime/basis/Real/gdtoa.c
Index: gdtoa.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/gdtoa.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- gdtoa.c 23 Jun 2003 04:59:02 -0000 1.2
+++ gdtoa.c 25 Jul 2003 20:14:48 -0000 1.3
@@ -46,3 +46,7 @@
result, d, mode, ndig, *decpt);
return result;
}
+
+char * Real32_gdtoa (float f, int mode, int ndig, int *decpt) {
+ return Real64_gdtoa ((double)f, mode, ndig, decpt);
+}
1.4 +4 -0 mlton/runtime/basis/Real/isFinite.c
Index: isFinite.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isFinite.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- isFinite.c 23 Jun 2003 04:59:02 -0000 1.3
+++ isFinite.c 25 Jul 2003 20:14:48 -0000 1.4
@@ -4,6 +4,10 @@
#endif
#include "mlton-basis.h"
+Int Real32_isFinite (Real32 f) {
+ return finite (f); /* finite is from math.h */
+}
+
Int Real64_isFinite (Real64 d) {
return finite (d); /* finite is from math.h */
}
1.4 +4 -0 mlton/runtime/basis/Real/isNan.c
Index: isNan.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isNan.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- isNan.c 23 Jun 2003 04:59:02 -0000 1.3
+++ isNan.c 25 Jul 2003 20:14:48 -0000 1.4
@@ -6,6 +6,10 @@
#if (defined (__i386__))
+Int Real32_isNan (Real32 f) {
+ return isnan (f); /* isnan is from math.h */
+}
+
Int Real64_isNan (Real64 d) {
return isnan (d); /* isnan is from math.h */
}
1.4 +16 -3 mlton/runtime/basis/Real/isNormal.c
Index: isNormal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isNormal.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- isNormal.c 23 Jun 2003 04:59:02 -0000 1.3
+++ isNormal.c 25 Jul 2003 20:14:48 -0000 1.4
@@ -7,16 +7,29 @@
#if (defined (__i386__))
-#define EXPONENT_MASK 0x7FF00000
+#define EXPONENT_MASK64 0x7FF00000
Int Real64_isNormal (Real64 d) {
Word word1, exponent;
word1 = ((Word *)&d)[1];
- exponent = word1 & EXPONENT_MASK;
+ exponent = word1 & EXPONENT_MASK64;
- return not (exponent == 0 or exponent == EXPONENT_MASK);
+ return not (exponent == 0 or exponent == EXPONENT_MASK64);
+}
+
+
+#define EXPONENT_MASK32 0x7F800000
+
+Int Real32_isNormal (Real32 f) {
+ Word word0, exponent;
+
+ word0 = ((Word *)&f)[0];
+
+ exponent = word0 & EXPONENT_MASK32;
+
+ return not (exponent == 0 or exponent == EXPONENT_MASK32);
}
#elif (defined __sparc__)
1.3 +4 -0 mlton/runtime/basis/Real/nextAfter.c
Index: nextAfter.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/nextAfter.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- nextAfter.c 23 Jun 2003 04:59:02 -0000 1.2
+++ nextAfter.c 25 Jul 2003 20:14:48 -0000 1.3
@@ -1,6 +1,10 @@
#include <math.h>
#include "mlton-basis.h"
+Real32 Real32_nextAfter (Real32 x1, Real32 x2) {
+ return nextafterf (x1, x2);
+}
+
Real64 Real64_nextAfter (Real64 x1, Real64 x2) {
return nextafter (x1, x2);
}
1.3 +10 -4 mlton/runtime/basis/Real/real.c
Index: real.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/real.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- real.c 23 Jun 2003 04:59:02 -0000 1.2
+++ real.c 25 Jul 2003 20:14:48 -0000 1.3
@@ -2,10 +2,16 @@
#include "basis-constants.h"
#include "mlton-basis.h"
+Real32 Real32_Math_pi = (Real32)M_PI;
+Real32 Real32_Math_e = (Real32)M_E;
+
+Real32 Real32_maxFinite = 3.40282347e+38;
+Real32 Real32_minNormalPos = 1.17549435e-38;
+Real32 Real32_minPos = 1.40129846e-45;
+
Real64 Real64_Math_pi = M_PI;
Real64 Real64_Math_e = M_E;
-Real64 Real64_maxFinite = 1.7976931348623157e308;
-Real64 Real64_minNormalPos = 2.22507385850720140e-308;
-Real64 Real64_minPos = 4.94065645841246544e-324;
-
+Real64 Real64_maxFinite = 1.7976931348623157e+308;
+Real64 Real64_minNormalPos = 2.2250738585072014e-308;
+Real64 Real64_minPos = 4.9406564584124654e-324;
1.3 +5 -0 mlton/runtime/basis/Real/signBit.c
Index: signBit.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/signBit.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- signBit.c 23 Jun 2003 04:59:02 -0000 1.2
+++ signBit.c 25 Jul 2003 20:14:48 -0000 1.3
@@ -1,4 +1,9 @@
+#include <math.h>
#include "mlton-basis.h"
+
+Int Real32_signBit (Real32 f) {
+ return (((unsigned char *)&f)[3] & 0x80) >> 7;
+}
Int Real64_signBit (Real64 d) {
return (((unsigned char *)&d)[7] & 0x80) >> 7;
1.1 mlton/runtime/basis/Real/copysign.c
Index: copysign.c
===================================================================
#include <math.h>
#include "mlton-basis.h"
Real32 Real32_copysign (Real32 f1, Real32 f2) {
return copysignf (f1, f2); /* copysignf is from math.h */
}
Real64 Real64_copysign (Real64 d1, Real64 d2) {
return copysign (d1, d2); /* copysign is from math.h */
}
1.1 mlton/runtime/basis/Real/frexp.c
Index: frexp.c
===================================================================
#include <math.h>
#include "mlton-basis.h"
double frexp(double x, int* exp);
Real32 Real32_frexp(Real32 x, Int *exp) {
int exp_;
Real32 res;
res = (Real32)(frexp((Real64) x, &exp_));
*exp = exp_;
return res;
}
Real64 Real64_frexp(Real64 x, Int *exp) {
int exp_;
Real64 res;
res = frexp(x, &exp_);
*exp = exp_;
return res;
}
1.1 mlton/runtime/basis/Real/modf.c
Index: modf.c
===================================================================
#include <math.h>
#include "mlton-basis.h"
Real32 Real32_modf(Real32 x, Real32 *exp) {
Real64 exp_, res;
res = modf((Real64) x, &exp_);
*exp = (Real32)(exp_);
return (Real32)(res);
}
Real64 Real64_modf(Real64 x, Real64 *exp) {
return modf(x, exp);
}
1.1 mlton/runtime/basis/Real/pow.c
Index: pow.c
===================================================================
#include <math.h>
#include "mlton-basis.h"
Real32 Real32_Math_pow(Real32 x, Real32 y) {
return (Real32)(pow((Real64)x, (Real64)y));
}
Real64 Real64_Math_pow(Real64 x, Real64 y) {
return pow(x, y);
}
1.1 mlton/runtime/basis/Real/strto.c
Index: strto.c
===================================================================
#include <stdio.h>
#include <gc.h>
#include "gdtoa.h"
#include "mlton-basis.h"
#include "my-lib.h"
Real32 Real32_strto (char *s) {
char *endptr;
Real32 res;
res = strtof (s, &endptr);
assert (NULL != endptr);
return res;
}
Real64 Real64_strto (char *s) {
char *endptr;
Real64 res;
res = strtod (s, &endptr);
assert (NULL != endptr);
return res;
}
1.1 mlton/runtime/basis/Real/trig.c
Index: trig.c
===================================================================
#include <math.h>
#include "mlton-basis.h"
Real32 Real32_Math_cosh(Real32 x) {
return (Real32)(cosh((Real64)x));
}
Real64 Real64_Math_cosh(Real64 x) {
return cosh(x);
}
Real32 Real32_Math_sinh(Real32 x) {
return (Real32)(sinh((Real64)x));
}
Real64 Real64_Math_sinh(Real64 x) {
return sinh(x);
}
Real32 Real32_Math_tanh(Real32 x) {
return (Real32)(tanh((Real64)x));
}
Real64 Real64_Math_tanh(Real64 x) {
return tanh(x);
}
-------------------------------------------------------
This SF.Net email sponsored by: Free pre-built ASP.NET sites including
Data Reports, E-commerce, Portals, and Forums are available now.
Download today and enter to win an XBOX or Visual Studio .NET.
http://aspnet.click-url.com/go/psa00100003ave/direct;at.aspnet_072303_01/01
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel