[MLton-devel] cvs commit: support for multiple integer, real, and word sizes
Stephen Weeks
sweeks@users.sourceforge.net
Sun, 22 Jun 2003 21:59:03 -0700
sweeks 03/06/22 21:59:02
Modified: basis-library/misc primitive.sml
basis-library/real real.sml
benchmark benchmark-stubs.cm benchmark.cm
bin check-basis
include c-chunk.h c-main.h main.h x86-main.h
mllex mllex-stubs.cm mllex.cm
mlprof mlprof-stubs.cm mlprof.cm
mlton mlton-stubs-1997.cm mlton-stubs.cm mlton.cm
mlton/ast ast-atoms.fun ast-const.fun ast-const.sig
prim-tycons.fun prim-tycons.sig record.fun
record.sig sources.cm
mlton/atoms atoms.fun atoms.sig cases.fun cases.sig
const.fun const.sig hash-type.fun hash-type.sig
prim.fun prim.sig sources.cm tycon.fun tycon.sig
type-ops.fun type-ops.sig type.fun type.sig
mlton/backend allocate-registers.fun backend.fun backend.sig
c-function.fun chunkify.fun limit-check.fun
machine-atoms.fun machine-atoms.sig machine.fun
machine.sig mtype.fun mtype.sig profile.fun
representation.fun representation.sig rssa.fun
rssa.sig runtime.fun runtime.sig signal-check.fun
sources.cm ssa-to-rssa.fun switch.fun switch.sig
mlton/closure-convert abstract-value.fun closure-convert.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-codegen.fun
x86-mlton-basic.fun x86-mlton.fun x86-translate.fun
mlton/core-ml lookup-constant.fun lookup-constant.sig
mlton/front-end import.cm ml.grm ml.lex
mlton/main compile.sml
mlton/ssa analyze.fun analyze.sig common-subexp.fun
constant-propagation.fun direct-exp.fun
direct-exp.sig poly-equal.fun redundant-tests.fun
remove-unused.fun shrink.fun ssa-tree.fun
ssa-tree.sig type-check.fun useless.fun
mlton/type-inference infer.fun infer.sig match-compile.fun
match-compile.sig type-env.fun type-env.sig
mlton/xml implement-exceptions.fun monomorphise.fun
polyvariance.fun shrink.fun simplify-types.fun
type-check.fun xml-tree.fun xml-tree.sig
mlyacc mlyacc-stubs.cm mlyacc.cm
runtime Makefile gc.c mlton-basis.h
runtime/Posix/Process exit.c sleep.c
runtime/Posix/Signal Signal.c isPending.c
runtime/basis IEEEReal.c Stdio.c
runtime/basis/Int quot.c rem.c
runtime/basis/MLton Callback.c exit.c
runtime/basis/PackReal subVec.c update.c
runtime/basis/Real class.c gdtoa.c isFinite.c isNan.c
isNormal.c nextAfter.c real.c round.c signBit.c
strtod.c
Added: mlton/ast int-size.fun int-size.sig real-size.fun
real-size.sig word-size.fun word-size.sig
mlton/atoms int-x.fun int-x.sig real-x.fun real-x.sig
word-x.fun word-x.sig
runtime types.h
Removed: runtime/basis/Real const.S qequal.c
Log:
Added compiler support for multiple integer, real, and word sizes.
This checkin just changes the compiler infrastructure. It does not
add the basis library modules. There are also some still some holes,
especially in the x86 codegen support. Matthew, if you could take a
look at those, that would be great.
Everything that was there before is still supported, though, and all
regressions and self compiles pass.
The main new datatypes are:
datatype IntSize.t = I8 | I16 | I32 | I64
datatype RealSize.t = R32 | R64
datatype WordSize.t = W8 | W16 | W32
Tycons and types have been extended so that they are parameterized
over the appropriate sizes.
val int: IntSize.t -> t
val real: RealSize.t -> t
val word: WordSize.t -> t
There are also default values of each size (I32, R64, W32) and the
corresponding default types.
There are new modules for representing values of the various types at
runtime: IntX.t, RealX.t, and WordX.t. The front end and ast
constants have been reworked to handle arbitrary size integers and
words. Const has been reworked, adding variants for each of the
values, and replacing char with words of size W8 and string with word8
vector
datatype Const.t =
Int of IntX.t
| IntInf of IntInf.t
| Real of RealX.t
| Word of WordX.t
| Word8Vector of Word8.t vector
I didn't treat IntInf as another size of Int because they are almost
always handled differently.
Integer, Real and Word primitives are now parameterized over the size
of value that they operate on. The conversion operators have also
been generalized.
datatype Prim.t =
...
| Int_add of IntSize.t
...
| Real_add of RealSize.t
...
| Word_add of WordSize.t
...
| Word_toIntX of WordSize.t * IntSize.t
...
For such primitives, the prim name in the basis library now always has
the size as part of the name, e.g.
_prim "Int32_addCheck": int * int -> int;
Case expressions in all the ILs have had cases on chars removed and
had cases on ints and words generalized to handle different sizes.
That's about it. The plan now is to add support for Int8, Int16,
Int64, Real32, and Word16. Hopefully, with all the infrastructure of
this checkin in place, adding those will only require writing some SML
basis library code and mucking with the codegen to implement the
primitives. I would like Word64, but that will take a little more
work since there is no Word64 to bootstrap off of.
Feel free to start implementing the module of your choice, but please
announce it on the list first to avoid duplication of effort.
Revision Changes Path
1.56 +159 -93 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- primitive.sml 19 Jun 2003 15:38:04 -0000 1.55
+++ primitive.sml 23 Jun 2003 04:58:53 -0000 1.56
@@ -17,22 +17,60 @@
datatype bool = datatype bool
type char = char
type exn = exn
-type int = int
+structure Int8 =
+ struct
+ type int = int8
+ end
+structure Int16 =
+ struct
+ type int = int16
+ end
+structure Int32 =
+ struct
+ type int = int32
+ end
+structure Int64 =
+ struct
+ type int = int64
+ end
type intInf = intInf
datatype list = datatype list
type pointer = pointer (* C integer, not SML heap pointer *)
-type real = real
+structure Real32 =
+ struct
+ type real = real32
+ end
+structure Real64 =
+ struct
+ type real = real64
+ end
datatype ref = datatype ref
type preThread = preThread
type thread = thread
-type word = word
-type word8 = word8
-type word32 = word
+structure Word8 =
+ struct
+ type word = word8
+ end
+structure Word16 =
+ struct
+ type word = word16
+ end
+structure Word32 =
+ struct
+ type word = word32
+ end
type 'a vector = 'a vector
type 'a weak = 'a weak
type string = char vector
type nullString = string
+structure Int = Int32
+type int = Int.int
+structure Real = Real64
+type real = Real.real
+structure Word = Word32
+type word = Word.word
+
exception Bind = Bind
exception Fail of string
exception Match = Match
@@ -56,7 +94,8 @@
val errno = _ffi "MLton_errno": unit -> int;
val halt = _prim "MLton_halt": int -> unit;
val handlesSignals = _prim "MLton_handlesSignals": bool;
- val installSignalHandler = _prim "MLton_installSignalHandler": unit -> unit;
+ val installSignalHandler =
+ _prim "MLton_installSignalHandler": unit -> unit;
val safe = _build_const "MLton_safe": bool;
val touch = fn z => _prim "MLton_touch": 'a -> unit; z
val usesCallcc: bool ref = ref false;
@@ -206,39 +245,38 @@
val getRoundingMode = _ffi "IEEEReal_getRoundingMode": unit -> int;
end
- structure Int =
+ structure Int32 =
struct
- type int = int
+ type int = int32
- val *? = _prim "Int_mul": int * int -> int;
+ val *? = _prim "Int32_mul": int * int -> int;
val * =
if detectOverflow
- then _prim "Int_mulCheck": int * int -> int;
+ then _prim "Int32_mulCheck": int * int -> int;
else *?
- val +? = _prim "Int_add": int * int -> int;
+ val +? = _prim "Int32_add": int * int -> int;
val + =
if detectOverflow
- then _prim "Int_addCheck": int * int -> int;
+ then _prim "Int32_addCheck": int * int -> int;
else +?
- val -? = _prim "Int_sub": int * int -> int;
+ val -? = _prim "Int32_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "Int_subCheck": int * int -> int;
+ then _prim "Int32_subCheck": int * int -> int;
else -?
- val < = _prim "Int_lt": int * int -> bool;
- val <= = _prim "Int_le": int * int -> bool;
- val > = _prim "Int_gt": int * int -> bool;
- val >= = _prim "Int_ge": int * int -> bool;
- val geu = _prim "Int_geu": int * int -> bool;
- val gtu = _prim "Int_gtu": int * int -> bool;
- val quot = _prim "Int_quot": int * int -> int;
- val rem = _prim "Int_rem": int * int -> int;
- val ~? = _prim "Int_neg": int -> int;
+ val < = _prim "Int32_lt": int * int -> bool;
+ val <= = _prim "Int32_le": int * int -> bool;
+ val > = _prim "Int32_gt": int * int -> bool;
+ val >= = _prim "Int32_ge": int * int -> bool;
+ val quot = _prim "Int32_quot": int * int -> int;
+ val rem = _prim "Int32_rem": int * int -> int;
+ val ~? = _prim "Int32_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Int_negCheck": int -> int;
+ then _prim "Int32_negCheck": int -> int;
else ~?
end
+ structure Int = Int32
structure Array =
struct
@@ -259,8 +297,8 @@
val andb = _prim "IntInf_andb": int * int * word -> int;
val ~>> = _prim "IntInf_arshift": int * word * word -> int;
val compare = _prim "IntInf_compare": int * int -> Int.int;
- val fromVector = _prim "IntInf_fromVector": word vector -> int;
- val fromWord = _prim "IntInf_fromWord": word -> int;
+ val fromVector = _prim "WordVector_toIntInf": word vector -> int;
+ val fromWord = _prim "Word_toIntInf": word -> int;
val gcd = _prim "IntInf_gcd": int * int * word -> int;
val << = _prim "IntInf_lshift": int * word * word -> int;
val * = _prim "IntInf_mul": int * int * word -> int;
@@ -453,10 +491,13 @@
val entryAddrType = _ffi "NetHostDB_Entry_addrType": unit -> int;
val entryLength = _ffi "NetHostDB_Entry_length": unit -> int;
val entryNumAddrs = _ffi "NetHostDB_Entry_numAddrs": unit -> int;
- val entryAddrsN = _ffi "NetHostDB_Entry_addrsN": int * pre_in_addr -> unit;
- val getByAddress = _ffi "NetHostDB_getByAddress": in_addr * int -> bool;
+ val entryAddrsN =
+ _ffi "NetHostDB_Entry_addrsN": int * pre_in_addr -> unit;
+ val getByAddress =
+ _ffi "NetHostDB_getByAddress": in_addr * int -> bool;
val getByName = _ffi "NetHostDB_getByName": nullString -> bool;
- val getHostName = _ffi "NetHostDB_getHostName": char array * int -> int;
+ val getHostName =
+ _ffi "NetHostDB_getHostName": char array * int -> int;
end
structure NetProtDB =
@@ -501,7 +542,8 @@
structure PackReal =
struct
val subVec = _ffi "PackReal_subVec": word8 vector * int -> real;
- val update = _ffi "PackReal_update": word8 array * int * real -> unit;
+ val update =
+ _ffi "PackReal_update": word8 array * int * real -> unit;
end
structure Ptrace =
@@ -538,61 +580,64 @@
structure Real =
struct
+ type real = real64
+
structure Math =
struct
type real = real
- val acos = _prim "Real_Math_acos": real -> real;
- val asin = _prim "Real_Math_asin": real -> real;
- val atan = _prim "Real_Math_atan": real -> real;
- val atan2 = _prim "Real_Math_atan2": real * real -> real;
- val cos = _prim "Real_Math_cos": real -> real;
- val cosh = _prim "Real_Math_cosh": real -> real;
- val e = _ffi "Real_Math_e": real;
- val exp = _prim "Real_Math_exp": real -> real;
- val ln = _prim "Real_Math_ln": real -> real;
- val log10 = _prim "Real_Math_log10": real -> real;
- val pi = _ffi "Real_Math_pi": real;
- val pow = _prim "Real_Math_pow": real * real -> real;
- val sin = _prim "Real_Math_sin": real -> real;
- val sinh = _prim "Real_Math_sinh": real -> real;
- val sqrt = _prim "Real_Math_sqrt": real -> real;
- val tan = _prim "Real_Math_tan": real -> real;
- val tanh = _prim "Real_Math_tanh": real -> real;
- end
-
- val * = _prim "Real_mul": real * real -> real;
- val *+ = _prim "Real_muladd": real * real * real -> real;
- val *- = _prim "Real_mulsub": real * real * real -> real;
- val + = _prim "Real_add": real * real -> real;
- val - = _prim "Real_sub": real * real -> real;
- val / = _prim "Real_div": real * real -> real;
- val < = _prim "Real_lt": real * real -> bool;
- val <= = _prim "Real_le": real * real -> bool;
- val == = _prim "Real_equal": real * real -> bool;
- val > = _prim "Real_gt": real * real -> bool;
- val >= = _prim "Real_ge": real * real -> bool;
- val ?= = _prim "Real_qequal": real * real -> bool;
- val abs = _prim "Real_abs": real -> real;
- val class = _ffi "Real_class": real -> int;
- val copySign = _prim "Real_copysign": real * real -> real;
- val frexp = _prim "Real_frexp": real * int ref -> real;
- val gdtoa = _ffi "Real_gdtoa": real * int * int * int ref -> cstring;
- val fromInt = _prim "Real_fromInt": int -> real;
- val isFinite = _ffi "Real_isFinite": real -> bool;
- val isNan = _ffi "Real_isNan": real -> bool;
- val isNormal = _ffi "Real_isNormal": real -> bool;
- val ldexp = _prim "Real_ldexp": real * int -> real;
- val maxFinite = _ffi "Real_maxFinite": real;
- val minNormalPos = _ffi "Real_minNormalPos": real;
- val minPos = _ffi "Real_minPos": real;
- val modf = _prim "Real_modf": real * real ref -> real;
- val nextAfter = _ffi "Real_nextAfter": real * real -> real;
- val round = _prim "Real_round": real -> real;
- val signBit = _ffi "Real_signBit": real -> bool;
- val strtod = _ffi "Real_strtod": nullString -> real;
- val toInt = _prim "Real_toInt": real -> int;
- val ~ = _prim "Real_neg": real -> real;
+ val acos = _prim "Real64_Math_acos": real -> real;
+ val asin = _prim "Real64_Math_asin": real -> real;
+ 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 = _ffi "cosh": real -> real;
+ val e = _ffi "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 = _ffi "Real64_Math_pi": real;
+ val pow = _ffi "pow": real * real -> real;
+ val sin = _prim "Real64_Math_sin": real -> real;
+ val sinh = _ffi "sinh": real -> real;
+ val sqrt = _prim "Real64_Math_sqrt": real -> real;
+ val tan = _prim "Real64_Math_tan": real -> real;
+ val tanh = _ffi "tanh": real -> real;
+ end
+
+ val * = _prim "Real64_mul": real * real -> real;
+ val *+ = _prim "Real64_muladd": real * real * real -> real;
+ val *- = _prim "Real64_mulsub": real * real * real -> real;
+ val + = _prim "Real64_add": real * real -> real;
+ val - = _prim "Real64_sub": real * real -> real;
+ val / = _prim "Real64_div": real * real -> real;
+ val < = _prim "Real64_lt": real * real -> bool;
+ val <= = _prim "Real64_le": real * real -> bool;
+ val == = _prim "Real64_equal": real * real -> bool;
+ val > = _prim "Real64_gt": real * real -> bool;
+ val >= = _prim "Real64_ge": real * real -> bool;
+ val ?= = _prim "Real64_qequal": real * real -> bool;
+ val abs = _prim "Real64_abs": real -> real;
+ val class = _ffi "Real64_class": real -> int;
+ val copySign = _ffi "copysign": real * real -> real;
+ val frexp = _ffi "frexp": real * int ref -> real;
+ val gdtoa =
+ _ffi "Real64_gdtoa": real * int * int * int ref -> cstring;
+ val fromInt = _prim "Int32_toReal64": int -> real;
+ val isFinite = _ffi "Real64_isFinite": real -> bool;
+ val isNan = _ffi "Real64_isNan": real -> bool;
+ val isNormal = _ffi "Real64_isNormal": real -> bool;
+ val ldexp = _prim "Real64_ldexp": real * int -> real;
+ val maxFinite = _ffi "Real64_maxFinite": real;
+ val minNormalPos = _ffi "Real64_minNormalPos": real;
+ val minPos = _ffi "Real64_minPos": real;
+ val modf = _ffi "modf": real * real ref -> real;
+ val nextAfter = _ffi "Real64_nextAfter": real * real -> real;
+ val round = _prim "Real64_round": real -> real;
+ val signBit = _ffi "Real64_signBit": real -> bool;
+ val strtod = _ffi "Real64_strtod": nullString -> real;
+ val toInt = _prim "Real64_toInt": real -> int;
+ val ~ = _prim "Real64_neg": real -> real;
end
structure Ref =
@@ -738,8 +783,9 @@
val toAddr = _ffi "UnixSock_toAddr": nullString * int *
pre_sock_addr * int ref -> unit;
val pathLen = _ffi "UnixSock_pathLen": sock_addr -> int;
- val fromAddr = _ffi "UnixSock_fromAddr": sock_addr *
- char array * int -> unit;
+ val fromAddr =
+ _ffi "UnixSock_fromAddr"
+ : sock_addr * char array * int -> unit;
structure Strm =
struct
end
@@ -759,7 +805,7 @@
structure String =
struct
val fromWord8Vector =
- _prim "String_fromWord8Vector": word8 vector -> string;
+ _prim "Word8Vector_toString": word8 vector -> string;
val toWord8Vector =
_prim "String_toWord8Vector": string -> word8 vector;
end
@@ -830,7 +876,7 @@
* are supposed to be immutable and the optimizer depends on this.
*)
val fromArray =
- fn x => _prim "Vector_fromArray": 'a array -> 'a vector; x
+ fn x => _prim "Array_toVector": 'a array -> 'a vector; x
end
structure Word8 =
@@ -841,8 +887,8 @@
val andb = _prim "Word8_andb": word * word -> word;
val ~>> = _prim "Word8_arshift": word * word32 -> word;
val div = _prim "Word8_div": word * word -> word;
- val fromInt = _prim "Word8_fromInt": int -> word;
- val fromLargeWord = _prim "Word8_fromLargeWord": word32 -> word;
+ val fromInt = _prim "Int32_toWord8": int -> word;
+ val fromLargeWord = _prim "Word32_toWord8": word32 -> word;
val >= = _prim "Word8_ge": word * word -> bool;
val > = _prim "Word8_gt" : word * word -> bool;
val <= = _prim "Word8_le": word * word -> bool;
@@ -857,10 +903,10 @@
val ror = _prim "Word8_ror": word * word32 -> word;
val >> = _prim "Word8_rshift": word * word32 -> word;
val - = _prim "Word8_sub": word * word -> word;
- val toInt = _prim "Word8_toInt": word -> int;
- val toIntX = _prim "Word8_toIntX": word -> int;
- val toLargeWord = _prim "Word8_toLargeWord": word -> word32;
- val toLargeWordX = _prim "Word8_toLargeWordX": word -> word32;
+ val toInt = _prim "Word8_toInt32": word -> int;
+ val toIntX = _prim "Word8_toInt32X": word -> int;
+ val toLargeWord = _prim "Word8_toWord32": word -> word32;
+ val toLargeWordX = _prim "Word8_toWord32X": word -> word32;
val xorb = _prim "Word8_xorb": word * word -> word;
end
@@ -887,7 +933,7 @@
val andb = _prim "Word32_andb": word * word -> word;
val ~>> = _prim "Word32_arshift": word * word -> word;
val div = _prim "Word32_div": word * word -> word;
- val fromInt = _prim "Word32_fromInt": int -> word;
+ val fromInt = _prim "Int32_toWord32": int -> word;
val >= = _prim "Word32_ge": word * word -> bool;
val > = _prim "Word32_gt" : word * word -> bool;
val <= = _prim "Word32_le": word * word -> bool;
@@ -903,9 +949,10 @@
val ror = _prim "Word32_ror": word * word -> word;
val >> = _prim "Word32_rshift": word * word -> word;
val - = _prim "Word32_sub": word * word -> word;
- val toIntX = _prim "Word32_toIntX": word -> int;
+ val toIntX = _prim "Word32_toInt32X": word -> int;
val xorb = _prim "Word32_xorb": word * word -> word;
end
+ structure Word = Word32
structure World =
struct
@@ -913,4 +960,23 @@
val makeOriginal = _ffi "World_makeOriginal": unit -> unit;
val save = _prim "World_save": word (* filedes *) -> unit;
end
+ end
+
+structure Primitive =
+ struct
+ open Primitive
+
+ structure Int32 =
+ struct
+ open Int32
+
+ local
+ fun make f (i: int, i': int): bool =
+ f (Primitive.Word.fromInt i, Primitive.Word.fromInt i')
+ in
+ val geu = make Primitive.Word.>=
+ val gtu = make Primitive.Word.>
+ end
+ end
+ structure Int = Int32
end
1.21 +6 -1 mlton/basis-library/real/real.sml
Index: real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sml,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- real.sml 2 Jun 2003 21:17:07 -0000 1.20
+++ real.sml 23 Jun 2003 04:58:53 -0000 1.21
@@ -39,7 +39,12 @@
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 = 2
val precision: int = 52
1.9 +2 -2 mlton/benchmark/benchmark-stubs.cm
Index: benchmark-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark-stubs.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- benchmark-stubs.cm 15 May 2003 20:12:27 -0000 1.8
+++ benchmark-stubs.cm 23 Jun 2003 04:58:54 -0000 1.9
@@ -102,8 +102,6 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/ordered-field.sig
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
@@ -159,6 +157,8 @@
../lib/mlton/basic/file-desc.sig
../lib/mlton/basic/file-desc.sml
../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/dir.sig
1.9 +2 -2 mlton/benchmark/benchmark.cm
Index: benchmark.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- benchmark.cm 1 Apr 2003 06:16:12 -0000 1.8
+++ benchmark.cm 23 Jun 2003 04:58:54 -0000 1.9
@@ -68,8 +68,6 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/ordered-field.sig
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
@@ -125,6 +123,8 @@
../lib/mlton/basic/file-desc.sig
../lib/mlton/basic/file-desc.sml
../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/dir.sig
1.15 +9 -3 mlton/bin/check-basis
Index: check-basis
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/check-basis,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- check-basis 18 Apr 2003 22:44:54 -0000 1.14
+++ check-basis 23 Jun 2003 04:58:54 -0000 1.15
@@ -102,17 +102,23 @@
datatype bool = datatype bool
type char = char
type exn = exn
- type int = Int32.int
+ type int8 = Int32.int
+ type int16 = Int32.int
+ type int32 = Int32.int
+ type int64 = Int32.int
+ type int = int32
type intInf = int
datatype list = datatype list
datatype pointer = T
- type real = real
+ type real32 = real
+ type real64 = real
datatype ref = datatype ref
datatype preThread = T
datatype thread = T
datatype 'a weak = T of 'a
- type word = Word32.word
type word8 = Word8.word
+ type word16 = Word32.word
+ type word32 = Word32.word
type 'a vector = 'a vector
datatype 'a option = T
1.6 +359 -415 mlton/include/c-chunk.h
Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-chunk.h 3 Jun 2003 01:06:35 -0000 1.5
+++ c-chunk.h 23 Jun 2003 04:58:54 -0000 1.6
@@ -3,6 +3,7 @@
#include "my-lib.h"
#include "c-common.h"
+#include "types.h"
#define WORD_SIZE 4
@@ -10,31 +11,10 @@
#define DEBUG_CCODEGEN FALSE
#endif
-typedef unsigned char Char;
-typedef double Double;
-typedef int Int;
-typedef char *Pointer;
-typedef unsigned long Word32;
-typedef Word32 Word;
-typedef unsigned long long Word64;
-
-#define Bool Int
-
-extern Char CReturnC;
-extern Double CReturnD;
-extern Int CReturnI;
-extern Char *CReturnP;
-extern Word CReturnU;
extern struct cont (*nextChunks []) ();
extern Int nextFun;
extern Int returnToC;
extern struct GC_state gcState;
-extern Char globaluchar[];
-extern Double globaldouble[];
-extern Int globalint[];
-extern Pointer globalpointer[];
-extern Word globaluint[];
-extern Pointer globalpointerNonRoot[];
#define GCState ((Pointer)&gcState)
#define ExnStack *(Word*)(GCState + ExnStackOffset)
@@ -44,6 +24,21 @@
#define StackTopMem *(Word*)(GCState + StackTopOffset)
#define StackTop stackTop
+/* ------------------------------------------------- */
+/* Memory */
+/* ------------------------------------------------- */
+
+#define C(ty, x) (*(ty*)(x))
+#define G(ty, i) (global##ty [i])
+#define GPNR(i) G(PointerNonRoot, i)
+#define O(ty, b, o) (*(ty*)((b) + (o)))
+#define X(ty, b, i) (*(ty*)((b) + ((i) * sizeof(ty))))
+#define S(ty, i) *(ty*)(StackTop + (i))
+
+/* ------------------------------------------------- */
+/* Tests */
+/* ------------------------------------------------- */
+
#define IsInt(p) (0x3 & (int)(p))
#define BZ(x, l) \
@@ -129,13 +124,13 @@
/* Calling SML from C */
/* ------------------------------------------------- */
-#define Thread_returnToC() \
- do { \
- if (DEBUG_CCODEGEN) \
+#define Thread_returnToC() \
+ do { \
+ if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: Thread_returnToC()\n", \
- __FILE__, __LINE__); \
- returnToC = TRUE; \
- return cont; \
+ __FILE__, __LINE__); \
+ returnToC = TRUE; \
+ return cont; \
} while (0)
/* ------------------------------------------------- */
@@ -149,64 +144,9 @@
} while (0)
/* ------------------------------------------------- */
-/* Globals */
-/* ------------------------------------------------- */
-
-#define Global(ty, i) (global ## ty [ i ])
-#define GC(i) Global(uchar, i)
-#define GD(i) Global(double, i)
-#define GI(i) Global(int, i)
-#define GP(i) Global(pointer, i)
-#define GPNR(i) Global(pointerNonRoot, i)
-#define GU(i) Global(uint, i)
-
-/* ------------------------------------------------- */
-/* Registers */
-/* ------------------------------------------------- */
-
-#define Declare(ty, name, i) ty Reg(name, i)
-#define DC(n) Declare(Char, c, n)
-#define DD(n) Declare(Double, d, n)
-#define DI(n) Declare(Int, i, n)
-#define DP(n) Declare(Pointer, p, n)
-#define DU(n) Declare(Word, u, n)
-
-#define Reg(name, i) local ## name ## i
-#define RC(n) Reg(c, n)
-#define RD(n) Reg(d, n)
-#define RI(n) Reg(i, n)
-#define RP(n) Reg(p, n)
-#define RU(n) Reg(u, n)
-
-/* ------------------------------------------------- */
-/* Memory */
-/* ------------------------------------------------- */
-
-#define Offset(ty, b, o) (*(ty*)((b) + (o)))
-#define OC(b, i) Offset(Char, b, i)
-#define OD(b, i) Offset(Double, b, i)
-#define OI(b, i) Offset(Int, b, i)
-#define OP(b, i) Offset(Pointer, b, i)
-#define OU(b, i) Offset(Word, b, i)
-
-#define Contents(t, x) (*(t*)(x))
-#define CC(x) Contents(Char, x)
-#define CD(x) Contents(Double, x)
-#define CI(x) Contents(Int, x)
-#define CP(x) Contents(Pointer, x)
-#define CU(x) Contents(Word, x)
-
-/* ------------------------------------------------- */
/* Stack */
/* ------------------------------------------------- */
-#define Slot(ty, i) *(ty*)(StackTop + (i))
-#define SC(i) Slot(Char, i)
-#define SD(i) Slot(Double, i)
-#define SI(i) Slot(Int, i)
-#define SP(i) Slot(Pointer, i)
-#define SU(i) Slot(Word, i)
-
#define Push(bytes) \
do { \
if (DEBUG_CCODEGEN) \
@@ -257,29 +197,6 @@
} while (0)
/* ------------------------------------------------- */
-/* Arrays */
-/* ------------------------------------------------- */
-
-#define ArrayOffset(ty, b, i) (*(ty*)((b) + ((i) * sizeof(ty))))
-
-#define XC(b, i) ArrayOffset (Char, b, i)
-#define XD(b, i) ArrayOffset (Double, b, i)
-#define XI(b, i) ArrayOffset (Int, b, i)
-#define XP(b, i) ArrayOffset (Pointer, b, i)
-#define XU(b, i) ArrayOffset (Word, b, i)
-
-/* ------------------------------------------------- */
-/* Char */
-/* ------------------------------------------------- */
-
-#define Char_lt(c1, c2) ((c1) < (c2))
-#define Char_le(c1, c2) ((c1) <= (c2))
-#define Char_gt(c1, c2) ((c1) > (c2))
-#define Char_ge(c1, c2) ((c1) >= (c2))
-#define Char_chr(c) ((Char)(c))
-#define Char_ord(c) ((Int)(c))
-
-/* ------------------------------------------------- */
/* Cpointer */
/* ------------------------------------------------- */
@@ -289,22 +206,11 @@
/* Int */
/* ------------------------------------------------- */
-/* The old -DFAST_INT has been renamed to -DINT_JO. */
-#if (defined (FAST_INT))
-#define INT_JO
-#endif
-
/* The default is to use INT_TEST. */
-#if (! defined (INT_NO_CHECK) && ! defined (INT_JO) && ! defined (INT_TEST) && ! defined (INT_LONG))
+#if (! defined (INT_NO_CHECK) && ! defined (INT_TEST))
#define INT_TEST
#endif
-enum {
- MAXINT = 0x7FFFFFFF,
- MININT = (int)0x80000000,
- MAXWORD = 0xFFFFFFFF,
-};
-
#if (defined (INT_NO_CHECK))
#define Int_addCheck(dst, n1, n2, l) dst = n1 + n2
#define Int_mulCheck(dst, n1, n2, l) dst = n1 * n2
@@ -312,92 +218,141 @@
#define Int_subCheck(dst, n1, n2, l) dst = n1 - n2
#define Word32_addCheck(dst, n1, n2, l) dst = n1 + n2
#define Word32_mulCheck(dst, n1, n2, l) dst = n1 * n2
+#define Int_addCheckCX Int_addCheck
+#define Int_addCheckXC Int_addCheck
+#define Int_subCheckCX Int_subCheck
+#define Int_subCheckXC Int_subCheck
+#define Word32_addCheckCX Word32_addCheck
+#define Word32_addCheckXC Word32_addCheck
#endif
#if (defined (INT_TEST))
-#define Int_addCheckXC(dst, x, c, l) \
- do { \
- if (c >= 0) { \
- if (x > MAXINT - c) \
- goto l; \
- } else if (x < MININT - c) \
- goto l; \
- dst = x + c; \
- } while (0)
-#define Int_addCheckCX(dst, c, x, l) Int_addCheckXC(dst, x, c, l)
-#define Int_subCheckCX(dst, c, x, l) \
+
+#define Int8_max (Int8)0x7F
+#define Int8_min (Int8)0x80
+#define Int16_max (Int16)0x7FFF
+#define Int16_min (Int16)0x8000
+#define Int32_max (Int32)0x7FFFFFFF
+#define Int32_min (Int32)0x80000000
+#define Int64_max (Int64)0x7FFFFFFFFFFFFFFF
+#define Int64_min (Int64)0x8000000000000000
+#define Word8_max (Word8)0xFF
+#define Word16_max (Word16)0xFFFF
+#define Word32_max (Word32)0xFFFFFFFF
+#define Word64_max (Word64)0xFFFFFFFFFFFFFFFF
+
+#define Int_addCheckXC(size, dst, x, c, l) \
+ do { \
+ if (c >= 0) { \
+ if (x > Int##size##_max - c) \
+ goto l; \
+ } else if (x < Int##size##_min - c) \
+ goto l; \
+ dst = x + c; \
+ } while (0)
+#define Int8_addCheckXC(dst, x, c, l) Int_addCheckXC(8, dst, x, c, l)
+#define Int16_addCheckXC(dst, x, c, l) Int_addCheckXC(16, dst, x, c, l)
+#define Int32_addCheckXC(dst, x, c, l) Int_addCheckXC(32, dst, x, c, l)
+#define Int64_addCheckXC(dst, x, c, l) Int_addCheckXC(64, dst, x, c, l)
+
+#define Int8_addCheckCX(dst, c, x, l) Int8_addCheckXC(dst, x, c, l)
+#define Int16_addCheckCX(dst, c, x, l) Int16_addCheckXC(dst, x, c, l)
+#define Int32_addCheckCX(dst, c, x, l) Int32_addCheckXC(dst, x, c, l)
+#define Int64_addCheckCX(dst, c, x, l) Int64_addCheckXC(dst, x, c, l)
+
+#define Int8_addCheck Int8_addCheckXC
+#define Int16_addCheck Int16_addCheckXC
+#define Int32_addCheck Int32_addCheckXC
+#define Int64_addCheck Int64_addCheckXC
+
+#define Int_negCheck(size, dst, n, l) \
do { \
- if (c >= 0) { \
- if (x < c - MAXINT) \
- goto l; \
- } else if (x > c - MININT) \
+ if (n == Int##size##_min) \
goto l; \
- dst = c - x; \
+ dst = -n; \
} while (0)
-#define Int_subCheckXC(dst, x, c, l) \
- do { \
- if (c <= 0) { \
- if (x > MAXINT + c) \
- goto l; \
- } else if (x < MININT + c) \
- goto l; \
- dst = x - c; \
+
+#define Int8_negCheck(dst, n, l) Int_negCheck(8, dst, n, l)
+#define Int16_negCheck(dst, n, l) Int_negCheck(16, dst, n, l)
+#define Int32_negCheck(dst, n, l) Int_negCheck(32, dst, n, l)
+#define Int64_negCheck(dst, n, l) Int_negCheck(64, dst, n, l)
+
+#define Int_subCheckCX(size, dst, c, x, l) \
+ do { \
+ if (c >= 0) { \
+ if (x < c - Int##size##_max) \
+ goto l; \
+ } else if (x > c - Int##size##_min) \
+ goto l; \
+ dst = c - x; \
+ } while (0)
+#define Int8_subCheckCX(dst, c, x, l) Int_subCheckCX(8, dst, c, x, l)
+#define Int16_subCheckCX(dst, c, x, l) Int_subCheckCX(16, dst, c, x, l)
+#define Int32_subCheckCX(dst, c, x, l) Int_subCheckCX(32, dst, c, x, l)
+#define Int64_subCheckCX(dst, c, x, l) Int_subCheckCX(64, dst, c, x, l)
+
+#define Int_subCheckXC(size, dst, x, c, l) \
+ do { \
+ if (c <= 0) { \
+ if (x > Int##size##_max + c) \
+ goto l; \
+ } else if (x < Int##size##_min + c) \
+ goto l; \
+ dst = x - c; \
} while (0)
-#define Word32_addCheckXC(dst, x, c, l) \
+#define Int8_subCheckXC(dst, c, x, l) Int_subCheckXC(8, dst, c, x, l)
+#define Int16_subCheckXC(dst, c, x, l) Int_subCheckXC(16, dst, c, x, l)
+#define Int32_subCheckXC(dst, c, x, l) Int_subCheckXC(32, dst, c, x, l)
+#define Int64_subCheckXC(dst, c, x, l) Int_subCheckXC(64, dst, c, x, l)
+
+#define Int8_subCheck Int8_subCheckXC
+#define Int16_subCheck Int16_subCheckXC
+#define Int32_subCheck Int32_subCheckXC
+#define Int64_subCheck Int64_subCheckXC
+
+#define Word_addCheckXC(size, dst, x, c, l) \
do { \
- if (x > MAXWORD - c) \
+ if (x > Word##size##_max - c) \
goto l; \
dst = x + c; \
} while (0)
-#define Word32_addCheckCX(dst, c, x, l) Word32_addCheckXC(dst, x, c, l)
+#define Word8_addCheckXC(dst, x, c, l) Word_addCheckXC(8, dst, x, c, l)
+#define Word16_addCheckXC(dst, x, c, l) Word_addCheckXC(16, dst, x, c, l)
+#define Word32_addCheckXC(dst, x, c, l) Word_addCheckXC(32, dst, x, c, l)
+#define Word64_addCheckXC(dst, x, c, l) Word_addCheckXC(64, dst, x, c, l)
+#define Word8_addCheckCX(dst, c, x, l) Word_addCheckXC(8, dst, x, c, l)
+#define Word16_addCheckCX(dst, c, x, l) Word_addCheckXC(16, dst, x, c, l)
+#define Word32_addCheckCX(dst, c, x, l) Word_addCheckXC(32, dst, x, c, l)
+#define Word64_addCheckCX(dst, c, x, l) Word_addCheckXC(64, dst, x, c, l)
-#define Int_addCheck Int_addCheckXC
-#define Int_subCheck Int_subCheckXC
+#define Word8_addCheck Word8_addCheckXC
+#define Word16_addCheck Word16_addCheckXC
#define Word32_addCheck Word32_addCheckXC
+#define Word64_addCheck Word64_addCheckXC
-#endif
-
-static inline Int Int_addOverflow (Int lhs, Int rhs, Bool *overflow) {
- long long tmp;
-
- tmp = (long long)lhs + rhs;
- *overflow = (tmp != (int)tmp);
- return tmp;
-}
-static inline Int Int_mulOverflow (Int lhs, Int rhs, Bool *overflow) {
- long long tmp;
-
- tmp = (long long)lhs * rhs;
- *overflow = (tmp != (int)tmp);
- return tmp;
-}
-static inline Int Int_subOverflow (Int lhs, Int rhs, Bool *overflow) {
- long long tmp;
-
- tmp = (long long)lhs - rhs;
- *overflow = (tmp != (int)tmp);
- return tmp;
-}
-static inline Word32 Word32_addOverflow (Word32 lhs, Word32 rhs, Bool *overflow) {
- Word64 tmp;
+#define mulOverflow(kind, small, large) \
+ static inline kind##small kind##small##_##mulOverflow \
+ (kind##small x1, kind##small x2, Bool *overflow) { \
+ kind##large tmp; \
+ kind##small res; \
+ \
+ tmp = (kind##large)x1 * x2; \
+ res = tmp; \
+ *overflow = (tmp != res); \
+ return res; \
+ }
+mulOverflow(Int, 8, 16)
+mulOverflow(Int, 16, 32)
+mulOverflow(Int, 32, 64)
+mulOverflow(Word, 8, 16)
+mulOverflow(Word, 16, 32)
+mulOverflow(Word, 32, 64)
+#undef mulOverflow
- tmp = (Word64)lhs + rhs;
- *overflow = (tmp != (Word32)tmp);
- return tmp;
-}
-static inline Word32 Word32_mulOverflow (Word32 lhs, Word32 rhs, Bool *overflow) {
- Word64 tmp;
-
- tmp = (Word64)lhs * rhs;
- *overflow = (tmp != (Word32)tmp);
- return tmp;
-}
-
-#if (defined (INT_TEST) || defined (INT_LONG))
#define check(dst, n1, n2, l, f); \
do { \
int overflow; \
- dst = f(n1, n2, &overflow); \
+ dst = f (n1, n2, &overflow); \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: " #f "(%d, %d) = %d\n", \
__FILE__, __LINE__, n1, n2, dst); \
@@ -408,110 +363,69 @@
goto l; \
} \
} while (0)
-#define Int_mulCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Int_mulOverflow)
-#define Int_negCheck(dst, n, l) \
- do { \
- if (n == MININT) \
- goto l; \
- dst = -n; \
- } while (0)
-#define Word32_mulCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Word32_mulOverflow)
-#endif
-
-#if (defined (INT_LONG))
-#define Int_addCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Int_addOverflow)
-#define Int_subCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Int_subOverflow)
-#define Word32_addCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Word32_addOverflow)
-#endif
-
-#if (defined (INT_JO))
-
-static void MLton_overflow () {
- die("Internal overflow detected. Halt.");
-}
-
-static inline Int Int_addCheckFast (Int n1, Int n2) {
- __asm__ __volatile__ ("addl %1, %0\n\tjo MLton_overflow"
- : "+r" (n1) : "g" (n2) : "cc");
-
- return n1;
-}
-
-static inline Int Int_mulCheckFast (Int n1, Int n2) {
- __asm__ __volatile__ ("imull %1, %0\n\tjo MLton_overflow"
- : "+r" (n1) : "g" (n2) : "cc");
-
- return n1;
-}
-
-static inline Int Int_negCheckFast (Int n) {
- __asm__ __volatile__ ("negl %1\n\tjo MLton_overflow"
- : "+r" (n) : : "cc" );
- return n;
-}
-
-static inline Int Int_subCheckFast (Int n1, Int n2) {
- __asm__ __volatile__ ("subl %1, %0\n\tjo MLton_overflow"
- : "+r" (n1) : "g" (n2) : "cc" );
-
- return n1;
-}
-
-static inline Word Word32_addCheckFast (Word n1, Word n2) {
- __asm__ __volatile__ ("addl %1, %0\n\tjc MLton_overflow"
- : "+r" (n1) : "g" (n2) : "cc");
-
- return n1;
-}
-static inline Word Word32_mulCheckFast (Word n1, Word n2) {
- __asm__ __volatile__ ("imull %1, %0\n\tjc MLton_overflow"
- : "+r" (n1) : "g" (n2) : "cc");
-
- return n1;
-}
-
-#define check(dst,n1,n2,l,f) dst = f(n1, n2)
-
-#define Int_addCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Int_addCheckFast)
-#define Int_mulCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Int_mulCheckFast)
-#define Int_negCheck(dst, n, l) \
- dst = Int_negCheckFast(n)
-#define Int_subCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Int_subCheckFast)
-#define Word32_addCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Word32_addCheckFast)
+#define Int8_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, Int8_mulOverflow)
+#define Int16_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, Int16_mulOverflow)
+#define Int32_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, Int32_mulOverflow)
+#define Int64_mulCheck(dst, n1, n2, l) \
+ fprintf (stderr, "FIXME: Int64_mulCheck\n");
+
+#define Word8_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, Word8_mulOverflow)
+#define Word16_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, Word16_mulOverflow)
#define Word32_mulCheck(dst, n1, n2, l) \
- check(dst, n1, n2, l, Word32_mulCheckFast)
-
-#endif
-
-#if (defined (INT_NO_CHECK) || defined (INT_JO) || defined (INT_LONG))
-#define Int_addCheckCX Int_addCheck
-#define Int_addCheckXC Int_addCheck
-#define Int_subCheckCX Int_subCheck
-#define Int_subCheckXC Int_subCheck
-#define Word32_addCheckCX Word32_addCheck
-#define Word32_addCheckXC Word32_addCheck
-#endif
-
-#define Int_add(n1, n2) ((n1) + (n2))
-#define Int_mul(n1, n2) ((n1) * (n2))
-#define Int_sub(n1, n2) ((n1) - (n2))
-#define Int_lt(n1, n2) ((n1) < (n2))
-#define Int_le(n1, n2) ((n1) <= (n2))
-#define Int_gt(n1, n2) ((n1) > (n2))
-#define Int_ge(n1, n2) ((n1) >= (n2))
-#define Int_geu(x, y) ((Word)(x) >= (Word)(y))
-#define Int_gtu(x, y) ((Word)(x) > (Word)(y))
-#define Int_neg(n) (-(n))
+ check (dst, n1, n2, l, Word32_mulOverflow)
+#define Word64_mulCheck(dst, n1, n2, l) \
+ fprintf (stderr, "FIXME: Word64_mulCheck\n");
+
+#endif /* INT_TEST */
+
+#define intBinary(name, op, size) \
+ static inline Int##size Int##size##_##name \
+ (Int##size i1, Int##size i2) { \
+ return i1 op i2; \
+ }
+#define intAllBinary(name, op) \
+ intBinary(name,op,8) \
+ intBinary(name,op,16) \
+ intBinary(name,op,32) \
+ intBinary(name,op,64)
+intAllBinary (add, +)
+intAllBinary (mul, *)
+intAllBinary (sub, -)
+#undef intBinary
+#undef intAllBinary
+
+#define intBinaryCompare(name, op, size) \
+ static inline Bool Int##size##_##name \
+ (Int##size i1, Int##size i2) { \
+ return i1 op i2; \
+ }
+#define intAllBinaryCompare(name, op) \
+ intBinaryCompare(name,op,8) \
+ intBinaryCompare(name,op,16) \
+ intBinaryCompare(name,op,32) \
+ intBinaryCompare(name,op,64)
+intAllBinaryCompare (ge, >=)
+intAllBinaryCompare (gt, >)
+intAllBinaryCompare (le, <=)
+intAllBinaryCompare (lt, <)
+#undef intBinaryCompare
+#undef intAllBinaryCompare
+
+#define Int_neg(size) \
+ static inline Int##size Int##size##_##neg (Int##size i) { \
+ return -i; \
+ }
+Int_neg(8)
+Int_neg(16)
+Int_neg(32)
+Int_neg(64)
+#undef Int_neg
/* ------------------------------------------------- */
/* MLton */
@@ -527,65 +441,90 @@
/* Real */
/* ------------------------------------------------- */
-Double acos (Double x);
-#define Real_Math_acos acos
-Double asin (Double x);
-#define Real_Math_asin asin
-Double atan (Double x);
-#define Real_Math_atan atan
-Double atan2 (Double x, Double y);
-#define Real_Math_atan2 atan2
-Double cos (Double x);
-#define Real_Math_cos cos
-Double cosh (Double x);
-#define Real_Math_cosh cosh
-Double exp (Double x);
-#define Real_Math_exp exp
-Double log (Double x);
-#define Real_Math_ln log
-Double log10 (Double x);
-#define Real_Math_log10 log10
-Double pow (Double x, Double y);
-#define Real_Math_pow pow
-Double sin (Double x);
-#define Real_Math_sin sin
-Double sinh (Double x);
-#define Real_Math_sinh sinh
-Double sqrt (Double x);
-#define Real_Math_sqrt sqrt
-Double tan (Double x);
-#define Real_Math_tan tan
-Double tanh (Double x);
-#define Real_Math_tanh tanh
-
-#define Real_abs fabs
-#define Real_add(x, y) ((x) + (y))
-#define Real_copysign copysign
-#define Real_div(x, y) ((x) / (y))
-#define Real_equal(x1, x2) ((x1) == (x2))
-#define Real_fromInt(n) ((Double)(n))
-#define Real_ge(x1, x2) ((x1) >= (x2))
-#define Real_gt(x1, x2) ((x1) > (x2))
-Double ldexp (Double x, Int i);
-#define Real_ldexp ldexp
-#define Real_le(x1, x2) ((x1) <= (x2))
-#define Real_lt(x1, x2) ((x1) < (x2))
-#define Real_mul(x, y) ((x) * (y))
-#define Real_muladd(x, y, z) ((x) * (y) + (z))
-#define Real_mulsub(x, y, z) ((x) * (y) - (z))
-#define Real_neg(x) (-(x))
-Int Real_qequal (Double x1, Double x2);
-Double Real_round (Double x);
-#define Real_sub(x, y) ((x) - (y))
-#define Real_toInt(x) ((int)(x))
+Real64 atan2 (Real64 x, Real64 y);
+#define Real64_Math_atan2 atan2
+static inline Real32 Real32_Math_atan2 (Real32 x, Real32 y) {
+ return (Real32)(Real64_Math_atan2 ((Real64)x, (Real64)y));
+}
+
+#define unaryReal(f,g) \
+ Real64 g (Real64 x); \
+ static inline Real64 Real64_Math_##f (Real64 x) { \
+ return g (x); \
+ } \
+ static inline Real32 Real32_Math_##f (Real32 x) { \
+ return (Real32)(Real64_Math_##f ((Real64)x)); \
+ }
+unaryReal(acos, acos)
+unaryReal(asin, asin)
+unaryReal(atan, atan)
+unaryReal(cos, cos)
+unaryReal(exp, exp)
+unaryReal(ln, log)
+unaryReal(log10, log10)
+unaryReal(sin, sin)
+unaryReal(sqrt, sqrt)
+unaryReal(tan, tan)
+
+Real64 fabs (Real64 x);
+static inline Real64 Real64_abs (Real64 x) {
+ return fabs (x);
+}
+Real32 fabsf (Real32 x);
+static inline Real32 Real32_abs (Real32 x) {
+ return fabsf (x);
+}
+
+#define binaryReal(name, op) \
+ static inline Real32 Real32_##name (Real32 x, Real32 y) { \
+ return x op y; \
+ } \
+ static inline Real64 Real64_##name (Real64 x, Real64 y) { \
+ return x op y; \
+ }
+binaryReal(add, +)
+binaryReal(div, /)
+binaryReal(mul, *)
+binaryReal(sub, -)
+
+#undef binaryReal
+#define binaryReal(name, op) \
+ static inline Bool Real32_##name (Real32 x, Real32 y) { \
+ return x op y; \
+ } \
+ static inline Bool Real64_##name (Real64 x, Real64 y) { \
+ return x op y; \
+ }
+binaryReal(equal, ==)
+binaryReal(ge, >=)
+binaryReal(gt, >)
+binaryReal(le, <=)
+binaryReal(lt, <)
+
+Real64 ldexp (Real64 x, Int i);
+static inline Real64 Real64_ldexp (Real64 x, Int i) {
+ return ldexp (x, i);
+}
+static inline Real32 Real32_ldexp (Real32 x, Int i) {
+ return (Real32)(Real64_ldexp ((Real64)x, i));
+}
+#define Real32_muladd(x, y, z) ((x) * (y) + (z))
+#define Real32_mulsub(x, y, z) ((x) * (y) - (z))
+#define Real64_muladd(x, y, z) ((x) * (y) + (z))
+#define Real64_mulsub(x, y, z) ((x) * (y) - (z))
+#define Real32_neg(x) (-(x))
+#define Real64_neg(x) (-(x))
+Real64 Real64_round (Real64 x);
+#define Real32_toInt(x) ((Int)(x))
+#define Real64_toInt(x) ((Int)(x))
typedef volatile union {
Word tab[2];
- Double d;
-} DoubleOr2Words;
+ Real64 d;
+} Real64Or2Words;
-static inline double Real_fetch (double *dp) {
- DoubleOr2Words u;
+static inline Real64 Real64_fetch (Real64 *dp) {
+ Real64Or2Words u;
Word32 *p;
p = (Word32*)dp;
@@ -594,7 +533,7 @@
return u.d;
}
-static inline void Real_move (double *dst, double *src) {
+static inline void Real64_move (Real64 *dst, Real64 *src) {
Word32 *pd;
Word32 *ps;
Word32 t;
@@ -606,8 +545,8 @@
pd[1] = t;
}
-static inline void Real_store (double *dp, double d) {
- DoubleOr2Words u;
+static inline void Real64_store (Real64 *dp, Real64 d) {
+ Real64Or2Words u;
Word32 *p;
p = (Word32*)dp;
@@ -617,77 +556,82 @@
}
/* ------------------------------------------------- */
-/* Word8 */
+/* Word */
/* ------------------------------------------------- */
-#define Word8_add(w1, w2) ((w1) + (w2))
-#define Word8_andb(w1, w2) ((w1) & (w2))
-/* The macro for Word8_arshift isn't ANSI C, because ANSI doesn't guarantee
- * sign extension. We use it anyway cause it always seems to work.
- */
-#define Word8_arshift(w, s) ((signed char)(w) >> (s))
-#define Word8_div(w1, w2) ((w1) / (w2))
-#define Word8_fromInt(x) ((Char)(x))
-#define Word8_fromLargeWord(w) ((Char)(w))
-#define Word8_ge(w1, w2) ((w1) >= (w2))
-#define Word8_gt(w1, w2) ((w1) > (w2))
-#define Word8_le(w1, w2) ((w1) <= (w2))
-#define Word8_lshift(w, s) ((w) << (s))
-#define Word8_lt(w1, w2) ((w1) < (w2))
-#define Word8_mod(w1, w2) ((w1) % (w2))
-#define Word8_mul(w1, w2) ((w1) * (w2))
-#define Word8_neg(w) (-(w))
-#define Word8_notb(w) (~(w))
-#define Word8_orb(w1, w2) ((w1) | (w2))
-#define Word8_rol(x, y) ((x)>>(8-(y)) | ((x)<<(y)))
-#define Word8_ror(x, y) ((x)>>(y) | ((x)<<(8-(y))))
-#define Word8_rshift(w, s) ((w) >> (s))
-#define Word8_sub(w1, w2) ((w1) - (w2))
-#define Word8_toInt(w) ((int)(w))
-#define Word8_toIntX(x) ((int)(signed char)(x))
-#define Word8_toLargeWord(w) ((uint)(w))
-#define Word8_toLargeWordX(x) ((uint)(signed char)(x))
-#define Word8_xorb(w1, w2) ((w1) ^ (w2))
-
-/* ------------------------------------------------- */
-/* Word8Array */
-/* ------------------------------------------------- */
-
-#define Word8Array_subWord(a, i) (((Word*)(a))[i])
-#define Word8Array_updateWord(a, i, w) ((Word*)(a))[i] = (w)
-
-/* ------------------------------------------------- */
-/* Word8Vector */
-/* ------------------------------------------------- */
-
-#define Word8Vector_subWord(a, i) (((Word*)(a))[i])
-
-/* ------------------------------------------------- */
-/* Word32 */
-/* ------------------------------------------------- */
-
-#define Word32_add(w1,w2) ((w1) + (w2))
-#define Word32_andb(w1,w2) ((w1) & (w2))
-/* The macro for Word32_arshift isn't ANSI C, because ANSI doesn't guarantee
- * sign extension. We use it anyway cause it always seems to work.
- * We do it because using a procedure call slows down IntInf by a factor of 2.
- */
-#define Word32_arshift(w, s) ((int)(w) >> (s))
-#define Word32_div(w1, w2) ((w1) / (w2))
-#define Word32_ge(w1, w2) ((w1) >= (w2))
-#define Word32_gt(w1, w2) ((w1) > (w2))
-#define Word32_le(w1, w2) ((w1) <= (w2))
-#define Word32_lshift(w, s) ((w) << (s))
-#define Word32_lt(w1, w2) ((w1) < (w2))
-#define Word32_mod(w1, w2) ((w1) % (w2))
-#define Word32_mul(w1, w2) ((w1) * (w2))
-#define Word32_neg(w) (-(w))
-#define Word32_notb(w) (~(w))
-#define Word32_orb(w1, w2) ((w1) | (w2))
-#define Word32_ror(x, y) ((x)>>(y) | ((x)<<(32-(y))))
-#define Word32_rol(x, y) ((x)>>(32-(y)) | ((x)<<(y)))
-#define Word32_rshift(w, s) ((w) >> (s))
-#define Word32_sub(w1, w2) ((w1) - (w2))
-#define Word32_xorb(w1, w2) ((w1) ^ (w2))
+#define wordBinary(size, name, op) \
+ static inline Word##size Word##size##_##name \
+ (Word##size w1, Word##size w2) { \
+ return w1 op w2; \
+ }
+#define wordCmp(size, name, op) \
+ static inline Bool Word##size##_##name \
+ (Word##size w1, Word##size w2) { \
+ return w1 op w2; \
+ }
+#define wordShift(size, name, op) \
+ static inline Word##size Word##size##_##name \
+ (Word##size w1, Word w2) { \
+ return w1 op w2; \
+ }
+#define wordUnary(size, name, op) \
+ static inline Word##size Word##size##_##name (Word##size w) { \
+ return op w; \
+ }
+#define wordOps(size) \
+ wordBinary (size, add, +) \
+ wordBinary (size, andb, &) \
+ wordBinary (size, div, /) \
+ wordBinary (size, mod, %) \
+ wordBinary (size, mul, *) \
+ wordBinary (size, orb, |) \
+ wordBinary (size, sub, -) \
+ wordBinary (size, xorb, ^) \
+ wordCmp (size, ge, >=) \
+ wordCmp (size, gt, >) \
+ wordCmp (size, le, <=) \
+ wordCmp (size, lt, <) \
+ wordShift (size, lshift, <<) \
+ wordShift (size, rshift, >>) \
+ wordUnary (size, neg, -) \
+ wordUnary (size, notb, ~) \
+ /* Word_arshift isn't ANSI C, because ANSI doesn't guarantee sign \
+ * extension. We use it anyway cause it always seems to work. \
+ */ \
+ static inline Word##size Word##size##_arshift (Word##size w, Word s) { \
+ return (Int##size)w >> s; \
+ } \
+ static inline Word##size Word##size##_rol (Word##size w1, Word w2) { \
+ return (w1 >> (size - w2)) | (w1 << w2); \
+ } \
+ static inline Word##size Word##size##_ror (Word##size w1, Word w2) { \
+ return (w1 >> w2) | (w1 << (size - w2)); \
+ }
+wordOps(8)
+wordOps(16)
+wordOps(32)
+wordOps(64)
+#undef wordBinary wordCmp wordShift wordUnary
+
+#define coerce(f, t) \
+ static inline t f##_to##t (f x) { \
+ return (t)x; \
+ }
+coerce (Int32, Real64)
+coerce (Int32, Word8)
+coerce (Int32, Word32)
+coerce (Word8, Int32)
+coerce (Word8, Word32)
+coerce (Word32, Word8)
+#undef coerce
+
+#define coerceX(size, t) \
+ static inline t Word##size##_to##t##X (Word##size x) { \
+ return (t)(Int##size)x; \
+ }
+coerceX (8, Int32)
+coerceX (32, Int32)
+coerceX (8, Word32)
+#undef coerceX
#endif /* #ifndef _C_CHUNK_H_ */
1.5 +50 -55 mlton/include/c-main.h
Index: c-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-main.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-main.h 19 Jun 2003 15:38:04 -0000 1.4
+++ c-main.h 23 Jun 2003 04:58:54 -0000 1.5
@@ -4,61 +4,56 @@
#include "main.h"
#include "c-common.h"
-#define Main(al, cs, mg, mfs, mlw, mmc, ps, mc, ml) \
-/* Globals */ \
-char CReturnC; /* The CReturn's must be globals and cannot be per chunk */ \
-double CReturnD; /* because they may be assigned in one chunk and read in */ \
-int CReturnI; /* another. See, e.g. Array_allocate. */ \
-char *CReturnP; \
-uint CReturnU; \
-int nextFun; \
-bool returnToC; \
-void MLton_callFromC () { \
- struct cont cont; \
- GC_state s; \
- \
- if (DEBUG_CCODEGEN) \
- fprintf (stderr, "MLton_callFromC() starting\n"); \
- s = &gcState; \
- s->savedThread = s->currentThread; \
- s->canHandle++; \
- /* Return to the C Handler thread. */ \
- GC_switchToThread (s, s->callFromCHandler); \
- nextFun = *(int*)(s->stackTop - WORD_SIZE); \
- cont.nextChunk = nextChunks[nextFun]; \
- returnToC = FALSE; \
- do { \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- } while (not returnToC); \
- GC_switchToThread (s, s->savedThread); \
- s->canHandle--; \
- s->savedThread = BOGUS_THREAD; \
- if (DEBUG_CCODEGEN) \
- fprintf (stderr, "MLton_callFromC done\n"); \
-} \
-int main (int argc, char **argv) { \
- struct cont cont; \
- gcState.native = FALSE; \
- Initialize (al, cs, mg, mfs, mlw, mmc, ps); \
- if (gcState.isOriginal) { \
- real_Init(); \
- PrepFarJump(mc, ml); \
- } else { \
- /* Return to the saved world */ \
- nextFun = *(int*)(gcState.stackTop - WORD_SIZE); \
- cont.nextChunk = nextChunks[nextFun]; \
- } \
- /* Trampoline */ \
- while (1) { \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- } \
+#define Main(al, cs, mg, mfs, mlw, mmc, ps, mc, ml) \
+/* Globals */ \
+int nextFun; \
+bool returnToC; \
+void MLton_callFromC () { \
+ struct cont cont; \
+ GC_state s; \
+ \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "MLton_callFromC() starting\n"); \
+ s = &gcState; \
+ s->savedThread = s->currentThread; \
+ s->canHandle++; \
+ /* Return to the C Handler thread. */ \
+ GC_switchToThread (s, s->callFromCHandler); \
+ nextFun = *(int*)(s->stackTop - WORD_SIZE); \
+ cont.nextChunk = nextChunks[nextFun]; \
+ returnToC = FALSE; \
+ do { \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ } while (not returnToC); \
+ GC_switchToThread (s, s->savedThread); \
+ s->canHandle--; \
+ s->savedThread = BOGUS_THREAD; \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "MLton_callFromC done\n"); \
+} \
+int main (int argc, char **argv) { \
+ struct cont cont; \
+ gcState.native = FALSE; \
+ Initialize (al, cs, mg, mfs, mlw, mmc, ps); \
+ if (gcState.isOriginal) { \
+ real_Init(); \
+ PrepFarJump(mc, ml); \
+ } else { \
+ /* Return to the saved world */ \
+ nextFun = *(int*)(gcState.stackTop - WORD_SIZE); \
+ cont.nextChunk = nextChunks[nextFun]; \
+ } \
+ /* Trampoline */ \
+ while (1) { \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ } \
}
#endif /* #ifndef _C_MAIN_H */
1.4 +2 -31 mlton/include/main.h
Index: main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/main.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- main.h 3 Jun 2003 01:03:53 -0000 1.3
+++ main.h 23 Jun 2003 04:58:54 -0000 1.4
@@ -17,38 +17,9 @@
#define String(g, s, l) { g, s, l },
#define EndStrings };
-#define BeginReals static void real_Init() {
-#define Real(c, f) globaldouble[c] = f;
-#define EndReals }
-
#define LoadArray(a, f) sfread (a, sizeof(*a), cardof(a), f)
#define SaveArray(a, fd) swrite (fd, a, sizeof(*a) * cardof(a))
-/* gcState can't be static because stuff in mlton-lib.c refers to it */
-
-#define Globals(c, d, i, p, u, nr) \
- struct GC_state gcState; \
- char globaluchar[c]; \
- double globaldouble[d]; \
- int globalint[i]; \
- pointer globalpointer[p]; \
- uint globaluint[u]; \
- pointer globalpointerNonRoot[nr]; \
- static void saveGlobals (int fd) { \
- SaveArray (globaluchar, fd); \
- SaveArray (globaldouble, fd); \
- SaveArray (globalint, fd); \
- SaveArray (globalpointer, fd); \
- SaveArray (globaluint, fd); \
- } \
- static void loadGlobals (FILE *file) { \
- LoadArray (globaluchar, file); \
- LoadArray (globaldouble, file); \
- LoadArray (globalint, file); \
- LoadArray (globalpointer, file); \
- LoadArray (globaluint, file); \
- }
-
#define Initialize(al, cs, mg, mfs, mlw, mmc, ps) \
gcState.alignment = al; \
gcState.cardSizeLog2 = cs; \
@@ -56,8 +27,8 @@
gcState.frameLayoutsSize = cardof(frameLayouts); \
gcState.frameSources = frameSources; \
gcState.frameSourcesSize = cardof(frameSources); \
- gcState.globals = globalpointer; \
- gcState.globalsSize = cardof(globalpointer); \
+ gcState.globals = globalPointer; \
+ gcState.globalsSize = cardof(globalPointer); \
gcState.intInfInits = intInfInits; \
gcState.intInfInitsSize = cardof(intInfInits); \
gcState.loadGlobals = loadGlobals; \
1.5 +0 -7 mlton/include/x86-main.h
Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- x86-main.h 19 Jun 2003 15:38:04 -0000 1.4
+++ x86-main.h 23 Jun 2003 04:58:54 -0000 1.5
@@ -31,13 +31,6 @@
#define DEBUG_X86CODEGEN FALSE
#endif
-#define Locals(c, d, i, p, u) \
- char localuchar[c]; \
- double localdouble[d]; \
- int localint[i]; \
- pointer localpointer[p]; \
- uint localuint[u]
-
#if (defined (__CYGWIN__))
#define ReturnToC "_Thread_returnToC"
#elif (defined (__FreeBSD__) || defined (__linux__) || defined (__sun__))
1.9 +2 -2 mlton/mllex/mllex-stubs.cm
Index: mllex-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex-stubs.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mllex-stubs.cm 15 May 2003 20:12:28 -0000 1.8
+++ mllex-stubs.cm 23 Jun 2003 04:58:54 -0000 1.9
@@ -104,8 +104,6 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/char.sig
../lib/mlton/basic/char.sml
../lib/mlton/basic/vector.sig
@@ -137,6 +135,8 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
1.6 +2 -2 mlton/mllex/mllex.cm
Index: mllex.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mllex.cm 1 Apr 2003 06:16:12 -0000 1.5
+++ mllex.cm 23 Jun 2003 04:58:54 -0000 1.6
@@ -70,8 +70,6 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/char.sig
../lib/mlton/basic/char.sml
../lib/mlton/basic/vector.sig
@@ -103,6 +101,8 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
1.13 +2 -2 mlton/mlprof/mlprof-stubs.cm
Index: mlprof-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof-stubs.cm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- mlprof-stubs.cm 15 May 2003 20:12:28 -0000 1.12
+++ mlprof-stubs.cm 23 Jun 2003 04:58:54 -0000 1.13
@@ -102,8 +102,6 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/ordered-field.sig
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
@@ -156,6 +154,8 @@
../lib/mlton/basic/regexp.sml
../lib/mlton/basic/result.sig
../lib/mlton/basic/result.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/file-desc.sig
../lib/mlton/basic/file-desc.sml
../lib/mlton/basic/function.sig
1.15 +2 -2 mlton/mlprof/mlprof.cm
Index: mlprof.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof.cm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- mlprof.cm 1 Apr 2003 06:16:12 -0000 1.14
+++ mlprof.cm 23 Jun 2003 04:58:54 -0000 1.15
@@ -68,8 +68,6 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/ordered-field.sig
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
@@ -122,6 +120,8 @@
../lib/mlton/basic/regexp.sml
../lib/mlton/basic/result.sig
../lib/mlton/basic/result.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/file-desc.sig
../lib/mlton/basic/file-desc.sml
../lib/mlton/basic/function.sig
1.17 +22 -12 mlton/mlton/mlton-stubs-1997.cm
Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- mlton-stubs-1997.cm 15 May 2003 20:12:29 -0000 1.16
+++ mlton-stubs-1997.cm 23 Jun 2003 04:58:54 -0000 1.17
@@ -116,8 +116,6 @@
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
../lib/mlton/basic/ordered-field.fun
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/real.sig
../lib/mlton/basic/real.sml
../lib/mlton/basic/ref.sig
@@ -150,18 +148,24 @@
control/region.sml
../lib/mlton/set/set.sig
../lib/mlton/env/mono-env.sig
-ast/field.sig
-ast/record.sig
+ast/word-size.sig
ast/wrapped.sig
ast/tyvar.sig
-ast/ast-const.sig
-ast/ast-id.sig
+ast/field.sig
+ast/record.sig
+ast/real-size.sig
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
+ast/int-size.sig
ast/prim-tycons.sig
ast/prim-cons.sig
+ast/ast-id.sig
ast/longid.sig
+ast/ast-const.sig
ast/ast-atoms.sig
ast/ast-core.sig
ast/ast.sig
+atoms/word-x.sig
atoms/id.sig
atoms/var.sig
atoms/tycon.sig
@@ -170,12 +174,13 @@
atoms/type.sig
atoms/generic-scheme.sig
atoms/scheme.sig
+atoms/real-x.sig
atoms/profile-exp.sig
atoms/cons.sig
+atoms/int-x.sig
atoms/const.sig
atoms/prim.sig
atoms/atoms.sig
-atoms/cases.sig
atoms/hash-type.sig
xml/xml-type.sig
xml/xml-tree.sig
@@ -224,24 +229,28 @@
cm/parse.sml
cm/cm.sig
cm/cm.sml
-ast/ast-const.fun
-ast/field.fun
+ast/tyvar.fun
../lib/mlton/basic/quick-sort.sig
../lib/mlton/basic/insertion-sort.sig
../lib/mlton/basic/insertion-sort.sml
../lib/mlton/basic/quick-sort.sml
ast/record.fun
-ast/tyvar.fun
-ast/ast-id.fun
+ast/field.fun
+ast/ast-const.fun
+ast/word-size.fun
+ast/real-size.fun
ast/prim-tycons.fun
ast/prim-cons.fun
ast/longid.fun
+ast/int-size.fun
+ast/ast-id.fun
ast/ast-atoms.fun
ast/ast-core.fun
ast/ast.fun
../lib/mlton/set/unordered.fun
../lib/mlton/env/basic-env-to-env.fun
../lib/mlton/env/mono-env.fun
+atoms/word-x.fun
atoms/id.fun
atoms/var.fun
atoms/use-name.fun
@@ -249,8 +258,10 @@
atoms/type.fun
atoms/tycon.fun
atoms/source-info.fun
+atoms/real-x.fun
atoms/profile-exp.fun
atoms/prim.fun
+atoms/int-x.fun
atoms/generic-scheme.fun
atoms/const.fun
atoms/cons.fun
@@ -330,7 +341,6 @@
../lib/mlton/basic/clearable-promise.sig
../lib/mlton/basic/clearable-promise.sml
atoms/hash-type.fun
-atoms/cases.fun
ssa/ssa-tree.fun
ssa/ssa.fun
backend/mtype.sig
1.22 +22 -12 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- mlton-stubs.cm 15 May 2003 20:12:29 -0000 1.21
+++ mlton-stubs.cm 23 Jun 2003 04:58:54 -0000 1.22
@@ -115,8 +115,6 @@
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
../lib/mlton/basic/ordered-field.fun
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/real.sig
../lib/mlton/basic/real.sml
../lib/mlton/basic/ref.sig
@@ -149,18 +147,24 @@
control/region.sml
../lib/mlton/set/set.sig
../lib/mlton/env/mono-env.sig
-ast/field.sig
-ast/record.sig
+ast/word-size.sig
ast/wrapped.sig
ast/tyvar.sig
-ast/ast-const.sig
-ast/ast-id.sig
+ast/field.sig
+ast/record.sig
+ast/real-size.sig
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
+ast/int-size.sig
ast/prim-tycons.sig
ast/prim-cons.sig
+ast/ast-id.sig
ast/longid.sig
+ast/ast-const.sig
ast/ast-atoms.sig
ast/ast-core.sig
ast/ast.sig
+atoms/word-x.sig
atoms/id.sig
atoms/var.sig
atoms/tycon.sig
@@ -169,12 +173,13 @@
atoms/type.sig
atoms/generic-scheme.sig
atoms/scheme.sig
+atoms/real-x.sig
atoms/profile-exp.sig
atoms/cons.sig
+atoms/int-x.sig
atoms/const.sig
atoms/prim.sig
atoms/atoms.sig
-atoms/cases.sig
atoms/hash-type.sig
xml/xml-type.sig
xml/xml-tree.sig
@@ -223,24 +228,28 @@
cm/parse.sml
cm/cm.sig
cm/cm.sml
-ast/ast-const.fun
-ast/field.fun
+ast/tyvar.fun
../lib/mlton/basic/quick-sort.sig
../lib/mlton/basic/insertion-sort.sig
../lib/mlton/basic/insertion-sort.sml
../lib/mlton/basic/quick-sort.sml
ast/record.fun
-ast/tyvar.fun
-ast/ast-id.fun
+ast/field.fun
+ast/ast-const.fun
+ast/word-size.fun
+ast/real-size.fun
ast/prim-tycons.fun
ast/prim-cons.fun
ast/longid.fun
+ast/int-size.fun
+ast/ast-id.fun
ast/ast-atoms.fun
ast/ast-core.fun
ast/ast.fun
../lib/mlton/set/unordered.fun
../lib/mlton/env/basic-env-to-env.fun
../lib/mlton/env/mono-env.fun
+atoms/word-x.fun
atoms/id.fun
atoms/var.fun
atoms/use-name.fun
@@ -248,8 +257,10 @@
atoms/type.fun
atoms/tycon.fun
atoms/source-info.fun
+atoms/real-x.fun
atoms/profile-exp.fun
atoms/prim.fun
+atoms/int-x.fun
atoms/generic-scheme.fun
atoms/const.fun
atoms/cons.fun
@@ -329,7 +340,6 @@
../lib/mlton/basic/clearable-promise.sig
../lib/mlton/basic/clearable-promise.sml
atoms/hash-type.fun
-atoms/cases.fun
ssa/ssa-tree.fun
ssa/ssa.fun
backend/mtype.sig
1.67 +22 -12 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- mlton.cm 21 Apr 2003 15:16:17 -0000 1.66
+++ mlton.cm 23 Jun 2003 04:58:54 -0000 1.67
@@ -81,8 +81,6 @@
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
../lib/mlton/basic/ordered-field.fun
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/real.sig
../lib/mlton/basic/real.sml
../lib/mlton/basic/ref.sig
@@ -115,18 +113,24 @@
control/region.sml
../lib/mlton/set/set.sig
../lib/mlton/env/mono-env.sig
-ast/field.sig
-ast/record.sig
+ast/word-size.sig
ast/wrapped.sig
ast/tyvar.sig
-ast/ast-const.sig
-ast/ast-id.sig
+ast/field.sig
+ast/record.sig
+ast/real-size.sig
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
+ast/int-size.sig
ast/prim-tycons.sig
ast/prim-cons.sig
+ast/ast-id.sig
ast/longid.sig
+ast/ast-const.sig
ast/ast-atoms.sig
ast/ast-core.sig
ast/ast.sig
+atoms/word-x.sig
atoms/id.sig
atoms/var.sig
atoms/tycon.sig
@@ -135,12 +139,13 @@
atoms/type.sig
atoms/generic-scheme.sig
atoms/scheme.sig
+atoms/real-x.sig
atoms/profile-exp.sig
atoms/cons.sig
+atoms/int-x.sig
atoms/const.sig
atoms/prim.sig
atoms/atoms.sig
-atoms/cases.sig
atoms/hash-type.sig
xml/xml-type.sig
xml/xml-tree.sig
@@ -189,24 +194,28 @@
cm/parse.sml
cm/cm.sig
cm/cm.sml
-ast/ast-const.fun
-ast/field.fun
+ast/tyvar.fun
../lib/mlton/basic/quick-sort.sig
../lib/mlton/basic/insertion-sort.sig
../lib/mlton/basic/insertion-sort.sml
../lib/mlton/basic/quick-sort.sml
ast/record.fun
-ast/tyvar.fun
-ast/ast-id.fun
+ast/field.fun
+ast/ast-const.fun
+ast/word-size.fun
+ast/real-size.fun
ast/prim-tycons.fun
ast/prim-cons.fun
ast/longid.fun
+ast/int-size.fun
+ast/ast-id.fun
ast/ast-atoms.fun
ast/ast-core.fun
ast/ast.fun
../lib/mlton/set/unordered.fun
../lib/mlton/env/basic-env-to-env.fun
../lib/mlton/env/mono-env.fun
+atoms/word-x.fun
atoms/id.fun
atoms/var.fun
atoms/use-name.fun
@@ -214,8 +223,10 @@
atoms/type.fun
atoms/tycon.fun
atoms/source-info.fun
+atoms/real-x.fun
atoms/profile-exp.fun
atoms/prim.fun
+atoms/int-x.fun
atoms/generic-scheme.fun
atoms/const.fun
atoms/cons.fun
@@ -295,7 +306,6 @@
../lib/mlton/basic/clearable-promise.sig
../lib/mlton/basic/clearable-promise.sml
atoms/hash-type.fun
-atoms/cases.fun
ssa/ssa-tree.fun
ssa/ssa.fun
backend/mtype.sig
1.5 +8 -1 mlton/mlton/ast/ast-atoms.fun
Index: ast-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ast-atoms.fun 10 Apr 2002 07:02:18 -0000 1.4
+++ ast-atoms.fun 23 Jun 2003 04:58:55 -0000 1.5
@@ -11,13 +11,20 @@
open S
structure Wrap = Region.Wrap
+structure IntSize = IntSize ()
+structure RealSize = RealSize ()
+structure WordSize = WordSize ()
+
structure Tycon =
struct
structure Id = AstId (val className = "tycon")
open Id
structure P =
- PrimTycons (open Id
+ PrimTycons (structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize
+ open Id
val fromString = fn s => fromString (s, Region.bogus))
open P
end
1.4 +4 -4 mlton/mlton/ast/ast-const.fun
Index: ast-const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-const.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ast-const.fun 10 Apr 2002 07:02:18 -0000 1.3
+++ ast-const.fun 23 Jun 2003 04:58:55 -0000 1.4
@@ -11,10 +11,10 @@
open Region.Wrap
datatype node =
Char of char
- | Int of string
+ | Int of IntInf.t
| Real of string
| String of string
- | Word of word
+ | Word of IntInf.t
type t = node Region.Wrap.t
type node' = node
type obj = t
@@ -28,10 +28,10 @@
fun layout c =
case node c of
Char c => wrap ("#\"", "\"", String.implode [c])
- | Int s => str s
+ | Int s => str (IntInf.toString s)
| Real l => String.layout l
| String s => wrap ("\"", "\"", s)
- | Word w => seq [str "0wx", str (Word.toString w)]
+ | Word w => str (concat ["0wx", IntInf.format (w, StringCvt.HEX)])
end
val toString = Layout.toString o layout
1.4 +2 -2 mlton/mlton/ast/ast-const.sig
Index: ast-const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-const.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ast-const.sig 10 Apr 2002 07:02:18 -0000 1.3
+++ ast-const.sig 23 Jun 2003 04:58:55 -0000 1.4
@@ -20,10 +20,10 @@
type t
datatype node =
Char of char
- | Int of string
+ | Int of IntInf.t
| Real of string
| String of string
- | Word of word
+ | Word of IntInf.t
include WRAPPED sharing type node' = node
sharing type obj = t
1.6 +87 -42 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- prim-tycons.fun 18 Apr 2003 22:44:58 -0000 1.5
+++ prim-tycons.fun 23 Jun 2003 04:58:55 -0000 1.6
@@ -5,45 +5,90 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor PrimTycons (S: PRIM_TYCONS_STRUCTS)
- :> PRIM_TYCONS where type tycon = S.t =
- struct
- open S
-
- type tycon = t
-
- val array = fromString "array"
- val arrow = fromString "->"
- val bool = fromString "bool"
- val char = fromString "char"
- val exn = fromString "exn"
- val int = fromString "int"
- val intInf = fromString "intInf"
- val list = fromString "list"
- val pointer = fromString "pointer"
- val preThread = fromString "preThread"
- val real = fromString "real"
- val reff = fromString "ref"
- val thread = fromString "thread"
- val tuple = fromString "*"
- val vector = fromString "vector"
- val weak = fromString "weak"
- val word = fromString "word"
- val word8 = fromString "word8"
-
- val prims =
- [array, arrow, bool, char, exn, int, intInf, list, pointer,
- preThread, real, reff, thread, tuple, vector, weak, word, word8]
-
- val defaultInt = int
- val defaultWord = word
-
- fun equalTo t t' = equals (t, t')
-
- local
- fun is l t = List.exists (l, equalTo t)
- in
- val isWordX = is [word, word8]
- val isIntX = is [int, intInf]
- end
- end
+functor PrimTycons (S: PRIM_TYCONS_STRUCTS): PRIM_TYCONS =
+struct
+
+open S
+
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
+
+type tycon = t
+
+val array = fromString "array"
+val arrow = fromString "->"
+val bool = fromString "bool"
+val char = fromString "char"
+val exn = fromString "exn"
+val int8 = fromString "int8"
+val int16 = fromString "int16"
+val int32 = fromString "int32"
+val int64 = fromString "int64"
+val intInf = fromString "intInf"
+val list = fromString "list"
+val pointer = fromString "pointer"
+val preThread = fromString "preThread"
+val real32 = fromString "real32"
+val real64 = fromString "real64"
+val reff = fromString "ref"
+val thread = fromString "thread"
+val tuple = fromString "*"
+val vector = fromString "vector"
+val weak = fromString "weak"
+val word8 = fromString "word8"
+val word16 = fromString "word16"
+val word32 = fromString "word32"
+
+val ints =
+ [(int8, I8),
+ (int16, I16),
+ (int32, I32),
+ (int64, I64)]
+
+val reals =
+ [(real32, R32),
+ (real64, R64)]
+
+val words =
+ [(word8, W8),
+ (word16, W16),
+ (word32, W32)]
+
+val prims =
+ [array, arrow, bool, char, exn,
+ int8, int16, int32, int64, intInf,
+ list, pointer, preThread,
+ real32, real64,
+ reff, thread, tuple, vector, weak,
+ word8, word16, word32]
+
+val int =
+ fn I8 => int8
+ | I16 => int16
+ | I32 => int32
+ | I64 => int64
+
+val real =
+ fn R32 => real32
+ | R64 => real64
+
+val word =
+ fn W8 => word8
+ | W16 => word16
+ | W32 => word32
+
+val defaultInt = int IntSize.default
+val defaultReal = real RealSize.default
+val defaultWord = word WordSize.default
+
+local
+ fun is l t = List.exists (l, fn t' => equals (t, t'))
+in
+ val isIntX = is [int8, int16, int32, int64, int8, intInf]
+ val isRealX = is [real32, real64]
+ val isWordX = is [word8, word16, word32]
+end
+
+end
+
1.6 +22 -12 mlton/mlton/ast/prim-tycons.sig
Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- prim-tycons.sig 18 Apr 2003 22:44:58 -0000 1.5
+++ prim-tycons.sig 23 Jun 2003 04:58:55 -0000 1.6
@@ -7,39 +7,49 @@
*)
signature PRIM_TYCONS_STRUCTS =
sig
+ structure IntSize: INT_SIZE
+ structure RealSize: REAL_SIZE
+ structure WordSize: WORD_SIZE
+
type t
+
val fromString: string -> t
val equals: t * t -> bool
end
signature PRIM_TYCONS =
sig
+ structure IntSize: INT_SIZE
+ structure RealSize: REAL_SIZE
+ structure WordSize: WORD_SIZE
+
type tycon
val array: tycon
val arrow: tycon
val bool: tycon
val char: tycon
+ val defaultInt: tycon
+ val defaultReal: tycon
+ val defaultWord: tycon
val exn: tycon
- val int: tycon
+ val int: IntSize.t -> tycon
+ val ints: (tycon * IntSize.t) list
val intInf: tycon
+ val isIntX: tycon -> bool
+ val isRealX: tycon -> bool
+ val isWordX: tycon -> bool
val list: tycon
val pointer: tycon
val preThread: tycon
- val real: tycon
+ val prims: tycon list
+ val real: RealSize.t -> tycon
+ val reals: (tycon * RealSize.t) list
val reff: tycon
val thread: tycon
val tuple: tycon
val vector: tycon
val weak: tycon
- val word: tycon
- val word8: tycon
-
- val prims: tycon list
-
- val defaultInt: tycon
- val defaultWord: tycon
-
- val isWordX: tycon -> bool
- val isIntX: tycon -> bool
+ val word: WordSize.t -> tycon
+ val words: (tycon * WordSize.t) list
end
1.5 +15 -6 mlton/mlton/ast/record.fun
Index: record.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/record.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- record.fun 7 Dec 2002 02:21:51 -0000 1.4
+++ record.fun 23 Jun 2003 04:58:55 -0000 1.5
@@ -32,6 +32,9 @@
Tuple t => SOME t
| Record _ => NONE
+fun sort v =
+ QuickSort.sortVector (v, fn ((s, _), (s', _)) => Field.<= (s, s'))
+
fun fromVector v =
let
fun isTuple v : bool =
@@ -40,15 +43,21 @@
case f of
Field.Int i' => Int.equals (i, i')
| _ => false)
- val v =
- if isSorted
- then QuickSort.sortVector (v, fn ((s, _), (s', _)) =>
- Field.<= (s, s'))
- else v
- in if isTuple v
+ val v = if isSorted then sort v else v
+ in
+ if isTuple v
then Tuple (Vector.map (v, #2))
else Record v
end
+
+fun equals (r, r', eq) =
+ case (r, r') of
+ (Tuple v, Tuple v') => Vector.equals (v, v', eq)
+ | (Record fs, Record fs') =>
+ Vector.equals
+ (fs, sort fs', fn ((f, v), (f', v')) =>
+ Field.equals (f, f') andalso eq (v, v'))
+ | _ => false
val peek: 'a t * Field.t -> 'a option =
fn (r, f) =>
1.3 +1 -0 mlton/mlton/ast/record.sig
Index: record.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/record.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- record.sig 10 Apr 2002 07:02:18 -0000 1.2
+++ record.sig 23 Jun 2003 04:58:55 -0000 1.3
@@ -23,6 +23,7 @@
val change: 'a t * ('a vector -> 'b vector * 'c) -> 'b t * 'c
(* detuple r returns the components, if r is a tuple *)
val detupleOpt: 'a t -> 'a vector option
+ val equals: 'a t * 'a t * ('a * 'a -> bool) -> bool
val exists: 'a t * ('a -> bool) -> bool
val fold: 'a t * 'b * ('a * 'b -> 'b) -> 'b
val foldi: 'a t * 'b * (Field.t * 'a * 'b ->'b) -> 'b
1.4 +28 -19 mlton/mlton/ast/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.3
+++ sources.cm 23 Jun 2003 04:58:55 -0000 1.4
@@ -9,11 +9,14 @@
signature AST
signature AST_ID
+signature INT_SIZE
signature LONGID
signature PRIM_CONS
signature PRIM_TYCONS
+signature REAL_SIZE
signature RECORD
signature TYVAR
+signature WORD_SIZE
signature WRAPPED
functor Ast
@@ -25,26 +28,32 @@
../../lib/mlton/sources.cm
../control/sources.cm
-wrapped.sig
-tyvar.sig
-tyvar.fun
-field.sig
-record.sig
-record.fun
-field.fun
-ast-const.sig
-ast-const.fun
-prim-tycons.sig
-prim-cons.sig
-ast-id.sig
-longid.sig
+ast-atoms.fun
ast-atoms.sig
-ast-core.sig
+ast-const.fun
+ast-const.sig
ast-core.fun
-prim-tycons.fun
-prim-cons.fun
-longid.fun
+ast-core.sig
ast-id.fun
-ast-atoms.fun
-ast.sig
+ast-id.sig
ast.fun
+ast.sig
+field.fun
+field.sig
+int-size.fun
+int-size.sig
+longid.fun
+longid.sig
+prim-cons.fun
+prim-cons.sig
+prim-tycons.fun
+prim-tycons.sig
+real-size.fun
+real-size.sig
+record.fun
+record.sig
+tyvar.fun
+tyvar.sig
+word-size.fun
+word-size.sig
+wrapped.sig
1.1 mlton/mlton/ast/int-size.fun
Index: int-size.fun
===================================================================
functor IntSize (S: INT_SIZE_STRUCTS): INT_SIZE =
struct
datatype t = I8 | I16 | I32 | I64
val equals: t * t -> bool = op =
val all = [I8, I16, I32, I64]
val default = I32
val bytes: t -> int =
fn I8 => 1
| I16 => 2
| I32 => 4
| I64 => 8
fun size s = 8 * bytes s
val toString = Int.toString o size
val layout = Layout.str o toString
val memoize: (t -> 'a) -> t -> 'a =
fn f =>
let
val a8 = f I8
val a16 = f I16
val a32 = f I32
val a64 = f I64
in
fn I8 => a8
| I16 => a16
| I32 => a32
| I64 => a64
end
val range =
memoize
(fn s =>
let
val pow = IntInf.pow (IntInf.fromInt 2, size s - 1)
in
(IntInf.~ pow, IntInf.- (pow, IntInf.fromInt 1))
end)
fun isInRange (s, i) =
let
val (min, max) = range s
in
IntInf.<= (min, i) andalso IntInf.<= (i, max)
end
val min = #1 o range
val max = #2 o range
end
1.1 mlton/mlton/ast/int-size.sig
Index: int-size.sig
===================================================================
type int = Int.t
signature INT_SIZE_STRUCTS =
sig
end
signature INT_SIZE =
sig
include INT_SIZE_STRUCTS
datatype t = I8 | I16 | I32 | I64
val all: t list
val bytes: t -> int
val default: t
val equals: t * t -> bool
val isInRange: t * IntInf.t -> bool
val layout: t -> Layout.t
val max: t -> IntInf.t
val memoize: (t -> 'a) -> t -> 'a
val min: t -> IntInf.t
val range: t -> IntInf.t * IntInf.t
val size: t -> int
val toString: t -> string
end
1.1 mlton/mlton/ast/real-size.fun
Index: real-size.fun
===================================================================
functor RealSize (S: REAL_SIZE_STRUCTS): REAL_SIZE =
struct
open S
datatype t = R32 | R64
val all = [R32, R64]
val default = R64
val equals: t * t -> bool = op =
val memoize: (t -> 'a) -> t -> 'a =
fn f =>
let
val r32 = f R32
val r64 = f R64
in
fn R32 => r32
| R64 => r64
end
val toString =
fn R32 => "32"
| R64 => "64"
val bytes: t -> int =
fn R32 => 4
| R64 => 8
end
1.1 mlton/mlton/ast/real-size.sig
Index: real-size.sig
===================================================================
type int = Int.t
type word = Word.t
signature REAL_SIZE_STRUCTS =
sig
end
signature REAL_SIZE =
sig
include REAL_SIZE_STRUCTS
datatype t = R32 | R64
val all: t list
val bytes: t -> int
val default: t
val equals: t * t -> bool
val memoize: (t -> 'a) -> t -> 'a
val toString: t -> string
end
1.1 mlton/mlton/ast/word-size.fun
Index: word-size.fun
===================================================================
functor WordSize (S: WORD_SIZE_STRUCTS): WORD_SIZE =
struct
datatype t = W8 | W16 | W32
val equals: t * t -> bool = op =
val all = [W8, W16, W32]
val default = W32
val max: t -> word =
fn W8 => 0wxFF
| W16 => 0wxFFFF
| W32 => 0wxFFFFFFFF
val allOnes = max
val bytes: t -> int =
fn W8 => 1
| W16 => 2
| W32 => 4
fun size s = 8 * bytes s
fun toString w = Int.toString (size w)
val memoize: (t -> 'a) -> t -> 'a =
fn f =>
let
val a8 = f W8
val a16 = f W16
val a32 = f W32
in
fn W8 => a8
| W16 => a16
| W32 => a32
end
end
1.1 mlton/mlton/ast/word-size.sig
Index: word-size.sig
===================================================================
type int = Int.t
type word = Word.t
signature WORD_SIZE_STRUCTS =
sig
end
signature WORD_SIZE =
sig
include WORD_SIZE_STRUCTS
datatype t = W8 | W16 | W32
val all: t list
val allOnes: t -> word
val bytes: t -> int
val default: t
val equals: t * t -> bool
val max: t -> word
val memoize: (t -> 'a) -> t -> 'a
val size: t -> int
val toString: t -> string
end
1.7 +20 -6 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- atoms.fun 18 Apr 2003 22:44:58 -0000 1.6
+++ atoms.fun 23 Jun 2003 04:58:55 -0000 1.7
@@ -15,12 +15,18 @@
structure SourceInfo = SourceInfo ()
structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
structure Var = Var (structure AstId = Ast.Var)
- structure Tycon = Tycon (structure AstId = Ast.Tycon)
+ structure Tycon = Tycon (structure AstId = Ast.Tycon
+ structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize)
+ fun f (x: IntSize.t): Tycon.IntSize.t = x
structure Type =
Type (structure Ast = Ast
- structure Record = Ast.SortedRecord
- structure Tyvar = Ast.Tyvar
- structure Tycon = Tycon)
+ structure IntSize = IntSize
+ structure Record = Ast.SortedRecord
+ structure Tyvar = Ast.Tyvar
+ structure Tycon = Tycon
+ structure WordSize = WordSize)
structure Scheme: SCHEME =
struct
structure Arg =
@@ -34,13 +40,21 @@
end
structure Con = Con (structure AstId = Ast.Con
structure Var = Var)
+ structure IntX = IntX (structure IntSize = IntSize)
+ structure RealX = RealX (structure RealSize = RealSize)
+ structure WordX = WordX (structure WordSize = WordSize)
structure Const = Const (structure Ast = Ast
- structure Tycon = Tycon)
+ structure IntX = IntX
+ structure RealX = RealX
+ structure WordX = WordX)
structure Prim = Prim (structure Con = Con
structure Const = Const
+ structure IntSize = IntSize
structure Longid = Ast.Longvid
+ structure RealSize = RealSize
+ structure Scheme = Scheme
structure Type = Type
- structure Scheme = Scheme)
+ structure WordSize = WordSize)
structure Record = Ast.Record
structure SortedRecord = Ast.SortedRecord
structure Tyvar = Ast.Tyvar
1.7 +12 -1 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- atoms.sig 18 Apr 2003 22:44:58 -0000 1.6
+++ atoms.sig 23 Jun 2003 04:58:55 -0000 1.7
@@ -8,6 +8,9 @@
signature ATOMS_STRUCTS =
sig
structure Ast: AST
+ structure IntSize: INT_SIZE
+ structure RealSize: REAL_SIZE
+ structure WordSize: WORD_SIZE
end
signature ATOMS' =
@@ -17,8 +20,10 @@
structure Con: CON
structure Cons: SET
structure Const: CONST
+ structure IntX: INT_X
structure Prim: PRIM
structure ProfileExp: PROFILE_EXP
+ structure RealX: REAL_X
structure Record: RECORD
structure Scheme: SCHEME
structure SortedRecord: RECORD
@@ -39,6 +44,7 @@
val rename: t * Tyvar.t vector -> t * Tyvar.t vector
end
structure Tyvars: SET
+ structure WordX: WORD_X
sharing Ast = Const.Ast = Prim.Type.Ast
sharing Ast.Con = Con.AstId
@@ -47,13 +53,18 @@
sharing Ast.Var = Var.AstId
sharing Con = Prim.Con
sharing Const = Prim.Const
+ sharing IntSize = IntX.IntSize = Prim.IntSize = Tycon.IntSize
+ sharing IntX = Const.IntX
+ sharing RealSize = Prim.RealSize = RealX.RealSize = Tycon.RealSize
+ sharing RealX = Const.RealX
sharing Record = Ast.Record
sharing Scheme = Prim.Scheme
sharing SortedRecord = Ast.SortedRecord
sharing SourceInfo = ProfileExp.SourceInfo
- sharing Tycon = Const.Tycon
sharing Tycon = Scheme.Tycon
sharing Tyvar = Ast.Tyvar
+ sharing WordSize = Prim.WordSize = Tycon.WordSize = WordX.WordSize
+ sharing WordX = Const.WordX
sharing type Con.t = Cons.Element.t
sharing type Tycon.t = Tycons.Element.t
sharing type Tyvar.t = TyvarEnv.Domain.t
1.4 +1 -91 mlton/mlton/atoms/cases.fun
Index: cases.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/cases.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- cases.fun 16 Apr 2002 12:10:52 -0000 1.3
+++ cases.fun 23 Jun 2003 04:58:55 -0000 1.4
@@ -13,99 +13,9 @@
datatype 'a t =
Char of (char * 'a) vector
| Con of (con * 'a) vector
- | Int of (int * 'a) vector
+ | Int of (IntInf.t * 'a) vector
| Word of (word * 'a) vector
- | Word8 of (Word8.t * 'a) vector
-fun equals (c1: 'a t, c2: 'a t, eq: 'a * 'a -> bool): bool =
- let
- fun doit (l1, l2, eq') =
- Vector.equals
- (l1, l2, fn ((x1, a1), (x2, a2)) =>
- eq' (x1, x2) andalso eq (a1, a2))
- in case (c1, c2) of
- (Char l1, Char l2) => doit (l1, l2, Char.equals)
- | (Con l1, Con l2) => doit (l1, l2, conEquals)
- | (Int l1, Int l2) => doit (l1, l2, Int.equals)
- | (Word l1, Word l2) => doit (l1, l2, Word.equals)
- | (Word8 l1, Word8 l2) => doit (l1, l2, Word8.equals)
- | _ => false
- end
-
-fun fold (c: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b =
- let
- fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
- in case c of
- Char l => doit l
- | Con l => doit l
- | Int l => doit l
- | Word l => doit l
- | Word8 l => doit l
- end
-
-fun map (c: 'a t, f: 'a -> 'b): 'b t =
- let
- fun doit l = Vector.map (l, fn (i, x) => (i, f x))
- in case c of
- Char l => Char (doit l)
- | Con l => Con (doit l)
- | Int l => Int (doit l)
- | Word l => Word (doit l)
- | Word8 l => Word8 (doit l)
- end
-
-fun forall (c: 'a t, f: 'a -> bool): bool =
- let
- fun doit l = Vector.forall (l, fn (_, x) => f x)
- in case c of
- Char l => doit l
- | Con l => doit l
- | Int l => doit l
- | Word l => doit l
- | Word8 l => doit l
- end
-
-fun isEmpty (c: 'a t): bool =
- let
- fun doit v = 0 = Vector.length v
- in case c of
- Char v => doit v
- | Con v => doit v
- | Int v => doit v
- | Word v => doit v
- | Word8 v => doit v
- end
-
-fun hd (c: 'a t): 'a =
- let
- fun doit v =
- if Vector.length v >= 1
- then let val (_, a) = Vector.sub (v, 0)
- in a
- end
- else Error.bug "Cases.hd"
- in case c of
- Char l => doit l
- | Con l => doit l
- | Int l => doit l
- | Word l => doit l
- | Word8 l => doit l
- end
-
-fun length (c: 'a t): int = fold (c, 0, fn (_, i) => i + 1)
-
-fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
-
-fun foreach' (c: 'a t, f: 'a -> unit, fc: con -> unit): unit =
- let
- fun doit l = Vector.foreach (l, fn (_, a) => f a)
- in case c of
- Char l => doit l
- | Con l => Vector.foreach (l, fn (c, a) => (fc c; f a))
- | Int l => doit l
- | Word l => doit l
- | Word8 l => doit l
- end
end
1.4 +5 -13 mlton/mlton/atoms/cases.sig
Index: cases.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/cases.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- cases.sig 16 Apr 2002 12:10:52 -0000 1.3
+++ cases.sig 23 Jun 2003 04:58:55 -0000 1.4
@@ -6,12 +6,14 @@
* Please see the file MLton-LICENSE for license information.
*)
type int = Int.t
-type word = Word.t
signature CASES_STRUCTS =
sig
type con
- val conEquals : con * con -> bool
+ type word
+
+ val conEquals: con * con -> bool
+ val wordEquals: word * word -> bool
end
signature CASES =
@@ -21,9 +23,8 @@
datatype 'a t =
Char of (char * 'a) vector
| Con of (con * 'a) vector
- | Int of (int * 'a) vector
+ | Int of (IntInf.t * 'a) vector
| Word of (word * 'a) vector
- | Word8 of (Word8.t * 'a) vector
val equals: 'a t * 'a t * ('a * 'a -> bool) -> bool
val fold: 'a t * 'b * ('a * 'b -> 'b) -> 'b
@@ -35,12 +36,3 @@
val length: 'a t -> int
val map: 'a t * ('a -> 'b) -> 'b t
end
-
-functor TestCasesVector (S: CASES) =
-struct
-
-open S
-
-val _ = Assert.assert ("Cases", fn () => true)
-
-end
1.8 +80 -128 mlton/mlton/atoms/const.fun
Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- const.fun 19 May 2003 18:36:45 -0000 1.7
+++ const.fun 23 Jun 2003 04:58:55 -0000 1.8
@@ -10,146 +10,28 @@
open S
-local open Ast
-in structure Aconst = Const
-end
-
-structure Type =
- struct
- type t = Tycon.t * Tycon.t vector
- fun equals ((tc1,tcs1), (tc2,tcs2)) =
- Tycon.equals (tc1, tc2)
- andalso
- Vector.equals (tcs1, tcs2, Tycon.equals)
- fun toType ((tc,tcs), con) =
- con (tc, Vector.map (tcs, fn tc => con (tc, Vector.new0())))
- val layout = Ast.Type.layout o (fn t =>
- toType (t, fn (t, ts) =>
- Ast.Type.con (Tycon.toAst t, ts)))
- val toString = Layout.toString o layout
- fun make (tc, tcs) : t = (tc, tcs)
- fun unary (tc, tc') = make (tc, Vector.new1 tc')
- fun nullary tc = make (tc, Vector.new0())
- val bool = nullary Tycon.bool
- val char = nullary Tycon.char
- val int = nullary Tycon.defaultInt
- val intInf = nullary Tycon.intInf
- val real = nullary Tycon.real
- val word = nullary Tycon.word
- val word8 = nullary Tycon.word8
- val string = unary (Tycon.vector, Tycon.char)
- end
-
-structure Node =
- struct
- datatype t =
- Char of char
- | Int of int
- | IntInf of IntInf.t
- | Real of string
- | String of string
- | Word of word
-
- local
- open Layout
- fun wrap (pre, post, s) = seq [str pre, String.layout s, str post]
- in
- val layout =
- fn Char c => wrap ("#\"", "\"", String.implode [c])
- | Int n => str (Int.toString n)
- | IntInf s => IntInf.layout s
- | Real r => String.layout r
- | String s => wrap ("\"", "\"", s)
- | Word w => seq [str "0wx", str (Word.toString w)]
- end
- end
-
-datatype z = datatype Node.t
-datatype t = T of {node: Node.t,
- ty: Type.t}
-
local
- fun make sel (T r) = sel r
+ open Ast
in
- val node = make #node
- val ty = make #ty
+ structure Aconst = Const
end
-
-val layout = Node.layout o node
-val toString = Layout.toString o layout
-
-fun make (n, t) = T {node = n, ty = t}
-
local
- val char = Random.word ()
- val truee = Random.word ()
- val falsee = Random.word ()
+ open IntX
in
- fun hash (c: t): word =
- case node c of
- Char c => Word.xorb (char, Word.fromChar c)
- | Int i => Word.fromInt i
- | IntInf i => String.hash (IntInf.toString i)
- | Real r => String.hash r
- | String s => String.hash s
- | Word w => w
+ structure IntSize = IntSize
end
-
-fun 'a toAst (make: Ast.Const.t -> 'a, constrain: 'a * Ast.Type.t -> 'a) c =
- let
- val make = fn n => make (Ast.Const.makeRegion (n, Region.bogus))
- fun maybeConstrain (defaultTycon, aconst) =
- let
- val ty = ty c
- val con : Tycon.t * Ast.Type.t vector -> Ast.Type.t =
- fn (t, ts) => Ast.Type.con (Tycon.toAst t, ts)
- in
- if Type.equals (ty, Type.nullary defaultTycon)
- then make aconst
- else constrain (make aconst, Type.toType (ty, con))
- end
- fun int s = maybeConstrain (Tycon.defaultInt, Aconst.Int s)
- in
- case node c of
- Char c => make (Aconst.Char c)
- | Int n => int (Int.toString n)
- | IntInf i => int (IntInf.toString i)
- | Real r => make (Aconst.Real r)
- | String s => make (Aconst.String s)
- | Word w => maybeConstrain (Tycon.defaultWord, Aconst.Word w)
- end
-
-val toAstExp = toAst (Ast.Exp.const, Ast.Exp.constraint)
-val toAstPat = toAst (Ast.Pat.const, Ast.Pat.constraint)
-
-fun equals (c, c') =
- Type.equals (ty c, ty c')
- andalso
- case (node c, node c') of
- (Char c, Char c') => c = c'
- | (Int n, Int n') => n = n'
- | (IntInf i, IntInf i') => IntInf.equals (i, i')
- | (Real r, Real r') => String.equals (r, r')
- | (String s, String s') => String.equals (s, s')
- | (Word w, Word w') => w = w'
- | _ => false
-
-val equals = Trace.trace2 ("Const.equals", layout, layout, Bool.layout) equals
-
local
- fun make c t x = T {node = c x, ty = t}
+ open WordX
in
- val fromChar = make Char Type.char
- val fromInt = make Int Type.int
- val fromIntInf = make IntInf Type.intInf
- val fromReal = make Real Type.real
- val fromString = make String Type.string
- val fromWord = make Word Type.word
- val fromWord8 = make (fn w => Word (Word.fromWord8 w)) Type.word8
+ structure WordSize = WordSize
end
+datatype z = datatype IntSize.t
+datatype z = datatype WordSize.t
+
structure SmallIntInf =
struct
+ structure Word = Pervasive.Word
(*
* The IntInf.fromInt calls are just because SML/NJ doesn't
* overload integer constants for IntInf.int's.
@@ -176,5 +58,75 @@
then SOME (IntInf.fromInt (Word.toIntX (Word.~>> (w, 0w1))))
else NONE
end
+
+datatype t =
+ Int of IntX.t
+ | IntInf of IntInf.t
+ | Real of RealX.t
+ | Word of WordX.t
+ | Word8Vector of Word8.t vector
+
+val int = Int
+val real = Real
+val intInf = IntInf
+val word = Word
+val word8Vector = Word8Vector
+
+val word8 = word o WordX.fromWord8
+val string = word8Vector o Word8.stringToVector
+
+local
+ open Layout
+ fun wrap (pre, post, s) = seq [str pre, String.layout s, str post]
+in
+ val layout =
+ fn Int i => IntX.layout i
+ | IntInf i => IntInf.layout i
+ | Real r => RealX.layout r
+ | Word w => WordX.layout w
+ | Word8Vector v => wrap ("\"", "\"", Word8.vectorToString v)
+end
+
+val toString = Layout.toString o layout
+
+local
+ val truee = Random.word ()
+ val falsee = Random.word ()
+in
+ fun hash (c: t): word =
+ case c of
+ Int i => String.hash (IntX.toString i)
+ | IntInf i => String.hash (IntInf.toString i)
+ | Real r => RealX.hash r
+ | Word w => WordX.toWord w
+ | Word8Vector v => String.hash (Word8.vectorToString v)
+end
+
+fun 'a toAst (make: Ast.Const.t -> 'a, constrain: 'a * Ast.Type.t -> 'a) c =
+ let
+ val aconst =
+ case c of
+ Int i => Aconst.Int (IntX.toIntInf i)
+ | IntInf i => Aconst.Int i
+ | Real r => Aconst.Real (RealX.toString r)
+ | Word w => Aconst.Word (WordX.toIntInf w)
+ | Word8Vector v => Aconst.String (Word8.vectorToString v)
+ in
+ make (Ast.Const.makeRegion (aconst, Region.bogus))
+ end
+
+val toAstExp = toAst (Ast.Exp.const, Ast.Exp.constraint)
+val toAstPat = toAst (Ast.Pat.const, Ast.Pat.constraint)
+
+fun equals (c, c') =
+ case (c, c') of
+ (Int i, Int i') => IntX.equals (i, i')
+ | (IntInf i, IntInf i') => IntInf.equals (i, i')
+ | (Real r, Real r') => RealX.equals (r, r')
+ | (Word w, Word w') => WordX.equals (w, w')
+ | (Word8Vector v, Word8Vector v') => v = v'
+ | _ => false
+
+val equals = Trace.trace2 ("Const.equals", layout, layout, Bool.layout) equals
end
1.7 +16 -45 mlton/mlton/atoms/const.sig
Index: const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- const.sig 19 May 2003 18:36:45 -0000 1.6
+++ const.sig 23 Jun 2003 04:58:55 -0000 1.7
@@ -11,33 +11,15 @@
signature CONST_STRUCTS =
sig
structure Ast: AST
- structure Tycon: TYCON
- sharing Tycon.AstId = Ast.Tycon
- sharing Tycon.AstId = Ast.Tycon
+ structure IntX: INT_X
+ structure RealX: REAL_X
+ structure WordX: WORD_X
end
signature CONST =
sig
include CONST_STRUCTS
- structure Type:
- sig
- type t
- val make: Tycon.t * Tycon.t vector -> t
- val equals: t * t -> bool
- val layout: t -> Layout.t
- val toString: t -> string
- val toType: t * (Tycon.t * 'a vector -> 'a) -> 'a
- val bool: t
- val char: t
- val int: t
- val intInf: t
- val real: t
- val string: t
- val word: t
- val word8: t
- end
-
structure SmallIntInf:
sig
val isSmall: IntInf.t -> bool
@@ -45,35 +27,24 @@
val fromWord: word -> IntInf.t option
end
- type t
-
- structure Node:
- sig
- datatype t =
- Char of char
- | Int of int
- | IntInf of IntInf.t
- | Real of string
- | String of string
- | Word of word
-
- val layout: t -> Layout.t
- end
+ datatype t =
+ Int of IntX.t
+ | IntInf of IntInf.t
+ | Real of RealX.t
+ | Word of WordX.t
+ | Word8Vector of Word8.t vector
val equals: t * t -> bool
- val fromChar: char -> t
- val fromInt: int -> t
- val fromIntInf: IntInf.t -> t
- val fromReal: string -> t
- val fromString: string -> t
- val fromWord: word -> t
- val fromWord8: Word8.t -> t
+ val int: IntX.t -> t
+ val intInf: IntInf.t -> t
val hash: t -> word
val layout: t -> Layout.t
- val make: Node.t * Type.t -> t
- val node: t -> Node.t
+ val real: RealX.t -> t
+ val string: string -> t
val toAstExp: t -> Ast.Exp.t
val toAstPat: t -> Ast.Pat.t
val toString: t -> string
- val ty: t -> Type.t
+ val word: WordX.t -> t
+ val word8: Word8.t -> t
+ val word8Vector: Word8.t vector -> t
end
1.7 +18 -2 mlton/mlton/atoms/hash-type.fun
Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- hash-type.fun 9 May 2003 19:29:42 -0000 1.6
+++ hash-type.fun 23 Jun 2003 04:58:55 -0000 1.7
@@ -99,6 +99,8 @@
val layout = Ast.Type.layout o toAst
+ val toString = Layout.toString o layout
+
(* let open Layout
* n
* case tree of
@@ -153,10 +155,14 @@
layout) con
end
end
-structure Ops = TypeOps (structure Tycon = Tycon
+structure Ops = TypeOps (structure IntSize = IntSize
+ structure Tycon = Tycon
+ structure WordSize = WordSize
open Type)
open Type Ops
+val string = word8Vector
+
structure Plist = PropertyList
local structure Type = Ast.Type
@@ -175,7 +181,17 @@
fun optionToAst z = Option.map (z, toAst)
-fun ofConst c = Const.Type.toType (Const.ty c, con)
+fun ofConst c =
+ let
+ datatype z = datatype Const.t
+ in
+ case c of
+ Int i => int (IntX.size i)
+ | IntInf _ => intInf
+ | Real r => real (RealX.size r)
+ | Word w => word (WordX.size w)
+ | Word8Vector _ => word8Vector
+ end
fun isUnit t =
case dest t of
1.4 +7 -1 mlton/mlton/atoms/hash-type.sig
Index: hash-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- hash-type.sig 10 Apr 2002 07:02:18 -0000 1.3
+++ hash-type.sig 23 Jun 2003 04:58:55 -0000 1.4
@@ -13,7 +13,11 @@
signature HASH_TYPE =
sig
include HASH_TYPE_STRUCTS
- include TYPE_OPS sharing type tycon = Tycon.t
+ include TYPE_OPS
+ sharing type intSize = IntSize.t
+ sharing type realSize = RealSize.t
+ sharing type tycon = Tycon.t
+ sharing type wordSize = WordSize.t
structure Dest:
sig
@@ -48,6 +52,7 @@
val optionToAst: t option -> Ast.Type.t option
val plist: t -> PropertyList.t
val stats: unit -> Layout.t
+ val string: t (* synonym for word8Vector *)
(* substitute (t, [(a1, t1), ..., (an, tn)]) performs simultaneous
* substitution of the ti for ai in t.
* The ai's are not required to contain every free variable in t
@@ -56,6 +61,7 @@
(* conversion to Ast *)
val toAst: t -> Ast.Type.t
val toPrim: t -> Prim.Type.t
+ val toString: t -> string
val tycon: t -> Tycon.t
val var: Tyvar.t -> t
end
1.50 +699 -736 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -r1.49 -r1.50
--- prim.fun 20 May 2003 02:18:26 -0000 1.49
+++ prim.fun 23 Jun 2003 04:58:55 -0000 1.50
@@ -15,7 +15,18 @@
open S
-local open Type
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
+
+local
+ open Const
+in
+ structure IntX = IntX
+ structure WordX = WordX
+end
+local
+ open Type
in
structure Tycon = Tycon
structure Tyvar = Tyvar
@@ -33,236 +44,297 @@
structure Name =
struct
datatype t =
- Array_array
- | Array_array0Const
- | Array_length
- | Array_sub
- | Array_update
- | BuildConstant of string
- | Byte_byteToChar
- | Byte_charToByte
- | C_CS_charArrayToWord8Array
- | Char_chr
- | Char_ge
- | Char_gt
- | Char_le
- | Char_lt
- | Char_ord
- | Constant of string
- | Cpointer_isNull
- | Exn_extra
- | Exn_keepHistory
- | Exn_name
- | Exn_setExtendExtra
- | Exn_setInitExtra
- | Exn_setTopLevelHandler
- | FFI of string
- | GC_collect
- | GC_pack
- | GC_unpack
- | Int_add
- | Int_addCheck
- | Int_ge
- | Int_geu
- | Int_gt
- | Int_gtu
- | Int_le
- | Int_lt
- | Int_mul
- | Int_mulCheck
- | Int_neg
- | Int_negCheck
- | Int_quot
- | Int_rem
- | Int_sub
- | Int_subCheck
- | IntInf_add
- | IntInf_andb
- | IntInf_arshift
- | IntInf_compare
- | IntInf_equal
- | IntInf_fromVector
- | IntInf_fromWord
- | IntInf_gcd
- | IntInf_lshift
- | IntInf_mul
- | IntInf_notb
- | IntInf_neg
- | IntInf_orb
- | IntInf_quot
- | IntInf_rem
- | IntInf_sub
- | IntInf_toString
- | IntInf_toVector
- | IntInf_toWord
- | IntInf_xorb
- | MLton_bogus
- | MLton_bug
- | MLton_deserialize
- | MLton_eq
- | MLton_equal
- | MLton_halt
- | MLton_handlesSignals
- | MLton_installSignalHandler
- | MLton_serialize
- | MLton_size
- | MLton_touch
- | Real_Math_acos
- | Real_Math_asin
- | Real_Math_atan
- | Real_Math_atan2
- | Real_Math_cos
- | Real_Math_cosh
- | Real_Math_exp
- | Real_Math_ln
- | Real_Math_log10
- | Real_Math_pow
- | Real_Math_sin
- | Real_Math_sinh
- | Real_Math_sqrt
- | Real_Math_tan
- | Real_Math_tanh
- | Real_abs
- | Real_add
- | Real_copysign
- | Real_div
- | Real_equal
- | Real_frexp
- | Real_fromInt
- | Real_ge
- | Real_gt
- | Real_ldexp
- | Real_le
- | Real_lt
- | Real_modf
- | Real_mul
- | Real_muladd
- | Real_mulsub
- | Real_neg
- | Real_qequal
- | Real_round
- | Real_sub
- | Real_toInt
- | Ref_assign
- | Ref_deref
- | Ref_ref
- | String_fromWord8Vector
- | String_toWord8Vector
- | Thread_atomicBegin
- | Thread_atomicEnd
- | Thread_canHandle
- | Thread_copy
- | Thread_copyCurrent
- | Thread_returnToC
- | Thread_switchTo
- | Vector_fromArray
- | Vector_length
- | Vector_sub
- | Weak_canGet
- | Weak_get
- | Weak_new
- | Word32_add
- | Word32_addCheck
- | Word32_andb
- | Word32_arshift
- | Word32_div
- | Word32_fromInt
- | Word32_ge
- | Word32_gt
- | Word32_le
- | Word32_lshift
- | Word32_lt
- | Word32_mod
- | Word32_mul
- | Word32_mulCheck
- | Word32_neg
- | Word32_notb
- | Word32_orb
- | Word32_rol
- | Word32_ror
- | Word32_rshift
- | Word32_sub
- | Word32_toIntX
- | Word32_xorb
- | Word8Array_subWord
- | Word8Array_updateWord
- | Word8Vector_subWord
- | Word8_add
- | Word8_andb
- | Word8_arshift
- | Word8_div
- | Word8_fromInt
- | Word8_fromLargeWord
- | Word8_ge
- | Word8_gt
- | Word8_le
- | Word8_lshift
- | Word8_lt
- | Word8_mod
- | Word8_mul
- | Word8_neg
- | Word8_notb
- | Word8_orb
- | Word8_rol
- | Word8_ror
- | Word8_rshift
- | Word8_sub
- | Word8_toInt
- | Word8_toIntX
- | Word8_toLargeWord
- | Word8_toLargeWordX
- | Word8_xorb
- | World_save
+ Array_array (* backend *)
+ | Array_array0Const (* constant propagation *)
+ | Array_length (* ssa to rssa *)
+ | Array_sub (* backend *)
+ | Array_toVector (* backend *)
+ | Array_update (* backend *)
+ | BuildConstant of string (* type inference *)
+ | Byte_byteToChar (* ssa to rssa *)
+ | Byte_charToByte (* ssa to rssa *)
+ | C_CS_charArrayToWord8Array (* ssa to rssa *)
+ | Char_lt (* codegen *)
+ | Char_le (* codegen *)
+ | Char_gt (* codegen *)
+ | Char_ge (* codegen *)
+ | Char_chr (* codegen *)
+ | Char_ord (* codegen *)
+ | Constant of string (* type inference *)
+ | Cpointer_isNull (* codegen *)
+ | Exn_extra (* implement exceptions *)
+ | Exn_keepHistory (* a compile-time boolean *)
+ | Exn_name (* implement exceptions *)
+ | Exn_setExtendExtra (* implement exceptions *)
+ | Exn_setInitExtra (* implement exceptions *)
+ | Exn_setTopLevelHandler (* implement exceptions *)
+ | FFI of string (* ssa to rssa *)
+ | GC_collect (* ssa to rssa *)
+ | GC_pack (* ssa to rssa *)
+ | GC_unpack (* ssa to rssa *)
+ | Int_add of IntSize.t (* codegen *)
+ | Int_addCheck of IntSize.t (* codegen *)
+ | Int_ge of IntSize.t (* codegen *)
+ | Int_gt of IntSize.t (* codegen *)
+ | Int_le of IntSize.t (* codegen *)
+ | Int_lt of IntSize.t (* codegen *)
+ | Int_mul of IntSize.t (* codegen *)
+ | Int_mulCheck of IntSize.t (* codegen *)
+ | Int_neg of IntSize.t (* codegen *)
+ | Int_negCheck of IntSize.t (* codegen *)
+ | Int_quot of IntSize.t (* codegen *)
+ | Int_rem of IntSize.t (* codegen *)
+ | Int_sub of IntSize.t (* codegen *)
+ | Int_subCheck of IntSize.t (* codegen *)
+ | Int_toReal of IntSize.t * RealSize.t (* codegen *)
+ | Int_toWord of IntSize.t * WordSize.t (* codegen *)
+ | IntInf_add (* ssa to rssa *)
+ | IntInf_andb (* ssa to rssa *)
+ | IntInf_arshift (* ssa to rssa *)
+ | IntInf_compare (* ssa to rssa *)
+ | IntInf_equal (* ssa to rssa *)
+ | IntInf_gcd (* ssa to rssa *)
+ | IntInf_lshift (* ssa to rssa *)
+ | IntInf_mul (* ssa to rssa *)
+ | IntInf_neg (* ssa to rssa *)
+ | IntInf_notb (* ssa to rssa *)
+ | IntInf_orb (* ssa to rssa *)
+ | IntInf_quot (* ssa to rssa *)
+ | IntInf_rem (* ssa to rssa *)
+ | IntInf_sub (* ssa to rssa *)
+ | IntInf_toString (* ssa to rssa *)
+ | IntInf_toVector (* ssa to rssa *)
+ | IntInf_toWord (* ssa to rssa *)
+ | IntInf_xorb (* ssa to rssa *)
+ | MLton_bogus (* ssa to rssa *)
+ (* of type unit -> 'a.
+ * Makes a bogus value of any type.
+ *)
+ | MLton_bug (* ssa to rssa *)
+ | MLton_deserialize (* unused *)
+ | MLton_eq (* codegen *)
+ | MLton_equal (* polymorphic equality *)
+ | MLton_halt (* ssa to rssa *)
+ (* MLton_handlesSignals and MLton_installSignalHandler work together
+ * to inform the optimizer and basis library whether or not the
+ * program uses signal handlers.
+ *
+ * MLton_installSignalHandler is called by MLton.Signal.setHandler,
+ * and is effectively a noop, but is left in the program until the
+ * end of the backend, so that the optimizer can test whether or
+ * not the program installs signal handlers.
+ *
+ * MLton_handlesSignals is translated by closure conversion into
+ * a boolean, and is true iff MLton_installsSignalHandler is called.
+ *)
+ | MLton_handlesSignals (* closure conversion *)
+ | MLton_installSignalHandler (* backend *)
+ | MLton_serialize (* unused *)
+ | MLton_size (* ssa to rssa *)
+ | MLton_touch (* backend *)
+ | Real_Math_acos of RealSize.t (* codegen *)
+ | Real_Math_asin of RealSize.t (* codegen *)
+ | Real_Math_atan of RealSize.t (* codegen *)
+ | Real_Math_atan2 of RealSize.t (* codegen *)
+ | Real_Math_cos of RealSize.t (* codegen *)
+ | Real_Math_exp of RealSize.t (* codegen *)
+ | Real_Math_ln of RealSize.t (* codegen *)
+ | Real_Math_log10 of RealSize.t (* codegen *)
+ | Real_Math_sin of RealSize.t (* codegen *)
+ | Real_Math_sqrt of RealSize.t (* codegen *)
+ | Real_Math_tan of RealSize.t (* codegen *)
+ | Real_abs of RealSize.t (* codegen *)
+ | Real_add of RealSize.t (* codegen *)
+ | Real_div of RealSize.t (* codegen *)
+ | Real_equal of RealSize.t (* codegen *)
+ | Real_ge of RealSize.t (* codegen *)
+ | Real_gt of RealSize.t (* codegen *)
+ | Real_ldexp of RealSize.t (* codegen *)
+ | Real_le of RealSize.t (* codegen *)
+ | Real_lt of RealSize.t (* codegen *)
+ | Real_mul of RealSize.t (* codegen *)
+ | Real_muladd of RealSize.t (* codegen *)
+ | Real_mulsub of RealSize.t (* codegen *)
+ | Real_neg of RealSize.t (* codegen *)
+ | Real_qequal of RealSize.t (* codegen *)
+ | Real_round of RealSize.t (* codegen *)
+ | Real_sub of RealSize.t (* codegen *)
+ | Real_toInt of RealSize.t (* codegen *)
+ | Ref_assign (* backend *)
+ | Ref_deref (* backend *)
+ | Ref_ref (* backend *)
+ | String_toWord8Vector (* ssa to rssa *)
+ | Thread_atomicBegin (* backend *)
+ | Thread_atomicEnd (* backend *)
+ | Thread_canHandle (* backend *)
+ | Thread_copy (* ssa to rssa *)
+ | Thread_copyCurrent (* ssa to rssa *)
+ | Thread_returnToC (* codegen *)
+ (* switchTo has to be a _prim because we have to know that it
+ * enters the runtime -- because everything must be saved
+ * on the stack.
+ *)
+ | Thread_switchTo (* ssa to rssa *)
+ | Vector_length (* ssa to rssa *)
+ | Vector_sub (* backend *)
+ | Weak_canGet (* ssa to rssa *)
+ | Weak_get (* ssa to rssa *)
+ | Weak_new (* ssa to rssa *)
+ | Word_add of WordSize.t (* codegen *)
+ | Word_addCheck of WordSize.t (* codegen *)
+ | Word_andb of WordSize.t (* codegen *)
+ | Word_arshift of WordSize.t (* codegen *)
+ | Word_div of WordSize.t (* codegen *)
+ | Word_ge of WordSize.t (* codegen *)
+ | Word_gt of WordSize.t (* codegen *)
+ | Word_le of WordSize.t (* codegen *)
+ | Word_lshift of WordSize.t (* codegen *)
+ | Word_lt of WordSize.t (* codegen *)
+ | Word_mod of WordSize.t (* codegen *)
+ | Word_mul of WordSize.t (* codegen *)
+ | Word_mulCheck of WordSize.t (* codegen *)
+ | Word_neg of WordSize.t (* codegen *)
+ | Word_notb of WordSize.t (* codegen *)
+ | Word_orb of WordSize.t (* codegen *)
+ | Word_rol of WordSize.t (* codegen *)
+ | Word_ror of WordSize.t (* codegen *)
+ | Word_rshift of WordSize.t (* codegen *)
+ | Word_sub of WordSize.t (* codegen *)
+ | Word_toInt of WordSize.t * IntSize.t (* codegen *)
+ | Word_toIntInf (* ssa to rssa *)
+ | Word_toIntX of WordSize.t * IntSize.t (* codegen *)
+ | Word_toWord of WordSize.t * WordSize.t (* codegen *)
+ | Word_toWordX of WordSize.t * WordSize.t (* codegen *)
+ | Word_xorb of WordSize.t (* codegen *)
+ | WordVector_toIntInf (* ssa to rssa *)
+ | Word8Array_subWord (* codegen *)
+ | Word8Array_updateWord (* codegen *)
+ | Word8Vector_subWord (* codegen *)
+ | Word8Vector_toString (* ssa to rssa *)
+ | World_save (* ssa to rssa *)
val equals: t * t -> bool = op =
val isCommutative =
- fn Int_add => true
- | Int_addCheck => true
- | Int_mul => true
- | Int_mulCheck => true
+ fn Int_add _ => true
+ | Int_addCheck _ => true
+ | Int_mul _ => true
+ | Int_mulCheck _ => true
| IntInf_equal => true
| MLton_eq => true
| MLton_equal => true
- | Real_add => true
- | Real_mul => true
- | Real_qequal => true
- | Word32_add => true
- | Word32_addCheck => true
- | Word32_andb => true
- | Word32_mul => true
- | Word32_mulCheck => true
- | Word32_orb => true
- | Word32_xorb => true
- | Word8_add => true
- | Word8_andb => true
- | Word8_mul => true
- | Word8_orb => true
- | Word8_xorb => true
+ | Real_add _ => true
+ | Real_mul _ => true
+ | Real_qequal _ => true
+ | Word_add _ => true
+ | Word_addCheck _ => true
+ | Word_andb _ => true
+ | Word_mul _ => true
+ | Word_mulCheck _ => true
+ | Word_orb _ => true
+ | Word_xorb _ => true
| _ => false
val mayOverflow =
- fn Int_addCheck => true
- | Int_mulCheck => true
- | Int_negCheck => true
- | Int_subCheck => true
- | Word32_addCheck => true
- | Word32_mulCheck => true
+ fn Int_addCheck _ => true
+ | Int_mulCheck _ => true
+ | Int_negCheck _ => true
+ | Int_subCheck _ => true
+ | Word_addCheck _ => true
+ | Word_mulCheck _ => true
| _ => false
val mayRaise = mayOverflow
datatype z = datatype Kind.t
-
(* The values of these strings are important since they are referred to
* in the basis library code. See basis-library/misc/primitive.sml.
*)
+ fun ints (s: IntSize.t) =
+ List.map
+ ([(Int_add, Functional, "add"),
+ (Int_addCheck, SideEffect, "addCheck"),
+ (Int_ge, Functional, "ge"),
+ (Int_gt, Functional, "gt"),
+ (Int_le, Functional, "le"),
+ (Int_lt, Functional, "lt"),
+ (Int_mul, Functional, "mul"),
+ (Int_mulCheck, SideEffect, "mulCheck"),
+ (Int_neg, Functional, "neg"),
+ (Int_negCheck, SideEffect, "negCheck"),
+ (Int_quot, Functional, "quot"),
+ (Int_rem, Functional, "rem"),
+ (Int_sub, Functional, "sub"),
+ (Int_subCheck, SideEffect, "subCheck")],
+ fn (makeName, kind, str) =>
+ (makeName s, kind, concat ["Int", IntSize.toString s, "_", str]))
+
+ fun reals (s: RealSize.t) =
+ List.map
+ ([(Real_Math_acos, Functional, "Math_acos"),
+ (Real_Math_asin, Functional, "Math_asin"),
+ (Real_Math_atan, Functional, "Math_atan"),
+ (Real_Math_atan2, Functional, "Math_atan2"),
+ (Real_Math_cos, Functional, "Math_cos"),
+ (Real_Math_exp, Functional, "Math_exp"),
+ (Real_Math_ln, Functional, "Math_ln"),
+ (Real_Math_log10, Functional, "Math_log10"),
+ (Real_Math_sin, Functional, "Math_sin"),
+ (Real_Math_sqrt, Functional, "Math_sqrt"),
+ (Real_Math_tan, Functional, "Math_tan"),
+ (Real_abs, Functional, "abs"),
+ (Real_add, Functional, "add"),
+ (Real_div, Functional, "div"),
+ (Real_equal, Functional, "equal"),
+ (Real_ge, Functional, "ge"),
+ (Real_gt, Functional, "gt"),
+ (Real_ldexp, Functional, "ldexp"),
+ (Real_le, Functional, "le"),
+ (Real_lt, Functional, "lt"),
+ (Real_mul, Functional, "mul"),
+ (Real_muladd, Functional, "muladd"),
+ (Real_mulsub, Functional, "mulsub"),
+ (Real_neg, Functional, "neg"),
+ (Real_qequal, Functional, "qequal"),
+ (Real_round, Functional, "round"),
+ (Real_sub, Functional, "sub"),
+ (Real_toInt, Functional, "toInt")],
+ fn (makeName, kind, str) =>
+ (makeName s, kind, concat ["Real", RealSize.toString s, "_", str]))
+
+ fun words (s: WordSize.t) =
+ List.map
+ ([(Word_add, Functional, "add"),
+ (Word_addCheck, SideEffect, "addCheck"),
+ (Word_andb, Functional, "andb"),
+ (Word_arshift, Functional, "arshift"),
+ (Word_div, Functional, "div"),
+ (Word_ge, Functional, "ge"),
+ (Word_gt, Functional, "gt"),
+ (Word_le, Functional, "le"),
+ (Word_lshift, Functional, "lshift"),
+ (Word_lt, Functional, "lt"),
+ (Word_mod, Functional, "mod"),
+ (Word_mul, Functional, "mul"),
+ (Word_mulCheck, SideEffect, "mulCheck"),
+ (Word_neg, Functional, "neg"),
+ (Word_notb, Functional, "notb"),
+ (Word_orb, Functional, "orb"),
+ (Word_rol, Functional, "rol"),
+ (Word_ror, Functional, "ror"),
+ (Word_rshift, Functional, "rshift"),
+ (Word_sub, Functional, "sub"),
+ (Word_xorb, Functional, "xorb")],
+ fn (makeName, kind, str) =>
+ (makeName s, kind, concat ["Word", WordSize.toString s, "_", str]))
+
val strings =
[
(Array_array, Moveable, "Array_array"),
(Array_array0Const, Moveable, "Array_array0Const"),
(Array_length, Functional, "Array_length"),
(Array_sub, DependsOnState, "Array_sub"),
+ (Array_toVector, DependsOnState, "Array_toVector"),
(Array_update, SideEffect, "Array_update"),
(Byte_byteToChar, Functional, "Byte_byteToChar"),
(Byte_charToByte, Functional, "Byte_charToByte"),
@@ -289,8 +361,6 @@
(IntInf_arshift, Functional, "IntInf_arshift"),
(IntInf_compare, Functional, "IntInf_compare"),
(IntInf_equal, Functional, "IntInf_equal"),
- (IntInf_fromVector, Functional, "IntInf_fromVector"),
- (IntInf_fromWord, Functional, "IntInf_fromWord"),
(IntInf_gcd, Functional, "IntInf_gcd"),
(IntInf_lshift, Functional, "IntInf_lshift"),
(IntInf_mul, Functional, "IntInf_mul"),
@@ -304,22 +374,6 @@
(IntInf_toVector, Functional, "IntInf_toVector"),
(IntInf_toWord, Functional, "IntInf_toWord"),
(IntInf_xorb, Functional, "IntInf_xorb"),
- (Int_add, Functional, "Int_add"),
- (Int_addCheck, SideEffect, "Int_addCheck"),
- (Int_ge, Functional, "Int_ge"),
- (Int_geu, Functional, "Int_geu"),
- (Int_gt, Functional, "Int_gt"),
- (Int_gtu, Functional, "Int_gtu"),
- (Int_le, Functional, "Int_le"),
- (Int_lt, Functional, "Int_lt"),
- (Int_mul, Functional, "Int_mul"),
- (Int_mulCheck, SideEffect, "Int_mulCheck"),
- (Int_neg, Functional, "Int_neg"),
- (Int_negCheck, SideEffect, "Int_negCheck"),
- (Int_quot, Functional, "Int_quot"),
- (Int_rem, Functional, "Int_rem"),
- (Int_sub, Functional, "Int_sub"),
- (Int_subCheck, SideEffect, "Int_subCheck"),
(MLton_bogus, Functional, "MLton_bogus"),
(MLton_bug, SideEffect, "MLton_bug"),
(MLton_deserialize, Moveable, "MLton_deserialize"),
@@ -332,46 +386,9 @@
(MLton_serialize, DependsOnState, "MLton_serialize"),
(MLton_size, DependsOnState, "MLton_size"),
(MLton_touch, SideEffect, "MLton_touch"),
- (Real_Math_acos, Functional, "Real_Math_acos"),
- (Real_Math_asin, Functional, "Real_Math_asin"),
- (Real_Math_atan, Functional, "Real_Math_atan"),
- (Real_Math_atan2, Functional, "Real_Math_atan2"),
- (Real_Math_cos, Functional, "Real_Math_cos"),
- (Real_Math_cosh, Functional, "Real_Math_cosh"),
- (Real_Math_exp, Functional, "Real_Math_exp"),
- (Real_Math_ln, Functional, "Real_Math_ln"),
- (Real_Math_log10, Functional, "Real_Math_log10"),
- (Real_Math_pow, Functional, "Real_Math_pow"),
- (Real_Math_sin, Functional, "Real_Math_sin"),
- (Real_Math_sinh, Functional, "Real_Math_sinh"),
- (Real_Math_sqrt, Functional, "Real_Math_sqrt"),
- (Real_Math_tan, Functional, "Real_Math_tan"),
- (Real_Math_tanh, Functional, "Real_Math_tanh"),
- (Real_abs, Functional, "Real_abs"),
- (Real_add, Functional, "Real_add"),
- (Real_copysign, Functional, "Real_copysign"),
- (Real_div, Functional, "Real_div"),
- (Real_equal, Functional, "Real_equal"),
- (Real_frexp, SideEffect, "Real_frexp"),
- (Real_fromInt, Functional, "Real_fromInt"),
- (Real_ge, Functional, "Real_ge"),
- (Real_gt, Functional, "Real_gt"),
- (Real_ldexp, Functional, "Real_ldexp"),
- (Real_le, Functional, "Real_le"),
- (Real_lt, Functional, "Real_lt"),
- (Real_modf, SideEffect, "Real_modf"),
- (Real_mul, Functional, "Real_mul"),
- (Real_muladd, Functional, "Real_muladd"),
- (Real_mulsub, Functional, "Real_mulsub"),
- (Real_neg, Functional, "Real_neg"),
- (Real_qequal, Functional, "Real_qequal"),
- (Real_round, Functional, "Real_round"),
- (Real_sub, Functional, "Real_sub"),
- (Real_toInt, Functional, "Real_toInt"),
(Ref_assign, SideEffect, "Ref_assign"),
(Ref_deref, DependsOnState, "Ref_deref"),
(Ref_ref, Moveable, "Ref_ref"),
- (String_fromWord8Vector, Functional, "String_fromWord8Vector"),
(String_toWord8Vector, Functional, "String_toWord8Vector"),
(Thread_atomicBegin, SideEffect, "Thread_atomicBegin"),
(Thread_atomicEnd, SideEffect, "Thread_atomicEnd"),
@@ -380,65 +397,50 @@
(Thread_copyCurrent, SideEffect, "Thread_copyCurrent"),
(Thread_returnToC, SideEffect, "Thread_returnToC"),
(Thread_switchTo, SideEffect, "Thread_switchTo"),
- (Vector_fromArray, DependsOnState, "Vector_fromArray"),
(Vector_length, Functional, "Vector_length"),
(Vector_sub, Functional, "Vector_sub"),
(Weak_canGet, DependsOnState, "Weak_canGet"),
(Weak_get, DependsOnState, "Weak_get"),
(Weak_new, Moveable, "Weak_new"),
- (Word32_add, Functional, "Word32_add"),
- (Word32_addCheck, SideEffect, "Word32_addCheck"),
- (Word32_andb, Functional, "Word32_andb"),
- (Word32_arshift, Functional, "Word32_arshift"),
- (Word32_div, Functional, "Word32_div"),
- (Word32_fromInt, Functional, "Word32_fromInt"),
- (Word32_ge, Functional, "Word32_ge"),
- (Word32_gt, Functional, "Word32_gt"),
- (Word32_le, Functional, "Word32_le"),
- (Word32_lshift, Functional, "Word32_lshift"),
- (Word32_lt, Functional, "Word32_lt"),
- (Word32_mod, Functional, "Word32_mod"),
- (Word32_mul, Functional, "Word32_mul"),
- (Word32_mulCheck, SideEffect, "Word32_mulCheck"),
- (Word32_neg, Functional, "Word32_neg"),
- (Word32_notb, Functional, "Word32_notb"),
- (Word32_orb, Functional, "Word32_orb"),
- (Word32_rol, Functional, "Word32_rol"),
- (Word32_ror, Functional, "Word32_ror"),
- (Word32_rshift, Functional, "Word32_rshift"),
- (Word32_sub, Functional, "Word32_sub"),
- (Word32_toIntX, Functional, "Word32_toIntX"),
- (Word32_xorb, Functional, "Word32_xorb"),
+ (Word_toIntInf, Functional, "Word_toIntInf"),
+ (WordVector_toIntInf, Functional, "WordVector_toIntInf"),
(Word8Array_subWord, DependsOnState, "Word8Array_subWord"),
(Word8Array_updateWord, SideEffect, "Word8Array_updateWord"),
(Word8Vector_subWord, Functional, "Word8Vector_subWord"),
- (Word8_add, Functional, "Word8_add"),
- (Word8_andb, Functional, "Word8_andb"),
- (Word8_arshift, Functional, "Word8_arshift"),
- (Word8_div, Functional, "Word8_div"),
- (Word8_fromInt, Functional, "Word8_fromInt"),
- (Word8_fromLargeWord, Functional, "Word8_fromLargeWord"),
- (Word8_ge, Functional, "Word8_ge"),
- (Word8_gt, Functional, "Word8_gt"),
- (Word8_le, Functional, "Word8_le"),
- (Word8_lshift, Functional, "Word8_lshift"),
- (Word8_lt, Functional, "Word8_lt"),
- (Word8_mod, Functional, "Word8_mod"),
- (Word8_mul, Functional, "Word8_mul"),
- (Word8_neg, Functional, "Word8_neg"),
- (Word8_notb, Functional, "Word8_notb"),
- (Word8_orb, Functional, "Word8_orb"),
- (Word8_rol, Functional, "Word8_rol"),
- (Word8_ror, Functional, "Word8_ror"),
- (Word8_rshift, Functional, "Word8_rshift"),
- (Word8_sub, Functional, "Word8_sub"),
- (Word8_toInt, Functional, "Word8_toInt"),
- (Word8_toIntX, Functional, "Word8_toIntX"),
- (Word8_toLargeWord, Functional, "Word8_toLargeWord"),
- (Word8_toLargeWordX, Functional, "Word8_toLargeWordX"),
- (Word8_xorb, Functional, "Word8_xorb"),
+ (Word8Vector_toString, Functional, "Word8Vector_toString"),
(World_save, SideEffect, "World_save")]
-
+ @ List.concat [List.concatMap (IntSize.all, ints),
+ List.concatMap (RealSize.all, reals),
+ List.concatMap (WordSize.all, words)]
+ @ let
+ val int = ("Int", IntSize.all, IntSize.toString)
+ val real = ("Real", RealSize.all, RealSize.toString)
+ val word = ("Word", WordSize.all, WordSize.toString)
+ local
+ fun coerces' suf (name,
+ (n, sizes, sizeToString),
+ (n', sizes', sizeToString')) =
+ List.fold
+ (sizes, [], fn (s, ac) =>
+ List.fold
+ (sizes', ac, fn (s', ac) =>
+ (name (s, s'), Functional,
+ concat [n, sizeToString s, "_to", n', sizeToString' s',
+ suf])
+ :: ac))
+ in
+ val coerces = fn z => coerces' "" z
+ val coercesX = fn z => coerces' "X" z
+ end
+ in
+ List.concat [coerces (Int_toReal, int, real),
+ coerces (Int_toWord, int, word),
+ coerces (Word_toInt, word, int),
+ coercesX (Word_toIntX, word, int),
+ coerces (Word_toWord, word, word),
+ coercesX (Word_toWordX, word, word)]
+ end
+
fun toString n =
case n of
BuildConstant s => s
@@ -532,42 +534,46 @@
| _ => (case List.peek (Name.strings, fn (n', _, _) => n = n') of
NONE => Error.bug "strange name"
| SOME (_, k, _) => k)
- in new (n, k, s)
+ in
+ new (n, k, s)
end
- val tuple = tuple o Vector.fromList
+ val tuple = tuple o Vector.fromList
in
- val array = new (Name.Array_array, make1 (fn a => int --> array a))
- val assign = new (Name.Ref_assign, make1 (fn a => tuple [reff a, a] --> unit))
+ val array = new (Name.Array_array, make1 (fn a => int I32 --> array a))
+ val assign =
+ new (Name.Ref_assign, make1 (fn a => tuple [reff a, a] --> unit))
val bogus = new (Name.MLton_bogus, make1 (fn a => a))
- val bug = new (Name.MLton_bug, make0 (string --> unit))
+ val bug = new (Name.MLton_bug, make0 (word8Vector --> unit))
val deref = new (Name.Ref_deref, make1 (fn a => reff a --> a))
val deserialize =
- new (Name.MLton_deserialize, make1 (fn a => vector word8 --> a))
+ new (Name.MLton_deserialize, make1 (fn a => vector (word W8) --> a))
val eq = new (Name.MLton_eq, makeEqual1 (fn a => tuple [a, a] --> bool))
val equal = new (Name.MLton_equal, makeEqual1 (fn a => tuple [a, a] --> bool))
- val gcCollect = new (Name.GC_collect, make0 (tuple [word, bool] --> unit))
+ val gcCollect = new (Name.GC_collect, make0 (tuple [word W32, bool] --> unit))
val reff = new (Name.Ref_ref, make1 (fn a => a --> reff a))
- val serialize = new (Name.MLton_serialize, make1 (fn a => a --> vector word8))
- val vectorLength = new (Name.Vector_length, make1 (fn a => vector a --> int))
+ val serialize = new (Name.MLton_serialize,
+ make1 (fn a => a --> vector (word W8)))
+ val vectorLength =
+ new (Name.Vector_length, make1 (fn a => vector a --> int I32))
val vectorSub =
- new (Name.Vector_sub, make1 (fn a => tuple [vector a, int] --> a))
+ new (Name.Vector_sub, make1 (fn a => tuple [vector a, int I32] --> a))
fun new0 (name, ty) = new (name, make0 ty)
- val intNeg = new0 (Name.Int_neg, int --> int)
- val intNegCheck = new0 (Name.Int_negCheck, int --> int)
+ fun intNeg s = new0 (Name.Int_neg s, int s --> int s)
+ fun intNegCheck s = new0 (Name.Int_negCheck s, int s --> int s)
val intInfNeg =
- new0 (Name.IntInf_neg, tuple [intInf, word] --> intInf)
+ new0 (Name.IntInf_neg, tuple [intInf, word W32] --> intInf)
val intInfNotb =
- new0 (Name.IntInf_notb, tuple [intInf, word] --> intInf)
+ new0 (Name.IntInf_notb, tuple [intInf, word W32] --> intInf)
val intInfEqual = new0 (Name.IntInf_equal, tuple [intInf, intInf] --> bool)
- val word8Neg = new0 (Name.Word8_neg, word8 --> word8)
- val word8Notb = new0 (Name.Word8_notb, word8 --> word8)
- val word32Notb = new0 (Name.Word32_notb, word --> word)
- val word32Neg = new0 (Name.Word32_neg, word --> word)
+
+ fun wordNotb (s: WordSize.t) = new0 (Name.Word_notb s, word s --> word s)
+ fun wordNeg (s: WordSize.t) = new0 (Name.Word_neg s, word s --> word s)
local
- fun make n = new0 (n, tuple [int, int] --> int)
+ fun make n =
+ IntSize.memoize (fn s => new0 (n s, tuple [int s, int s] --> int s))
in
val intAdd = make Name.Int_add
val intAddCheck = make Name.Int_addCheck
@@ -578,25 +584,46 @@
end
local
- fun make n = new0 (n, tuple [word, word] --> word)
+ fun make n =
+ WordSize.memoize
+ (fn s => new0 (n s, tuple [word s, word s] --> word s))
in
- val word32Add = make Name.Word32_add
- val word32AddCheck = make Name.Word32_addCheck
- val word32Andb = make Name.Word32_andb
- val word32Mul = make Name.Word32_mul
- val word32MulCheck = make Name.Word32_mulCheck
- val word32Rshift = make Name.Word32_rshift
- val word32Sub = make Name.Word32_sub
+ val wordAdd = make Name.Word_add
+ val wordAddCheck = make Name.Word_addCheck
+ val wordAndb = make Name.Word_andb
+ val wordMul = make Name.Word_mul
+ val wordMulCheck = make Name.Word_mulCheck
+ val wordRshift = make Name.Word_rshift
+ val wordSub = make Name.Word_sub
end
local
- fun make n = new0 (n, tuple [word, word] --> bool)
+ fun make n =
+ WordSize.memoize
+ (fn s => new0 (n s, tuple [word s, word s] --> bool))
in
- val word32Gt = make Name.Word32_gt
+ val wordGe = make Name.Word_ge
+ val wordGt = make Name.Word_gt
+ val wordLe = make Name.Word_le
+ val wordLt = make Name.Word_lt
end
- val word32FromInt = new0 (Name.Word32_fromInt, int --> word)
- val word32ToIntX = new0 (Name.Word32_toIntX, word --> int)
+ local
+ fun make (name, (ty, memo), (ty', memo')) =
+ let
+ val f =
+ memo (fn s => memo' (fn s' => new0 (name (s, s'),
+ ty s --> ty' s')))
+ in
+ fn (s, s') => f s s'
+ end
+ val int = (int, IntSize.memoize)
+ val word = (word, WordSize.memoize)
+ in
+ val intToWord = make (Name.Int_toWord, int, word)
+ val wordToInt = make (Name.Word_toInt, word, int)
+ val wordToIntX = make (Name.Word_toIntX, word, int)
+ end
fun ffi (name: string, s: Scheme.t) =
new (Name.FFI name, s)
@@ -639,6 +666,14 @@
; error)
else
let
+ val con = fn (c, ts) =>
+ let
+ val c = if Tycon.equals (c, Tycon.char)
+ then Tycon.word W8
+ else c
+ in
+ con (c, ts)
+ end
val env = Vector.zip (tyvars, targs)
fun var a =
case Vector.peek (env, fn (a', _) => Tyvar.equals (a, a')) of
@@ -691,6 +726,7 @@
Array_array => one (dearray result)
| Array_array0Const => one (dearray result)
| Array_sub => one result
+ | Array_toVector => one (dearray (arg 0))
| Array_update => one (arg 2)
| Array_length => one (dearray (arg 0))
| Exn_extra => one result
@@ -706,7 +742,6 @@
| Ref_assign => one (arg 1)
| Ref_deref => one result
| Ref_ref => one (arg 0)
- | Vector_fromArray => one (dearray (arg 0))
| Vector_length => one (devector (arg 0))
| Vector_sub => one result
| Weak_canGet => one (deweak (arg 0))
@@ -721,14 +756,14 @@
struct
datatype 'a t =
Con of {con: Con.t, hasArg: bool}
- | Const of Const.Node.t
+ | Const of Const.t
| Var of 'a
fun layout layoutX =
fn Con {con, hasArg} =>
Layout.record [("con", Con.layout con),
("hasArg", Bool.layout hasArg)]
- | Const c => Const.Node.layout c
+ | Const c => Const.layout c
| Var x => layoutX x
end
@@ -784,139 +819,114 @@
* A = B --> false
* A x = B y --> false
*)
-
+
fun 'a apply (p, args, varEquals) =
let
datatype z = datatype Name.t
- datatype z = datatype Const.Node.t
+ datatype z = datatype Const.t
val bool = ApplyResult.Bool
- val char = ApplyResult.Const o Const.fromChar
- val int = ApplyResult.Const o Const.fromInt
- val intInf = ApplyResult.Const o Const.fromIntInf
+ val int = ApplyResult.Const o Const.int
+ val intInf = ApplyResult.Const o Const.intInf
val intInfConst = intInf o IntInf.fromInt
- val string = ApplyResult.Const o Const.fromString
- val word = ApplyResult.Const o Const.fromWord
- val word32 = word
- val word8 = ApplyResult.Const o Const.fromWord8
+ fun word (w: WordX.t): 'a ApplyResult.t =
+ ApplyResult.Const (Const.word w)
+ val word8Vector = ApplyResult.Const o Const.word8Vector
val t = ApplyResult.truee
val f = ApplyResult.falsee
local
fun make from (f, c1, c2) = from (f (c1, c2))
in
- fun io z = make int z
- val wo = make word
fun pred z = make bool z
val iio = make intInf
end
- fun iu (f, i1, i2) = bool (f (Word.fromInt i1, Word.fromInt i2))
- fun w8w (f, w8: Word.t, w: Word.t) = word8 (f (Word8.fromWord w8, w))
- fun w8p (p, w1, w2) = bool (p (Word8.fromWord w1, Word8.fromWord w2))
- fun w8o (f, w1, w2) = word8 (f (Word8.fromWord w1, Word8.fromWord w2))
+ fun io (f: IntX.t * IntX.t -> IntX.t, i, i') =
+ int (f (i, i'))
+ fun wcheck (f: IntInf.t * IntInf.t -> IntInf.t,
+ w: WordX.t,
+ w': WordX.t,
+ s: WordSize.t) =
+ let
+ val x = f (WordX.toIntInf w, WordX.toIntInf w')
+ val x' = IntInf.mod (x, Int.toIntInf (WordSize.size s))
+ in
+ if x = x'
+ then word (WordX.fromLargeInt (x, s))
+ else ApplyResult.Overflow
+ end
val eq =
- fn (Char c1, Char c2) => bool (Char.equals (c1, c2))
- | (Int i1, Int i2) => bool (Int.equals (i1, i2))
- | (Word w1, Word w2) => bool (Word.equals (w1, w2))
+ fn (Int i1, Int i2) => bool (IntX.equals (i1, i2))
+ | (Word w1, Word w2) => bool (WordX.equals (w1, w2))
| _ => ApplyResult.Unknown
val equal =
- fn (Char c1, Char c2) => bool (Char.equals (c1, c2))
- | (Int i1, Int i2) => bool (Int.equals (i1, i2))
- | (IntInf i1, IntInf i2) => bool (IntInf.equals (i1, i2))
- | (String s1, String s2) => bool (String.equals (s1, s2))
- | (Word w1, Word w2) => bool (Word.equals (w1, w2))
+ fn (Int i1, Int i2) => bool (IntX.equals (i1, i2))
+ | (Word w1, Word w2) => bool (WordX.equals (w1, w2))
+ | (Word8Vector v1, Word8Vector v2) => bool (v1 = v2)
| _ => ApplyResult.Unknown
- fun allConsts (cs: Const.Node.t list) =
+ fun allConsts (cs: Const.t list) =
(case (name p, cs) of
- (Byte_byteToChar, [Word w]) => char (Word.toChar w)
- | (Byte_charToByte, [Char c]) => word8 (Word8.fromChar c)
- | (Char_lt, [Char c1, Char c2]) => pred (Char.<, c1, c2)
- | (Char_le, [Char c1, Char c2]) => pred (Char.<=, c1, c2)
- | (Char_gt, [Char c1, Char c2]) => pred (Char.>, c1, c2)
- | (Char_ge, [Char c1, Char c2]) => pred (Char.>=, c1, c2)
- | (Char_chr, [Int i]) => char (Char.fromInt i)
- | (Char_ord, [Char c]) => int (Char.toInt c)
- | (Int_add, [Int i1, Int i2]) => io (Int.+, i1, i2)
- | (Int_addCheck, [Int i1, Int i2]) => io (Int.+, i1, i2)
- | (Int_mul, [Int i1, Int i2]) => io (Int.*, i1, i2)
- | (Int_mulCheck, [Int i1, Int i2]) => io (Int.*, i1, i2)
- | (Int_sub, [Int i1, Int i2]) => io (Int.-, i1, i2)
- | (Int_subCheck, [Int i1, Int i2]) => io (Int.-, i1, i2)
- | (Int_lt, [Int i1, Int i2]) => pred (Int.<, i1, i2)
- | (Int_le, [Int i1, Int i2]) => pred (Int.<=, i1, i2)
- | (Int_gt, [Int i1, Int i2]) => pred (Int.>, i1, i2)
- | (Int_ge, [Int i1, Int i2]) => pred (Int.>=, i1, i2)
- | (Int_geu, [Int i1, Int i2]) => iu (Word.>=, i1, i2)
- | (Int_gtu, [Int i1, Int i2]) => iu (Word.>, i1, i2)
- | (Int_neg, [Int i]) => int (~ i)
- | (Int_negCheck, [Int i]) => int (~ i)
- | (Int_quot, [Int i1, Int i2]) => io (Int.quot, i1, i2)
- | (Int_rem, [Int i1, Int i2]) => io (Int.rem, i1, i2)
+ (Int_add _, [Int i1, Int i2]) => io (IntX.+, i1, i2)
+ | (Int_addCheck _, [Int i1, Int i2]) => io (IntX.+, i1, i2)
+ | (Int_ge s, [Int i1, Int i2]) => pred (IntX.>=, i1, i2)
+ | (Int_gt s, [Int i1, Int i2]) => pred (IntX.>, i1, i2)
+ | (Int_le s, [Int i1, Int i2]) => pred (IntX.<=, i1, i2)
+ | (Int_lt s, [Int i1, Int i2]) => pred (IntX.<, i1, i2)
+ | (Int_mul _, [Int i1, Int i2]) => io (IntX.*, i1, i2)
+ | (Int_mulCheck _, [Int i1, Int i2]) => io (IntX.*, i1, i2)
+ | (Int_neg _, [Int i]) => int (IntX.~ i)
+ | (Int_negCheck _, [Int i]) => int (IntX.~ i)
+ | (Int_quot _, [Int i1, Int i2]) => io (IntX.quot, i1, i2)
+ | (Int_rem _, [Int i1, Int i2]) => io (IntX.rem, i1, i2)
+ | (Int_sub _, [Int i1, Int i2]) => io (IntX.-, i1, i2)
+ | (Int_subCheck _, [Int i1, Int i2]) => io (IntX.-, i1, i2)
+ | (Int_toWord (_, s), [Int i]) =>
+ word (WordX.fromLargeInt (IntX.toIntInf i, s))
| (IntInf_compare, [IntInf i1, IntInf i2]) =>
- int (case IntInf.compare (i1, i2) of
- Relation.LESS => ~1
- | Relation.EQUAL => 0
- | Relation.GREATER => 1)
+ int (IntX.make
+ (IntInf.fromInt (case IntInf.compare (i1, i2) of
+ Relation.LESS => ~1
+ | Relation.EQUAL => 0
+ | Relation.GREATER => 1),
+ IntSize.default))
| (IntInf_equal, [IntInf i1, IntInf i2]) =>
bool (IntInf.equals (i1, i2))
- | (IntInf_fromWord, [Word w]) =>
- (case SmallIntInf.fromWord w of
- NONE => ApplyResult.Unknown
- | SOME i => intInf i)
| (IntInf_toWord, [IntInf i]) =>
(case SmallIntInf.toWord i of
NONE => ApplyResult.Unknown
- | SOME w => word w)
+ | SOME w => word (WordX.make (w, WordSize.default)))
| (MLton_eq, [c1, c2]) => eq (c1, c2)
| (MLton_equal, [c1, c2]) => equal (c1, c2)
- | (Word8_mul, [Word w1, Word w2]) => w8o (Word8.*, w1, w2)
- | (Word8_add, [Word w1, Word w2]) => w8o (Word8.+, w1, w2)
- | (Word8_sub, [Word w1, Word w2]) => w8o (Word8.-, w1, w2)
- | (Word8_lt, [Word w1, Word w2]) => w8p (Word8.<, w1, w2)
- | (Word8_lshift, [Word w1, Word w2]) => w8w (Word8.<<, w1, w2)
- | (Word8_le, [Word w1, Word w2]) => w8p (Word8.<=, w1, w2)
- | (Word8_gt, [Word w1, Word w2]) => w8p (Word8.>, w1, w2)
- | (Word8_ge, [Word w1, Word w2]) => w8p (Word8.>=, w1, w2)
- | (Word8_rol, [Word w1, Word w2]) => w8w (Word8.rol, w1, w2)
- | (Word8_ror, [Word w1, Word w2]) => w8w (Word8.ror, w1, w2)
- | (Word8_rshift, [Word w1, Word w2]) => w8w (Word8.>>, w1, w2)
- | (Word8_andb, [Word w1, Word w2]) => w8o (Word8.andb, w1, w2)
- | (Word8_div, [Word w1, Word w2]) => w8o (Word8.div, w1, w2)
- | (Word8_fromInt, [Int i]) => word8 (Word8.fromInt i)
- | (Word8_fromLargeWord, [Word w]) => word8 (Word8.fromWord w)
- | (Word8_mod, [Word w1, Word w2]) => w8o (Word8.mod, w1, w2)
- | (Word8_notb, [Word w]) => word8 (Word8.notb (Word8.fromWord w))
- | (Word8_orb, [Word w1, Word w2]) => w8o (Word8.orb, w1, w2)
- | (Word8_toInt, [Word w]) => int (Word8.toInt (Word8.fromWord w))
- | (Word8_toIntX, [Word w]) => int (Word8.toIntX (Word8.fromWord w))
- | (Word8_toLargeWord, [Word w]) =>
- word (Word8.toWord (Word8.fromWord w))
- | (Word8_toLargeWordX, [Word w]) =>
- word (Word8.toWordX (Word8.fromWord w))
- | (Word8_xorb, [Word w1, Word w2]) => w8o (Word8.xorb, w1, w2)
- | (Word8_arshift, [Word w1, Word w2]) => w8w (Word8.~>>, w1, w2)
- | (Word32_add, [Word w1, Word w2]) => wo (Word.+, w1, w2)
- | (Word32_addCheck, [Word w1, Word w2]) =>
- wo (MLton.Word.addCheck, w1, w2)
- | (Word32_andb, [Word w1, Word w2]) => wo (Word.andb, w1, w2)
- | (Word32_arshift, [Word w1, Word w2]) => wo (Word.~>>, w1, w2)
- | (Word32_div, [Word w1, Word w2]) => wo (Word.div, w1, w2)
- | (Word32_fromInt, [Int i]) => word (Word.fromInt i)
- | (Word32_ge, [Word w1, Word w2]) => pred (Word.>=, w1, w2)
- | (Word32_gt, [Word w1, Word w2]) => pred (Word.>, w1, w2)
- | (Word32_le, [Word w1, Word w2]) => pred (Word.<=, w1, w2)
- | (Word32_lshift, [Word w1, Word w2]) => wo (Word.<<, w1, w2)
- | (Word32_lt, [Word w1, Word w2]) => pred (Word.<, w1, w2)
- | (Word32_mod, [Word w1, Word w2]) => wo (Word.mod, w1, w2)
- | (Word32_mul, [Word w1, Word w2]) => wo (Word.*, w1, w2)
- | (Word32_mulCheck, [Word w1, Word w2]) =>
- wo (MLton.Word.mulCheck, w1, w2)
- | (Word32_notb, [Word w]) => word (Word.notb w)
- | (Word32_orb, [Word w1, Word w2]) => wo (Word.orb, w1, w2)
- | (Word32_rol, [Word w1, Word w2]) => wo (Word.rol, w1, w2)
- | (Word32_ror, [Word w1, Word w2]) => wo (Word.ror, w1, w2)
- | (Word32_rshift, [Word w1, Word w2]) => wo (Word.>>, w1, w2)
- | (Word32_sub, [Word w1, Word w2]) => wo (Word.-, w1, w2)
- | (Word32_toIntX, [Word w]) => int (Word.toIntX w)
- | (Word32_xorb, [Word w1, Word w2]) => wo (Word.xorb, w1, w2)
+ | (Word_add _, [Word w1, Word w2]) => word (WordX.+ (w1, w2))
+ | (Word_addCheck s, [Word w1, Word w2]) =>
+ wcheck (IntInf.+, w1, w2, s)
+ | (Word_andb _, [Word w1, Word w2]) => word (WordX.andb (w1, w2))
+ | (Word_arshift _, [Word w1, Word w2]) => word (WordX.~>> (w1, w2))
+ | (Word_div _, [Word w1, Word w2]) => word (WordX.div (w1, w2))
+ | (Word_ge _, [Word w1, Word w2]) => bool (WordX.>= (w1, w2))
+ | (Word_gt _, [Word w1, Word w2]) => bool (WordX.> (w1, w2))
+ | (Word_le _, [Word w1, Word w2]) => bool (WordX.<= (w1, w2))
+ | (Word_lshift _, [Word w1, Word w2]) => word (WordX.<< (w1, w2))
+ | (Word_lt _, [Word w1, Word w2]) => bool (WordX.< (w1, w2))
+ | (Word_mod _, [Word w1, Word w2]) => word (WordX.mod (w1, w2))
+ | (Word_mul _, [Word w1, Word w2]) => word (WordX.* (w1, w2))
+ | (Word_mulCheck s, [Word w1, Word w2]) =>
+ wcheck (IntInf.*, w1, w2, s)
+ | (Word_notb _, [Word w]) => word (WordX.notb w)
+ | (Word_orb _, [Word w1, Word w2]) => word (WordX.orb (w1, w2))
+ | (Word_rol _, [Word w1, Word w2]) => word (WordX.rol (w1, w2))
+ | (Word_ror _, [Word w1, Word w2]) => word (WordX.ror (w1, w2))
+ | (Word_rshift _, [Word w1, Word w2]) => word (WordX.>> (w1, w2))
+ | (Word_sub _, [Word w1, Word w2]) => word (WordX.- (w1, w2))
+ | (Word_toInt (_, s), [Word w]) =>
+ int (IntX.make (WordX.toIntInf w, s))
+ | (Word_toIntInf, [Word w]) =>
+ (case SmallIntInf.fromWord (WordX.toWord w) of
+ NONE => ApplyResult.Unknown
+ | SOME i => intInf i)
+ | (Word_toIntX (_, s), [Word w]) =>
+ int (IntX.make (WordX.toIntInfX w, s))
+ | (Word_toWord (_, s), [Word w]) => word (WordX.resize (w, s))
+ | (Word_toWordX (_, s), [Word w]) => word (WordX.resizeX (w, s))
+ | (Word_xorb _, [Word w1, Word w2]) => word (WordX.xorb (w1, w2))
| _ => ApplyResult.Unknown)
handle Chr => ApplyResult.Unknown
| Div => ApplyResult.Unknown
@@ -925,13 +935,14 @@
fun someVars () =
let
datatype z = datatype ApplyResult.t
- fun add (x, i) = if i = 0 then Var x else Unknown
- fun mul (x, i, neg) =
- case i of
- 0 => int 0
- | 1 => Var x
- | ~1 => Apply (neg, [x])
- | _ => Unknown
+ fun add (x: 'a, i: IntX.t): 'a ApplyResult.t =
+ if IntX.isZero i then Var x else Unknown
+ fun mul (x: 'a, i: IntX.t, s: IntSize.t, neg) =
+ (case IntX.toInt i of
+ 0 => int (IntX.zero s)
+ | 1 => Var x
+ | ~1 => Apply (neg s, [x])
+ | _ => Unknown) handle Exn.Overflow => Unknown
val name = name p
fun varIntInf (x, i: IntInf.t, space, inOrder) =
let
@@ -983,151 +994,124 @@
end handle Exn.Overflow => Unknown
fun varWord (x, w, inOrder) =
let
- fun allOnes isWord8 = if isWord8 then 0wxFF else 0wxFFFFFFFF
- val max = allOnes
- fun zero isWord8 = if isWord8 then word8 0wx0 else word32 0wx0
- fun maxRes isWord8 =
- if isWord8 then word8 0wxFF else word32 0wxFFFFFFFF
- fun add () = if w = 0w0 then Var x else Unknown
- fun andb isWord8 =
- if w = 0w0
- then zero isWord8
- else if w = allOnes isWord8
+ val zero = word o WordX.zero
+ fun add s = if WordX.isZero w then Var x else Unknown
+ fun mul () =
+ if WordX.isZero w
+ then word w
+ else if WordX.isOne w
then Var x
else Unknown
- fun arshift isWord8 =
- if w = 0w0 then if inOrder then Var x else zero isWord8
- else if w = max isWord8
- then if inOrder then Unknown else maxRes isWord8
- else Unknown
- nonfix div
- fun div () = if inOrder andalso w = 0w1 then Var x else Unknown
- fun ge isWord8 =
- if inOrder
- then if w = 0w0 then t else Unknown
- else if w = max isWord8 then t else Unknown
- fun gt isWord8 =
- if inOrder
- then if w = max isWord8 then f else Unknown
- else if w = 0w0 then f else Unknown
- fun le isWord8 =
- if inOrder
- then if w = max isWord8 then t else Unknown
- else if w = 0w0 then t else Unknown
- fun lt isWord8 =
- if inOrder
- then if w = 0w0 then f else Unknown
- else if w = max isWord8 then f else Unknown
- nonfix mod
- fun mod isWord8 =
- if inOrder andalso w = 0w1 then zero isWord8 else Unknown
- fun mul isWord8 =
- case w of
- 0w0 => zero isWord8
- | 0w1 => Var x
- | _ => Unknown
- fun orb isWord8 =
- if w = 0w0
- then Var x
- else if w = allOnes isWord8
- then maxRes isWord8
- else Unknown
- fun ro isWord8 =
+ fun ro () =
if inOrder
then
- if 0w0 = Word.mod (w, if isWord8 then 0w8 else 0w32)
- then Var x
- else Unknown
+ let
+ val s = WordX.size w
+ in
+ if WordX.isZero
+ (WordX.mod
+ (w,
+ WordX.make
+ (Word.fromInt (WordSize.size s), s)))
+ then Var x
+ else Unknown
+ end
else
- if w = 0w0
- then zero isWord8
- else if w = allOnes isWord8
- then maxRes isWord8
- else Unknown
- fun shift isWord8 =
+ if WordX.isZero w orelse WordX.isAllOnes w
+ then word w
+ else Unknown
+ fun shift s =
if inOrder
- then if w = 0w0
+ then if WordX.isZero w
then Var x
- else if w >= (if isWord8 then 0w8 else 0w32)
- then zero isWord8
+ else if (WordX.>=
+ (w, WordX.make (Word.fromInt
+ (WordSize.size s),
+ WordSize.default)))
+ then zero s
else Unknown
- else if w = 0w0
- then zero isWord8
- else Unknown
- fun sub isWord8 =
- if w = 0w0
- then
- if inOrder
- then Var x
- else Apply (if isWord8
- then word8Neg
- else word32Neg,
- [x])
- else Unknown
- fun xorb isWord8 =
- if w = 0w0
- then Var x
- else if w = allOnes isWord8
- then Apply (if isWord8 then word8Notb
- else word32Notb,
- [x])
+ else if WordX.isZero w
+ then zero s
else Unknown
in
case name of
- Word8_add => add ()
- | Word32_add => add ()
- | Word32_addCheck => add ()
- | Word8_andb => andb true
- | Word32_andb => andb false
- | Word8_arshift => arshift true
- | Word32_arshift => arshift false
- | Word8_div => div ()
- | Word32_div => div ()
- | Word8_ge => ge true
- | Word32_ge => ge false
- | Word8_gt => gt true
- | Word32_gt => gt false
- | Word8_le => le true
- | Word32_le => le false
- | Word8_lshift => shift true
- | Word32_lshift => shift false
- | Word8_lt => lt true
- | Word32_lt => lt false
- | Word8_mod => mod true
- | Word32_mod => mod false
- | Word8_mul => mul true
- | Word32_mul => mul false
- | Word32_mulCheck => mul false
- | Word8_orb => orb true
- | Word32_orb => orb false
- | Word8_rol => ro true
- | Word32_rol => ro false
- | Word8_ror => ro true
- | Word32_ror => ro false
- | Word8_rshift => shift true
- | Word32_rshift => shift false
- | Word8_sub => sub true
- | Word32_sub => sub false
- | Word8_xorb => xorb true
- | Word32_xorb => xorb false
+ Word_add s => add s
+ | Word_addCheck s => add s
+ | Word_andb s =>
+ if WordX.isZero w
+ then zero s
+ else if WordX.isAllOnes w
+ then Var x
+ else Unknown
+ | Word_arshift s =>
+ if WordX.isZero w
+ then if inOrder then Var x else zero s
+ else if WordX.isAllOnes w
+ then if inOrder then Unknown else word w
+ else Unknown
+ | Word_div _ =>
+ if inOrder andalso WordX.isOne w then Var x else Unknown
+ | Word_ge _ =>
+ if inOrder
+ then if WordX.isZero w then t else Unknown
+ else if WordX.isMax w then t else Unknown
+ | Word_gt _ =>
+ if inOrder
+ then if WordX.isMax w then f else Unknown
+ else if WordX.isZero w then f else Unknown
+ | Word_le _ =>
+ if inOrder
+ then if WordX.isMax w then t else Unknown
+ else if WordX.isZero w then t else Unknown
+ | Word_lshift s => shift s
+ | Word_lt _ =>
+ if inOrder
+ then if WordX.isZero w then f else Unknown
+ else if WordX.isMax w then f else Unknown
+ | Word_mod s =>
+ if inOrder andalso WordX.isOne w
+ then zero s
+ else Unknown
+ | Word_mul _ => mul ()
+ | Word_mulCheck _ => mul ()
+ | Word_orb _ =>
+ if WordX.isZero w
+ then Var x
+ else if WordX.isAllOnes w
+ then word w
+ else Unknown
+ | Word_rol _ => ro ()
+ | Word_ror _ => ro ()
+ | Word_rshift s => shift s
+ | Word_sub s =>
+ if WordX.isZero w
+ then
+ if inOrder
+ then Var x
+ else Apply (wordNeg s, [x])
+ else Unknown
+ | Word_xorb s =>
+ if WordX.isZero w
+ then Var x
+ else if WordX.isAllOnes w
+ then Apply (wordNotb s, [x])
+ else Unknown
| _ => Unknown
end
- val minInt = ~0x80000000
- val maxInt = 0x7FFFFFFF
datatype z = datatype ApplyArg.t
in
case (name, args) of
(IntInf_toString, [Const (IntInf i), Const (Int base), _]) =>
let
val base =
- case base of
+ case IntX.toInt base of
2 => StringCvt.BIN
| 8 => StringCvt.OCT
| 10 => StringCvt.DEC
| 16 => StringCvt.HEX
| _ => Error.bug "strange base for IntInf_toString"
in
- string (IntInf.format (i, base))
+ word8Vector (Word8.stringToVector (IntInf.format (i, base)))
end
| (_, [Con {con = c, hasArg = h}, Con {con = c', hasArg = h'}]) =>
if name = MLton_equal orelse name = MLton_eq
@@ -1141,40 +1125,51 @@
| (_, [Const (Word i), Var x]) => varWord (x, i, false)
| (_, [Var x, Const (Int i)]) =>
(case name of
- Int_add => add (x, i)
- | Int_addCheck => add (x, i)
- | Int_ge => if i = minInt then t else Unknown
- | Int_geu => if i = 0 then t else Unknown
- | Int_gt => if i = maxInt then f else Unknown
- | Int_gtu => if i = ~1 then f else Unknown
- | Int_le => if i = maxInt then t else Unknown
- | Int_lt => if i = minInt then f else Unknown
- | Int_mul => mul (x, i, intNeg)
- | Int_mulCheck => mul (x, i, intNegCheck)
- | Int_quot => (case i of
- 1 => ApplyResult.Var x
- | ~1 => Apply (intNeg, [x])
- | _ => Unknown)
- | Int_rem => if i = ~1 orelse i = 1 then int 0 else Unknown
- | Int_sub => if i = 0 then ApplyResult.Var x else Unknown
- | Int_subCheck =>
- if i = 0 then ApplyResult.Var x else Unknown
+ Int_add s => add (x, i)
+ | Int_addCheck s => add (x, i)
+ | Int_ge _ => if IntX.isMin i then t else Unknown
+ | Int_gt _ => if IntX.isMax i then f else Unknown
+ | Int_le _ => if IntX.isMax i then t else Unknown
+ | Int_lt _ => if IntX.isMin i then f else Unknown
+ | Int_mul s => mul (x, i, s, intNeg)
+ | Int_mulCheck s => mul (x, i, s, intNegCheck)
+ | Int_quot s =>
+ if IntX.isNegOne i
+ then Apply (intNeg s, [x])
+ else if IntX.isOne i
+ then ApplyResult.Var x
+ else Unknown
+ | Int_rem s =>
+ if IntX.isNegOne i orelse IntX.isOne i
+ then int (IntX.zero s)
+ else Unknown
+ | Int_sub _ =>
+ if IntX.isZero i
+ then ApplyResult.Var x
+ else Unknown
+ | Int_subCheck _ =>
+ if IntX.isZero i
+ then ApplyResult.Var x
+ else Unknown
| _ => Unknown)
| (_, [Const (Int i), Var x]) =>
(case name of
- Int_add => add (x, i)
- | Int_addCheck => add (x, i)
- | Int_ge => if i = maxInt then t else Unknown
- | Int_geu => if i = ~1 then t else Unknown
- | Int_gt => if i = minInt then f else Unknown
- | Int_gtu => if i = 0 then f else Unknown
- | Int_le => if i = minInt then t else Unknown
- | Int_lt => if i = maxInt then f else Unknown
- | Int_mul => mul (x, i, intNeg)
- | Int_mulCheck => mul (x, i, intNegCheck)
- | Int_sub => if i = 0 then Apply (intNeg, [x]) else Unknown
- | Int_subCheck =>
- if i = 0 then Apply (intNegCheck, [x]) else Unknown
+ Int_add _ => add (x, i)
+ | Int_addCheck _ => add (x, i)
+ | Int_ge _ => if IntX.isMax i then t else Unknown
+ | Int_gt _ => if IntX.isMin i then f else Unknown
+ | Int_le _ => if IntX.isMin i then t else Unknown
+ | Int_lt _ => if IntX.isMax i then f else Unknown
+ | Int_mul s => mul (x, i, s, intNeg)
+ | Int_mulCheck s => mul (x, i, s, intNegCheck)
+ | Int_sub s =>
+ if IntX.isZero i
+ then Apply (intNeg s, [x])
+ else Unknown
+ | Int_subCheck s =>
+ if IntX.isZero i
+ then Apply (intNegCheck s, [x])
+ else Unknown
| _ => Unknown)
| (_, [Const (IntInf i1), Const (IntInf i2), _]) =>
(case name of
@@ -1190,8 +1185,8 @@
| _ => Unknown)
| (_, [Const (IntInf i1), Const (Word w2), _]) =>
(case name of
- IntInf_arshift => intInf (IntInf.~>> (i1, w2))
- | IntInf_lshift => intInf (IntInf.<< (i1, w2))
+ IntInf_arshift => intInf (IntInf.~>> (i1, WordX.toWord w2))
+ | IntInf_lshift => intInf (IntInf.<< (i1, WordX.toWord w2))
| _ => Unknown)
| (_, [Const (IntInf i1), _]) =>
(case name of
@@ -1202,15 +1197,19 @@
varIntInf (x, i, space, true)
| (_, [Const (IntInf i), Var x, Var space]) =>
varIntInf (x, i, space, false)
- | (_, [Var x, Const (Word 0wx0), _]) =>
- (let datatype z = datatype ApplyResult.t
- in
- case name of
- IntInf_arshift => Var x
- | IntInf_lshift => Var x
- | _ => Unknown
- end)
- | (_, [Var x, Var y, _]) =>
+ | (_, [Var x, Const (Word w), _]) =>
+ if WordX.isZero w
+ then
+ let
+ datatype z = datatype ApplyResult.t
+ in
+ case name of
+ IntInf_arshift => Var x
+ | IntInf_lshift => Var x
+ | _ => Unknown
+ end
+ else Unknown
+ | (_, [Var x, Var y, _]) =>
if varEquals (x, y)
then let datatype z = datatype ApplyResult.t
in
@@ -1230,50 +1229,36 @@
val t = ApplyResult.truee
val f = ApplyResult.falsee
datatype z = datatype ApplyResult.t
- in case name of
- Char_lt => f
- | Char_le => t
- | Char_gt => f
- | Char_ge => t
- | Int_ge => t
- | Int_geu => t
- | Int_gt => f
- | Int_gtu => f
- | Int_le => t
- | Int_lt => f
- | Int_quot => int 1
- | Int_rem => int 0
- | Int_sub => int 0
- | IntInf_compare => int 0
+ in
+ case name of
+ Int_ge _ => t
+ | Int_gt _ => f
+ | Int_le _ => t
+ | Int_lt _ => f
+ | Int_quot s => int (IntX.one s)
+ | Int_rem s => int (IntX.zero s)
+ | Int_sub s => int (IntX.zero s)
+ | IntInf_compare =>
+ int (IntX.zero IntSize.default)
| IntInf_equal => t
| MLton_eq => t
| MLton_equal => t
- | Real_lt => f
- | Real_le => t
- | Real_equal => t
- | Real_gt => f
- | Real_ge => t
- | Real_qequal => t
- | Word8_andb => Var x
- | Word8_div => word8 0w1
- | Word8_ge => t
- | Word8_gt => f
- | Word8_le => t
- | Word8_lt => f
- | Word8_mod => word8 0w0
- | Word8_orb => Var x
- | Word8_sub => word8 0w0
- | Word8_xorb => word8 0w0
- | Word32_andb => Var x
- | Word32_div => word 0w1
- | Word32_ge => t
- | Word32_gt => f
- | Word32_le => t
- | Word32_lt => f
- | Word32_mod => word 0w0
- | Word32_orb => Var x
- | Word32_sub => word 0w0
- | Word32_xorb => word 0w0
+ | Real_lt _ => f
+ | Real_le _ => t
+ | Real_equal _ => t
+ | Real_gt _ => f
+ | Real_ge _ => t
+ | Real_qequal _ => t
+ | Word_andb _ => Var x
+ | Word_div s => word (WordX.one s)
+ | Word_ge _ => t
+ | Word_gt _ => f
+ | Word_le _ => t
+ | Word_lt _ => f
+ | Word_mod s => word (WordX.zero s)
+ | Word_orb _ => Var x
+ | Word_sub s => word (WordX.zero s)
+ | Word_xorb s => word (WordX.zero s)
| _ => Unknown
end
else Unknown
@@ -1303,85 +1288,63 @@
| Char_ge => two ">="
| Char_chr => one "chr"
| Char_ord => one "ord"
- | Int_mul => two "*?"
- | Int_mulCheck => two "*"
- | Int_add => two "+?"
- | Int_addCheck => two "+"
- | Int_sub => two "-?"
- | Int_subCheck => two "-"
- | Int_lt => two "<"
- | Int_le => two "<="
- | Int_gt => two ">"
- | Int_ge => two ">="
- | Int_geu => two ">=u"
- | Int_gtu => two ">u"
- | Int_neg => one "-?"
- | Int_negCheck => one "-"
+ | Int_mul _ => two "*?"
+ | Int_mulCheck _ => two "*"
+ | Int_add _ => two "+?"
+ | Int_addCheck _ => two "+"
+ | Int_sub _ => two "-?"
+ | Int_subCheck _ => two "-"
+ | Int_lt _ => two "<"
+ | Int_le _ => two "<="
+ | Int_gt _ => two ">"
+ | Int_ge _ => two ">="
+ | Int_neg _ => one "-?"
+ | Int_negCheck _ => one "-"
| IntInf_equal => two "="
| MLton_eq => two "="
- | Real_Math_acos => one "acos"
- | Real_Math_asin => one "asin"
- | Real_Math_atan => one "atan"
- | Real_Math_cos => one "cos"
- | Real_Math_cosh => one "cosh"
- | Real_Math_exp => one "exp"
- | Real_Math_ln => one "ln"
- | Real_Math_log10 => one "log10"
- | Real_Math_pow => two "^"
- | Real_Math_sin => one "sin"
- | Real_Math_sinh => one "sinh"
- | Real_Math_sqrt => one "sqrt"
- | Real_Math_tan => one "tan"
- | Real_Math_tanh => one "tanh"
- | Real_mul => two "*"
- | Real_add => two "+"
- | Real_sub => two "-"
- | Real_div => two "/"
- | Real_lt => two "<"
- | Real_le => two "<="
- | Real_equal => two "=="
- | Real_gt => two ">"
- | Real_ge => two ">="
- | Real_qequal => two "?="
- | Real_neg => one "-"
+ | Real_Math_acos _ => one "acos"
+ | Real_Math_asin _ => one "asin"
+ | Real_Math_atan _ => one "atan"
+ | Real_Math_cos _ => one "cos"
+ | Real_Math_exp _ => one "exp"
+ | Real_Math_ln _ => one "ln"
+ | Real_Math_log10 _ => one "log10"
+ | Real_Math_sin _ => one "sin"
+ | Real_Math_sqrt _ => one "sqrt"
+ | Real_Math_tan _ => one "tan"
+ | Real_add _ => two "+"
+ | Real_div _ => two "/"
+ | Real_equal _ => two "=="
+ | Real_ge _ => two ">="
+ | Real_gt _ => two ">"
+ | Real_le _ => two "<="
+ | Real_lt _ => two "<"
+ | Real_mul _ => two "*"
+ | Real_neg _ => one "-"
+ | Real_qequal _ => two "?="
+ | Real_sub _ => two "-"
| Ref_assign => two ":="
| Ref_deref => one "!"
| Ref_ref => one "ref"
| Vector_length => one "length"
- | Word32_add => two "+"
- | Word32_addCheck => two "+c"
- | Word32_andb => two "&"
- | Word32_arshift => two "~>>"
- | Word32_ge => two ">="
- | Word32_gt => two ">"
- | Word32_le => two "<="
- | Word32_lshift => two "<<"
- | Word32_lt => two "<"
- | Word32_mul => two "*"
- | Word32_mulCheck => two "*c"
- | Word32_neg => one "-"
- | Word32_orb => two "|"
- | Word32_rol => two "rol"
- | Word32_ror => two "ror"
- | Word32_rshift => two ">>"
- | Word32_sub => two "-"
- | Word32_xorb => two "^"
- | Word8_add => two "+"
- | Word8_andb => two "&"
- | Word8_arshift => two "~>>"
- | Word8_ge => two ">="
- | Word8_gt => two ">"
- | Word8_le => two "<="
- | Word8_lshift => two "<<"
- | Word8_lt => two "<"
- | Word8_mul => two "*"
- | Word8_neg => one "-"
- | Word8_orb => two "|"
- | Word8_rol => two "rol"
- | Word8_ror => two "ror"
- | Word8_rshift => two ">>"
- | Word8_sub => two "-"
- | Word8_xorb => two "^"
+ | Word_add _ => two "+"
+ | Word_addCheck _ => two "+c"
+ | Word_andb _ => two "&"
+ | Word_arshift _ => two "~>>"
+ | Word_ge _ => two ">="
+ | Word_gt _ => two ">"
+ | Word_le _ => two "<="
+ | Word_lshift _ => two "<<"
+ | Word_lt _ => two "<"
+ | Word_mul _ => two "*"
+ | Word_mulCheck _ => two "*c"
+ | Word_neg _ => one "-"
+ | Word_orb _ => two "|"
+ | Word_rol _ => two "rol"
+ | Word_ror _ => two "ror"
+ | Word_rshift _ => two ">>"
+ | Word_sub _ => two "-"
+ | Word_xorb _ => two "^"
| _ => seq [layout p, str " ", Vector.layout layoutArg args]
end
1.39 +107 -128 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- prim.sig 20 May 2003 02:18:26 -0000 1.38
+++ prim.sig 23 Jun 2003 04:58:55 -0000 1.39
@@ -11,9 +11,15 @@
sig
structure Con: CON
structure Const: CONST
+ structure IntSize: INT_SIZE
+ structure RealSize: REAL_SIZE
structure Scheme: SCHEME
structure Type: TYPE
+ structure WordSize: WORD_SIZE
+ sharing IntSize = Const.IntX.IntSize = Type.Tycon.IntSize
+ sharing RealSize = Const.RealX.RealSize = Type.Tycon.RealSize
sharing Type = Scheme.Type
+ sharing WordSize = Const.WordX.WordSize = Type.Tycon.WordSize
end
signature PRIM =
@@ -27,6 +33,7 @@
| Array_array0Const (* constant propagation *)
| Array_length (* ssa to rssa *)
| Array_sub (* backend *)
+ | Array_toVector (* backend *)
| Array_update (* backend *)
| BuildConstant of string (* type inference *)
| Byte_byteToChar (* ssa to rssa *)
@@ -50,29 +57,27 @@
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
- | Int_add (* codegen *)
- | Int_addCheck (* codegen *)
- | Int_ge (* codegen *)
- | Int_geu (* codegen *)
- | Int_gt (* codegen *)
- | Int_gtu (* codegen *)
- | Int_le (* codegen *)
- | Int_lt (* codegen *)
- | Int_mul (* codegen *)
- | Int_mulCheck (* codegen *)
- | Int_neg (* codegen *)
- | Int_negCheck (* codegen *)
- | Int_quot (* codegen *)
- | Int_rem (* codegen *)
- | Int_sub (* codegen *)
- | Int_subCheck (* codegen *)
+ | Int_add of IntSize.t (* codegen *)
+ | Int_addCheck of IntSize.t (* codegen *)
+ | Int_ge of IntSize.t (* codegen *)
+ | Int_gt of IntSize.t (* codegen *)
+ | Int_le of IntSize.t (* codegen *)
+ | Int_lt of IntSize.t (* codegen *)
+ | Int_mul of IntSize.t (* codegen *)
+ | Int_mulCheck of IntSize.t (* codegen *)
+ | Int_neg of IntSize.t (* codegen *)
+ | Int_negCheck of IntSize.t (* codegen *)
+ | Int_quot of IntSize.t (* codegen *)
+ | Int_rem of IntSize.t (* codegen *)
+ | Int_sub of IntSize.t (* codegen *)
+ | Int_subCheck of IntSize.t (* codegen *)
+ | Int_toReal of IntSize.t * RealSize.t (* codegen *)
+ | Int_toWord of IntSize.t * WordSize.t (* codegen *)
| IntInf_add (* ssa to rssa *)
| IntInf_andb (* ssa to rssa *)
| IntInf_arshift (* ssa to rssa *)
| IntInf_compare (* ssa to rssa *)
| IntInf_equal (* ssa to rssa *)
- | IntInf_fromVector (* ssa to rssa *)
- | IntInf_fromWord (* ssa to rssa *)
| IntInf_gcd (* ssa to rssa *)
| IntInf_lshift (* ssa to rssa *)
| IntInf_mul (* ssa to rssa *)
@@ -87,9 +92,9 @@
| IntInf_toWord (* ssa to rssa *)
| IntInf_xorb (* ssa to rssa *)
| MLton_bogus (* ssa to rssa *)
- (* of type unit -> 'a.
- * Makes a bogus value of any type.
- *)
+ (* of type unit -> 'a.
+ * Makes a bogus value of any type.
+ *)
| MLton_bug (* ssa to rssa *)
| MLton_deserialize (* unused *)
| MLton_eq (* codegen *)
@@ -112,47 +117,38 @@
| MLton_serialize (* unused *)
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
- | Real_Math_acos (* codegen *)
- | Real_Math_asin (* codegen *)
- | Real_Math_atan (* codegen *)
- | Real_Math_atan2 (* codegen *)
- | Real_Math_cos (* codegen *)
- | Real_Math_cosh (* codegen *)
- | Real_Math_exp (* codegen *)
- | Real_Math_ln (* codegen *)
- | Real_Math_log10 (* codegen *)
- | Real_Math_pow (* codegen *)
- | Real_Math_sin (* codegen *)
- | Real_Math_sinh (* codegen *)
- | Real_Math_sqrt (* codegen *)
- | Real_Math_tan (* codegen *)
- | Real_Math_tanh (* codegen *)
- | Real_abs (* codegen *)
- | Real_add (* codegen *)
- | Real_copysign (* codegen *)
- | Real_div (* codegen *)
- | Real_equal (* codegen *)
- | Real_frexp (* ssa to rssa *)
- | Real_fromInt (* codegen *)
- | Real_ge (* codegen *)
- | Real_gt (* codegen *)
- | Real_ldexp (* codegen *)
- | Real_le (* codegen *)
- | Real_lt (* codegen *)
- | Real_modf (* ssa to rssa *)
- | Real_mul (* codegen *)
- | Real_muladd (* codegen *)
- | Real_mulsub (* codegen *)
- | Real_neg (* codegen *)
- | Real_qequal (* codegen *)
- | Real_round (* codegen *)
- | Real_sub (* codegen *)
- | Real_toInt (* codegen *)
+ | Real_Math_acos of RealSize.t (* codegen *)
+ | Real_Math_asin of RealSize.t (* codegen *)
+ | Real_Math_atan of RealSize.t (* codegen *)
+ | Real_Math_atan2 of RealSize.t (* codegen *)
+ | Real_Math_cos of RealSize.t (* codegen *)
+ | Real_Math_exp of RealSize.t (* codegen *)
+ | Real_Math_ln of RealSize.t (* codegen *)
+ | Real_Math_log10 of RealSize.t (* codegen *)
+ | Real_Math_sin of RealSize.t (* codegen *)
+ | Real_Math_sqrt of RealSize.t (* codegen *)
+ | Real_Math_tan of RealSize.t (* codegen *)
+ | Real_abs of RealSize.t (* codegen *)
+ | Real_add of RealSize.t (* codegen *)
+ | Real_div of RealSize.t (* codegen *)
+ | Real_equal of RealSize.t (* codegen *)
+ | Real_ge of RealSize.t (* codegen *)
+ | Real_gt of RealSize.t (* codegen *)
+ | Real_ldexp of RealSize.t (* codegen *)
+ | Real_le of RealSize.t (* codegen *)
+ | Real_lt of RealSize.t (* codegen *)
+ | Real_mul of RealSize.t (* codegen *)
+ | Real_muladd of RealSize.t (* codegen *)
+ | Real_mulsub of RealSize.t (* codegen *)
+ | Real_neg of RealSize.t (* codegen *)
+ | Real_qequal of RealSize.t (* codegen *)
+ | Real_round of RealSize.t (* codegen *)
+ | Real_sub of RealSize.t (* codegen *)
+ | Real_toInt of RealSize.t (* codegen *)
| Ref_assign (* backend *)
| Ref_deref (* backend *)
| Ref_ref (* backend *)
- | String_fromWord8Vector (* ssa to rssa *)
- | String_toWord8Vector (* ssa to rssa *)
+ | String_toWord8Vector (* infer *)
| Thread_atomicBegin (* backend *)
| Thread_atomicEnd (* backend *)
| Thread_canHandle (* backend *)
@@ -164,63 +160,42 @@
* on the stack.
*)
| Thread_switchTo (* ssa to rssa *)
- | Vector_fromArray (* backend *)
| Vector_length (* ssa to rssa *)
| Vector_sub (* backend *)
| Weak_canGet (* ssa to rssa *)
| Weak_get (* ssa to rssa *)
| Weak_new (* ssa to rssa *)
- | Word32_add (* codegen *)
- | Word32_addCheck (* codegen *)
- | Word32_andb (* codegen *)
- | Word32_arshift (* codegen *)
- | Word32_div (* codegen *)
- | Word32_fromInt (* ssa to rssa *)
- | Word32_ge (* codegen *)
- | Word32_gt (* codegen *)
- | Word32_le (* codegen *)
- | Word32_lshift (* codegen *)
- | Word32_lt (* codegen *)
- | Word32_mod (* codegen *)
- | Word32_mul (* codegen *)
- | Word32_mulCheck (* codegen *)
- | Word32_neg (* codegen *)
- | Word32_notb (* codegen *)
- | Word32_orb (* codegen *)
- | Word32_rol (* codegen *)
- | Word32_ror (* codegen *)
- | Word32_rshift (* codegen *)
- | Word32_sub (* codegen *)
- | Word32_toIntX (* ssa to rssa *)
- | Word32_xorb (* codegen *)
- | Word8Array_subWord (* codegen *)
- | Word8Array_updateWord (* codegen *)
- | Word8Vector_subWord (* codegen *)
- | Word8_add (* codegen *)
- | Word8_andb (* codegen *)
- | Word8_arshift (* codegen *)
- | Word8_div (* codegen *)
- | Word8_fromInt (* codegen *)
- | Word8_fromLargeWord (* codegen *)
- | Word8_ge (* codegen *)
- | Word8_gt (* codegen *)
- | Word8_le (* codegen *)
- | Word8_lshift (* codegen *)
- | Word8_lt (* codegen *)
- | Word8_mod (* codegen *)
- | Word8_mul (* codegen *)
- | Word8_neg (* codegen *)
- | Word8_notb (* codegen *)
- | Word8_orb (* codegen *)
- | Word8_rol (* codegen *)
- | Word8_ror (* codegen *)
- | Word8_rshift (* codegen *)
- | Word8_sub (* codegen *)
- | Word8_toInt (* codegen *)
- | Word8_toIntX (* codegen *)
- | Word8_toLargeWord (* codegen *)
- | Word8_toLargeWordX (* codegen *)
- | Word8_xorb (* codegen *)
+ | Word_add of WordSize.t (* codegen *)
+ | Word_addCheck of WordSize.t (* codegen *)
+ | Word_andb of WordSize.t (* codegen *)
+ | Word_arshift of WordSize.t (* codegen *)
+ | Word_div of WordSize.t (* codegen *)
+ | Word_ge of WordSize.t (* codegen *)
+ | Word_gt of WordSize.t (* codegen *)
+ | Word_le of WordSize.t (* codegen *)
+ | Word_lshift of WordSize.t (* codegen *)
+ | Word_lt of WordSize.t (* codegen *)
+ | Word_mod of WordSize.t (* codegen *)
+ | Word_mul of WordSize.t (* codegen *)
+ | Word_mulCheck of WordSize.t (* codegen *)
+ | Word_neg of WordSize.t (* codegen *)
+ | Word_notb of WordSize.t (* codegen *)
+ | Word_orb of WordSize.t (* codegen *)
+ | Word_rol of WordSize.t (* codegen *)
+ | Word_ror of WordSize.t (* codegen *)
+ | Word_rshift of WordSize.t (* codegen *)
+ | Word_sub of WordSize.t (* codegen *)
+ | Word_toInt of WordSize.t * IntSize.t (* codegen *)
+ | Word_toIntInf (* ssa to rssa *)
+ | Word_toIntX of WordSize.t * IntSize.t (* codegen *)
+ | Word_toWord of WordSize.t * WordSize.t (* codegen *)
+ | Word_toWordX of WordSize.t * WordSize.t (* codegen *)
+ | Word_xorb of WordSize.t (* codegen *)
+ | WordVector_toIntInf (* ssa to rssa *)
+ | Word8Array_subWord (* ssa to rssa *)
+ | Word8Array_updateWord (* ssa to rssa *)
+ | Word8Vector_subWord (* ssa to rssa *)
+ | Word8Vector_toString (* infer *)
| World_save (* ssa to rssa *)
val layout: t -> Layout.t
@@ -233,7 +208,7 @@
sig
datatype 'a t =
Con of {con: Con.t, hasArg: bool}
- | Const of Const.Node.t
+ | Const of Const.t
| Var of 'a
val layout: ('a -> Layout.t) -> 'a t -> Layout.t
@@ -286,12 +261,13 @@
val ffi: string * Scheme.t -> t
val gcCollect: t
val intInfEqual: t
- val intAdd: t
- val intAddCheck: t
- val intMul: t
- val intMulCheck: t
- val intSub: t
- val intSubCheck: t
+ val intAdd: IntSize.t -> t
+ val intAddCheck: IntSize.t -> t
+ val intMul: IntSize.t -> t
+ val intMulCheck: IntSize.t -> t
+ val intSub: IntSize.t -> t
+ val intSubCheck: IntSize.t -> t
+ val intToWord: IntSize.t * WordSize.t -> t
val isCommutative: t -> bool
(*
* isFunctional p = true iff p always returns same result when given
@@ -320,14 +296,17 @@
val toString: t -> string
val vectorLength: t
val vectorSub: t
- val word32Add: t
- val word32AddCheck: t
- val word32Andb: t
- val word32FromInt: t
- val word32Gt: t
- val word32Mul: t
- val word32MulCheck: t
- val word32Rshift: t
- val word32Sub: t
- val word32ToIntX: t
+ val wordAdd: WordSize.t -> t
+ val wordAddCheck: WordSize.t -> t
+ val wordAndb: WordSize.t -> t
+ val wordGe: WordSize.t -> t
+ val wordGt: WordSize.t -> t
+ val wordLe: WordSize.t -> t
+ val wordLt: WordSize.t -> t
+ val wordMul: WordSize.t -> t
+ val wordMulCheck: WordSize.t -> t
+ val wordRshift: WordSize.t -> t
+ val wordSub: WordSize.t -> t
+ val wordToInt: WordSize.t * IntSize.t -> t
+ val wordToIntX: WordSize.t * IntSize.t -> t
end
1.12 +9 -4 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- sources.cm 18 Apr 2003 22:44:58 -0000 1.11
+++ sources.cm 23 Jun 2003 04:58:55 -0000 1.12
@@ -11,7 +11,7 @@
signature ATOMS
signature ID
signature ID_NO_AST
-signature CASES
+signature INT_X
signature CON
signature CONST
signature GENERIC_SCHEME
@@ -19,6 +19,7 @@
signature HASH_TYPE
signature PRIM
signature PROFILE_EXP
+signature REAL_X
signature RECORD
signature SCHEME
signature SOURCE_INFO
@@ -27,9 +28,9 @@
signature TYPE
signature TYVAR
signature VAR
+signature WORD_X
functor Atoms
-functor Cases
functor Id
functor IdNoAst
functor GenericScheme
@@ -45,8 +46,6 @@
atoms.fun
atoms.sig
-cases.fun
-cases.sig
cons.fun
cons.sig
const.fun
@@ -57,10 +56,14 @@
hash-type.sig
id.fun
id.sig
+int-x.fun
+int-x.sig
prim.fun
prim.sig
profile-exp.fun
profile-exp.sig
+real-x.fun
+real-x.sig
scheme.sig
source-info.fun
source-info.sig
@@ -73,3 +76,5 @@
use-name.fun
var.fun
var.sig
+word-x.fun
+word-x.sig
1.3 +4 -1 mlton/mlton/atoms/tycon.fun
Index: tycon.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- tycon.fun 10 Apr 2002 07:02:19 -0000 1.2
+++ tycon.fun 23 Jun 2003 04:58:55 -0000 1.3
@@ -14,7 +14,10 @@
val noname = "t")
open Id
-structure P = PrimTycons (Id)
+structure P = PrimTycons (structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize
+ open Id)
open P
fun stats () =
1.3 +3 -0 mlton/mlton/atoms/tycon.sig
Index: tycon.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- tycon.sig 10 Apr 2002 07:02:19 -0000 1.2
+++ tycon.sig 23 Jun 2003 04:58:55 -0000 1.3
@@ -8,6 +8,9 @@
signature TYCON_STRUCTS =
sig
structure AstId: AST_ID
+ structure IntSize: INT_SIZE
+ structure RealSize: REAL_SIZE
+ structure WordSize: WORD_SIZE
end
signature TYCON =
1.6 +20 -10 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- type-ops.fun 18 Apr 2003 22:44:58 -0000 1.5
+++ type-ops.fun 23 Jun 2003 04:58:55 -0000 1.6
@@ -10,26 +10,35 @@
open S
+local
+ open Tycon
+in
+ structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize
+end
+datatype intSize = datatype IntSize.t
+datatype realSize = datatype RealSize.t
type tycon = Tycon.t
+datatype wordSize = datatype WordSize.t
local
fun nullary tycon = con (tycon, Vector.new0 ())
in
val bool = nullary Tycon.bool
- val char = nullary Tycon.char
val exn = nullary Tycon.exn
- val int = nullary Tycon.int
+ val int = IntSize.memoize (fn s => nullary (Tycon.int s))
val intInf = nullary Tycon.intInf
val preThread = nullary Tycon.preThread
- val real = nullary Tycon.real
+ val real = RealSize.memoize (fn s => nullary (Tycon.real s))
val thread = nullary Tycon.thread
- val word = nullary Tycon.word
- val word8 = nullary Tycon.word8
-
- val defaultInt = nullary Tycon.defaultInt
- val defaultWord = nullary Tycon.defaultWord
+ val word = WordSize.memoize (fn s => nullary (Tycon.word s))
end
+val defaultInt = int IntSize.default
+val defaultReal = real RealSize.default
+val defaultWord = word WordSize.default
+
local
fun unary tycon t = con (tycon, Vector.new1 t)
in
@@ -40,8 +49,9 @@
val weak = unary Tycon.weak
end
-val string = vector char
-
+val word8 = word W8
+val word8Vector = vector word8
+
local
fun binary tycon (t1, t2) = con (tycon, Vector.new2 (t1, t2))
in
1.6 +10 -7 mlton/mlton/atoms/type-ops.sig
Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- type-ops.sig 18 Apr 2003 22:44:58 -0000 1.5
+++ type-ops.sig 23 Jun 2003 04:58:55 -0000 1.6
@@ -22,17 +22,19 @@
signature TYPE_OPS =
sig
(* Don't want to include TYPE_OPS_STRUCTS because don't want to propagate
- * the Tycon structure, which will cause duplicate specifications later on.
+ * the Tycon structure, which will cause duplicate specifications later
+ * on.
*)
-
+ type intSize
+ type realSize
type tycon
+ type wordSize
type t
val arg: t -> t (* arg = #1 o dearrow *)
val array: t -> t
val arrow: t * t -> t
val bool: t
- val char: t
val con: tycon * t vector -> t
val dearray: t -> t
val dearrayOpt: t -> t option
@@ -42,6 +44,7 @@
val deconConstOpt: t -> (tycon * tycon vector) option
val deconConst: t -> (tycon * tycon vector)
val defaultInt: t
+ val defaultReal: t
val defaultWord: t
val deref: t -> t
val derefOpt: t -> t option
@@ -52,22 +55,22 @@
val deweak: t -> t
val deweakOpt: t -> t option
val exn: t
- val int: t
+ val int: intSize -> t
val intInf: t
val isTuple: t -> bool
val list: t -> t
val nth: t * int -> t
val preThread: t
- val real: t
+ val real: realSize -> t
val reff: t -> t
val result: t -> t (* result = #2 o dearrow *)
- val string: t
val thread: t
val tuple: t vector -> t
val unit: t
val unitRef: t
val vector: t -> t
val weak: t -> t
+ val word: wordSize -> t
val word8: t
- val word: t
+ val word8Vector: t
end
1.3 +12 -2 mlton/mlton/atoms/type.fun
Index: type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- type.fun 10 Apr 2002 07:02:19 -0000 1.2
+++ type.fun 23 Jun 2003 04:58:55 -0000 1.3
@@ -12,12 +12,13 @@
structure Type =
struct
+ type var = Tyvar.t
+
datatype t =
Var of var
| Con of con
| Record of record
- withtype var = Tyvar.t
- and con = Tycon.t * t vector
+ withtype con = Tycon.t * t vector
and record = t Record.t
datatype t' = datatype t
@@ -51,6 +52,15 @@
structure Ops = TypeOps (structure Tycon = Tycon
open Type)
open Ops Type
+
+val rec equals =
+ fn (Var a, Var a') => Tyvar.equals (a, a')
+ | (Con (c, ts), Con (c', ts')) =>
+ Tycon.equals (c, c')
+ andalso Vector.equals (ts, ts', equals)
+ | (Record r, Record r') =>
+ Record.equals (r, r', equals)
+ | _ => false
structure Tyvars = UnorderedSet (Tyvar)
1.4 +8 -3 mlton/mlton/atoms/type.sig
Index: type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- type.sig 13 May 2003 16:32:28 -0000 1.3
+++ type.sig 23 Jun 2003 04:58:55 -0000 1.4
@@ -11,22 +11,27 @@
structure Record: RECORD
structure Tycon: TYCON
structure Tyvar: TYVAR
+ sharing Record = Ast.SortedRecord
sharing Tyvar = Ast.Tyvar
sharing Ast.Tycon = Tycon.AstId
- sharing Record = Ast.SortedRecord
end
signature TYPE =
sig
include TYPE_STRUCTS
- include TYPE_OPS where type tycon = Tycon.t
+ include TYPE_OPS
+ where type intSize = Tycon.IntSize.t
+ where type realSize = Tycon.RealSize.t
+ where type tycon = Tycon.t
+ where type wordSize = Tycon.WordSize.t
datatype t' =
Con of Tycon.t * t' vector
| Record of t' Record.t
| Var of Tyvar.t
sharing type t = t'
-
+
+ val equals: t * t -> bool
val hom: {ty: t,
var: Tyvar.t -> 'a,
con: Tycon.t * 'a vector -> 'a} -> 'a
1.1 mlton/mlton/atoms/int-x.fun
Index: int-x.fun
===================================================================
functor IntX (S: INT_X_STRUCTS): INT_X =
struct
open S
datatype z = datatype IntSize.t
datatype t = T of {int: IntInf.t,
size: IntSize.t}
local
fun make f (T r) = f r
in
val int = make #int
val size = make #size
end
fun equals (T {int = i, ...}, T {int = i', ...}) = i = i'
fun toString (T {int = i, ...}) = IntInf.toString i
val layout = Layout.str o toString
fun format (T {int = i, ...}, r) = IntInf.format (i, r)
fun make (i: IntInf.t, s: IntSize.t): t =
if IntSize.isInRange (s, i)
then T {int = i,
size = s}
else raise Overflow
fun defaultInt (i: int): t = make (IntInf.fromInt i, IntSize.default)
val toIntInf = int
val toInt = IntInf.toInt o toIntInf
val toChar = Char.fromInt o toInt
val hash = IntInf.hash o toIntInf
local
val make: (IntInf.t * IntInf.t -> IntInf.t) -> t * t -> t =
fn f => fn (i, i') => make (f (int i, int i'), size i)
in
val op + = make IntInf.+
val op - = make IntInf.-
val op * = make IntInf.*
val quot = make IntInf.quot
val rem = make IntInf.rem
end
fun ~ i = make (IntInf.~ (int i), size i)
local
fun is i i' = int i' = IntInf.fromInt i
in
val isNegOne = is ~1
val isOne = is 1
val isZero = is 0
end
local
fun is f i = int i = f (size i)
in
val isMax = is IntSize.max
val isMin = is IntSize.min
end
fun one s = make (IntInf.fromInt 1, s)
fun zero s = make (IntInf.fromInt 0, s)
fun max s = make (IntSize.max s, s)
fun min s = make (IntSize.min s, s)
local
fun make (f: IntInf.t * IntInf.t -> 'a): t * t -> 'a =
fn (i, i') =>
if IntSize.equals (size i, size i')
then f (int i, int i')
else Error.bug "IntX binary failure"
in
val op < = make IntInf.<
val op <= = make IntInf.<=
val op > = make IntInf.>
val op >= = make IntInf.>=
val compare = make IntInf.compare
end
end
1.1 mlton/mlton/atoms/int-x.sig
Index: int-x.sig
===================================================================
type int = Int.t
type word = Word.t
signature INT_X_STRUCTS =
sig
structure IntSize: INT_SIZE
end
signature INT_X =
sig
include INT_X_STRUCTS
(* Ints of all IntSize.t sizes. *)
type t
val + : t * t -> t
val - : t * t -> t
val * : t * t -> t
val ~ : t -> t
val > : t * t -> bool
val < : t * t -> bool
val >= : t * t -> bool
val <= : t * t -> bool
val compare: t * t -> Relation.t
val defaultInt: int -> t
val equals: t * t -> bool
val format: t * StringCvt.radix -> string
val hash: t -> word
val isMax: t -> bool
val isMin: t -> bool
val isNegOne: t -> bool
val isOne: t -> bool
val isZero: t -> bool
val layout: t -> Layout.t
val make: IntInf.t * IntSize.t -> t
val max: IntSize.t -> t
val min: IntSize.t -> t
val one: IntSize.t -> t
val quot: t * t -> t
val rem: t * t -> t
val size: t -> IntSize.t
val toChar: t -> char
val toInt: t -> int
val toIntInf: t -> IntInf.t
val toString: t -> string
val zero: IntSize.t -> t
end
1.1 mlton/mlton/atoms/real-x.fun
Index: real-x.fun
===================================================================
functor RealX (S: REAL_X_STRUCTS): REAL_X =
struct
open S
datatype t = T of {real: string,
size: RealSize.t}
local
fun make f (T r) = f r
in
val size = make #size
end
fun make (r, s) = T {real = r, size = s}
fun equals (T {real = r, ...}, T {real = r', ...}) = r = r'
fun toString (T {real = r, ...}) = r
val layout = Layout.str o toString
val hash = String.hash o toString
end
1.1 mlton/mlton/atoms/real-x.sig
Index: real-x.sig
===================================================================
type int = Int.t
type word = Word.t
signature REAL_X_STRUCTS =
sig
structure RealSize: REAL_SIZE
end
signature REAL_X =
sig
include REAL_X_STRUCTS
(* reals of all RealSize.t sizes. *)
type t
val equals: t * t -> bool
val hash: t -> word
val layout: t -> Layout.t
val make: string * RealSize.t -> t
val size: t -> RealSize.t
val toString: t -> string
end
1.1 mlton/mlton/atoms/word-x.fun
Index: word-x.fun
===================================================================
functor WordX (S: WORD_X_STRUCTS): WORD_X =
struct
open S
datatype z = datatype WordSize.t
(* Words are stored with all zeros for the unused bits. *)
local
datatype t = T of {size: WordSize.t,
word: word}
in
type t = t
fun make (w, s) =
T {size = s,
word = Word.andb (w, WordSize.max s)}
fun dest (T r) = r
end
local
fun make f = f o dest
in
val size = make #size
val word = make #word
end
val toWord = word
fun fromWord8 w = make (Word8.toWord w, W8)
fun equals (w, w') = dest w = dest w'
fun toString w =
let
val {word, ...} = dest w
in
concat ["0wx", Word.toString word]
end
val layout = Layout.str o toString
fun fromChar (c: Char.t) =
make (Word8.toWord (Word8.fromChar c), WordSize.W8)
fun signExtend (w: t): word =
let
val {size = s, word = w} = dest w
in
case s of
W8 => if 0w0 = Word.andb (w, 0wx80)
then w
else Word.orb (w, 0wxFFFFFF00)
| W16 => if 0w0 = Word.andb (w, 0wx8000)
then w
else Word.orb (w, 0wxFFFF0000)
| W32 => w
end
fun ~>> (w, w') =
make (Word.~>> (signExtend w, word w'), size w)
fun rol (w, w') =
let
val {size = s, word = w} = dest w
val {word = w', ...} = dest w'
in
make (let
open Word
val s = Word.fromInt (WordSize.size s)
val w' = w' mod s
in
orb (>> (w, s - w'), << (w, w'))
end,
s)
end
fun ror (w, w') =
let
val {size = s, word = w} = dest w
val {word = w', ...} = dest w'
in
make (let
open Word
val s = Word.fromInt (WordSize.size s)
val w' = w' mod s
in
orb (>> (w, w'), << (w, s - w'))
end,
s)
end
fun resize (w, s) = make (word w, s)
fun resizeX (w, s) = make (signExtend w, s)
fun fromLargeInt (i: IntInf.t, s) = make (Word.fromIntInf i, s)
val toIntInf = Word.toIntInf o word
fun toIntInfX w = Word.toIntInfX (signExtend w)
local
val make: (word * word -> word) -> t * t -> t =
fn f => fn (w, w') =>
let
val {size = s, word = w} = dest w
val {word = w', ...} = dest w'
in
make (f (w, w'), s)
end
in
val op + = make Word.+
val op - = make Word.-
val op * = make Word.*
val << = make Word.<<
val >> = make Word.>>
val andb = make Word.andb
val op div = make Word.div
val op mod = make Word.mod
val orb = make Word.orb
val xorb = make Word.xorb
end
fun notb w = make (Word.notb (word w), size w)
fun isOne w = 0w1 = word w
fun isZero w = 0w0 = word w
fun isAllOnes w = word w = WordSize.allOnes (size w)
fun isMax w = word w = WordSize.max (size w)
fun one s = make (0w1, s)
fun zero s = make (0w0, s)
fun allOnes s = make (WordSize.allOnes s, s)
fun max s = make (WordSize.max s, s)
fun toChar w =
let
val {word = w, ...} = dest w
in
Word8.toChar (Word8.fromWord w)
end
val toString = Word.toString o word
local
fun make (f: word * word -> 'a): t * t -> 'a =
fn (w, w') =>
let
val {size = s, word = w} = dest w
val {size = s', word = w'} = dest w'
in
if WordSize.equals (s, s')
then f (w, w')
else Error.bug "WordX binary failure"
end
in
val op < = make (op <)
val op <= = make (op <=)
val op > = make (op >)
val op >= = make (op >=)
end
end
1.1 mlton/mlton/atoms/word-x.sig
Index: word-x.sig
===================================================================
type int = Int.t
type word = Word.t
signature WORD_X_STRUCTS =
sig
structure WordSize: WORD_SIZE
end
signature WORD_X =
sig
include WORD_X_STRUCTS
(* Words of all WordSize.t sizes. *)
type t
val << : t * t -> t
val >> : t * t -> t
val ~>> : t * t -> t
val + : t * t -> t
val - : t * t -> t
val * : t * t -> t
val > : t * t -> bool
val < : t * t -> bool
val >= : t * t -> bool
val <= : t * t -> bool
val andb: t * t -> t
val div: t * t -> t
val equals: t * t -> bool
val fromChar: char -> t (* returns a word of size 8 *)
val fromLargeInt: IntInf.t * WordSize.t -> t
val fromWord8: Word8.t -> t
val isAllOnes: t -> bool
val isOne: t -> bool
val isMax: t -> bool
val isZero: t -> bool
val layout: t -> Layout.t
val make: word * WordSize.t -> t
val max: WordSize.t -> t
val mod: t * t -> t
val notb: t -> t
val one: WordSize.t -> t
val orb: t * t -> t
val resize: t * WordSize.t -> t
val resizeX: t * WordSize.t -> t
val rol: t * t -> t
val ror: t * t -> t
val size: t -> WordSize.t
val toChar: t -> char
val toIntInf: t -> IntInf.t
val toIntInfX: t -> IntInf.t
val toString: t -> string
val toWord: t -> word
val xorb: t * t -> t
val zero: WordSize.t -> t
end
1.27 +3 -3 mlton/mlton/backend/allocate-registers.fun
Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- allocate-registers.fun 24 Apr 2003 20:50:44 -0000 1.26
+++ allocate-registers.fun 23 Jun 2003 04:58:56 -0000 1.27
@@ -42,7 +42,7 @@
local
open Type
in
- val handlerSize = Runtime.labelSize + size word
+ val handlerSize = Runtime.labelSize + size defaultWord
end
structure Live = Live (open Rssa)
@@ -455,7 +455,7 @@
then
let
val (stack, {offset = handler, ...}) =
- Allocation.Stack.get (stack, Type.word)
+ Allocation.Stack.get (stack, Type.defaultWord)
val (stack, {offset = link, ...}) =
Allocation.Stack.get (stack, Type.ExnStack)
in
@@ -513,7 +513,7 @@
case handlerLinkOffset of
NONE => stackInit
| SOME {handler, link} =>
- {offset = handler, ty = Type.word} (* should be label *)
+ {offset = handler, ty = Type.defaultWord} (* should be label *)
:: {offset = link, ty = Type.ExnStack}
:: stackInit
val a = Allocation.new (stackInit, registersInit)
1.55 +54 -39 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- backend.fun 20 May 2003 02:18:26 -0000 1.54
+++ backend.fun 23 Jun 2003 04:58:56 -0000 1.55
@@ -16,15 +16,19 @@
in
structure Chunk = Chunk
structure Global = Global
+ structure IntX = IntX
structure Label = Label
structure MemChunk = MemChunk
structure ObjectType = ObjectType
structure PointerTycon = PointerTycon
structure ProfileInfo = ProfileInfo
+ structure RealX = RealX
structure Register = Register
structure Runtime = Runtime
structure SourceInfo = SourceInfo
structure Type = Type
+ structure WordSize = WordSize
+ structure WordX = WordX
end
local
open Runtime
@@ -345,61 +349,67 @@
fun varOperands xs = Vector.map (xs, varOperand)
(* Hash tables for uniquifying globals. *)
local
- fun 'a make (ty: Type.t, toString: 'a -> string) =
+ fun ('a, 'b) make (equals: 'a * 'a -> bool,
+ info: 'a -> string * Type.t * 'b) =
let
- val set: {global: M.Global.t,
+ val set: {a: 'a,
+ global: M.Global.t,
hash: word,
- string: string} HashSet.t = HashSet.new {hash = #hash}
+ value: 'b} HashSet.t = HashSet.new {hash = #hash}
fun get (a: 'a): M.Operand.t =
let
- val s = toString a
- val hash = String.hash s
+ val (string, ty, value) = info a
+ val hash = String.hash string
in
M.Operand.Global
(#global
(HashSet.lookupOrInsert
- (set, hash, fn {string, ...} => s = string,
- fn () => {hash = hash,
+ (set, hash,
+ fn {a = a', ...} => equals (a, a'),
+ fn () => {a = a,
+ hash = hash,
global = M.Global.new {isRoot = true,
ty = ty},
- string = s})))
+ value = value})))
end
fun all () =
HashSet.fold
- (set, [], fn ({global, string, ...}, ac) =>
- (global, string) :: ac)
+ (set, [], fn ({global, value, ...}, ac) =>
+ (global, value) :: ac)
in
(all, get)
end
in
val (allIntInfs, globalIntInf) =
- make (Type.intInf, fn i => IntInf.format (i, StringCvt.DEC))
- val (allReals, globalReal) = make (Type.real, fn s => s)
- val (allStrings, globalString) = make (Type.string, fn s => s)
+ make (IntInf.equals,
+ fn i => let
+ val s = IntInf.toString i
+ in
+ (s, Type.intInf, s)
+ end)
+ val (allReals, globalReal) =
+ make (RealX.equals,
+ fn r => (RealX.toString r,
+ Type.real (RealX.size r),
+ r))
+ val (allStrings, globalString) =
+ make (String.equals, fn s => (s, Type.word8Vector, s))
fun constOperand (c: Const.t): M.Operand.t =
let
- datatype z = datatype Const.Node.t
+ datatype z = datatype Const.t
in
- case Const.node c of
- Char n => M.Operand.Char n
- | Int n => M.Operand.Int n
+ case c of
+ Int i => M.Operand.Int i
| IntInf i =>
(case Const.SmallIntInf.toWord i of
NONE => globalIntInf i
| SOME w => M.Operand.SmallIntInf w)
- | Real f =>
+ | Real r =>
if !Control.Native.native
- then globalReal f
- else M.Operand.Real f
- | String s => globalString s
- | Word w =>
- let val ty = Const.ty c
- in if Const.Type.equals (ty, Const.Type.word)
- then M.Operand.Word w
- else if Const.Type.equals (ty, Const.Type.word8)
- then M.Operand.Char (Char.chr (Word.toInt w))
- else Error.bug "strange word"
- end
+ then globalReal r
+ else M.Operand.Real r
+ | Word w => M.Operand.Word w
+ | Word8Vector v => globalString (Word8.vectorToString v)
end
end
fun parallelMove {chunk,
@@ -430,8 +440,8 @@
offset = GCField.offset field,
ty = ty}
val exnStackOp = runtimeOp (GCField.ExnStack, Type.ExnStack)
- val stackBottomOp = runtimeOp (GCField.StackBottom, Type.Word)
- val stackTopOp = runtimeOp (GCField.StackTop, Type.Word)
+ val stackBottomOp = runtimeOp (GCField.StackBottom, Type.defaultWord)
+ val stackTopOp = runtimeOp (GCField.StackTop, Type.defaultWord)
fun translateOperand (oper: R.Operand.t): M.Operand.t =
let
datatype z = datatype R.Operand.t
@@ -453,8 +463,9 @@
offset = offset,
ty = ty}
| PointerTycon pt =>
- M.Operand.Word (Runtime.typeIndexToHeader
- (PointerTycon.index pt))
+ M.Operand.Word
+ (WordX.make (Runtime.typeIndexToHeader (PointerTycon.index pt),
+ WordSize.default))
| Runtime f =>
runtimeOp (f, R.Operand.ty oper)
| SmallIntInf w => M.Operand.SmallIntInf w
@@ -513,20 +524,22 @@
(* ExnStack = stackTop + (offset + WORD_SIZE) - StackBottom; *)
let
val tmp =
- M.Operand.Register (Register.new (Type.word, NONE))
+ M.Operand.Register
+ (Register.new (Type.defaultWord, NONE))
in
Vector.new2
(M.Statement.PrimApp
{args = (Vector.new2
(stackTopOp,
M.Operand.Int
- (handlerOffset () + Runtime.wordSize))),
+ (IntX.defaultInt
+ (handlerOffset () + Runtime.wordSize)))),
dst = SOME tmp,
- prim = Prim.word32Add},
+ prim = Prim.wordAdd WordSize.default},
M.Statement.PrimApp
{args = Vector.new2 (tmp, stackBottomOp),
dst = SOME exnStackOp,
- prim = Prim.word32Sub})
+ prim = Prim.wordSub WordSize.default})
end
| SetExnStackSlot =>
(* ExnStack = *(uint* )(stackTop + offset); *)
@@ -822,9 +835,11 @@
let
fun doit ({cases: ('a * Label.t) vector,
default: Label.t option,
+ size: 'b,
test: R.Operand.t},
make: {cases: ('a * Label.t) vector,
default: Label.t option,
+ size: 'b,
test: M.Operand.t} -> M.Switch.t) =
simple
(case (Vector.length cases, default) of
@@ -836,11 +851,11 @@
M.Transfer.Switch
(make {cases = cases,
default = default,
+ size = size,
test = translateOperand test}))
in
case switch of
- R.Switch.Char z => doit (z, M.Switch.Char)
- | R.Switch.EnumPointers {enum, pointers, test} =>
+ R.Switch.EnumPointers {enum, pointers, test} =>
simple
(M.Transfer.Switch
(M.Switch.EnumPointers
1.9 +3 -0 mlton/mlton/backend/backend.sig
Index: backend.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- backend.sig 12 Dec 2002 01:14:21 -0000 1.8
+++ backend.sig 23 Jun 2003 04:58:56 -0000 1.9
@@ -12,9 +12,12 @@
sig
structure Machine: MACHINE
structure Ssa: SSA
+ sharing Machine.IntX = Ssa.IntX
sharing Machine.Label = Ssa.Label
sharing Machine.Prim = Ssa.Prim
+ sharing Machine.RealX = Ssa.RealX
sharing Machine.SourceInfo = Ssa.SourceInfo
+ sharing Machine.WordX = Ssa.WordX
val funcToLabel: Ssa.Func.t -> Machine.Label.t
end
1.12 +1 -1 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- c-function.fun 25 Mar 2003 04:31:24 -0000 1.11
+++ c-function.fun 23 Jun 2003 04:58:56 -0000 1.12
@@ -111,7 +111,7 @@
end
val size = vanilla {name = "MLton_size",
- returnTy = SOME Type.int}
+ returnTy = SOME Type.defaultInt}
val returnToC =
T {bytesNeeded = NONE,
1.16 +2 -3 mlton/mlton/backend/chunkify.fun
Index: chunkify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/chunkify.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- chunkify.fun 2 Apr 2003 02:55:56 -0000 1.15
+++ chunkify.fun 23 Jun 2003 04:58:56 -0000 1.16
@@ -44,12 +44,11 @@
Switch s =>
let
datatype z = datatype Switch.t
- fun simple {cases, default, test} =
+ fun simple {cases, default, size, test} =
1 + Vector.length cases
in
case s of
- Char z => simple z
- | EnumPointers _ => 2
+ EnumPointers _ => 2
| Int z => simple z
| Pointer {cases, ...} => 1 + Vector.length cases
| Word z => simple z
1.38 +27 -18 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- limit-check.fun 25 Mar 2003 04:31:24 -0000 1.37
+++ limit-check.fun 23 Jun 2003 04:58:56 -0000 1.38
@@ -167,7 +167,9 @@
case z of
Operand.EnsuresBytesFree =>
Operand.word
- (ensureBytesFree (valOf return))
+ (WordX.make
+ (ensureBytesFree (valOf return),
+ WordSize.default))
| _ => z)),
func = func,
return = return}
@@ -280,7 +282,7 @@
fun stackCheck (maybeFirst, z): Label.t =
let
val (statements, transfer) =
- primApp (Prim.word32Gt,
+ primApp (Prim.wordGt WordSize.default,
Operand.Runtime StackTop,
Operand.Runtime StackLimit,
z)
@@ -289,7 +291,9 @@
end
fun maybeStack (): Label.t =
if stack
- then stackCheck (true, insert (Operand.word 0w0))
+ then stackCheck (true,
+ insert (Operand.word
+ (WordX.zero WordSize.default)))
else
(* No limit check, just keep the block around. *)
(List.push (newBlocks,
@@ -324,12 +328,12 @@
Statement.PrimApp
{args = Vector.new2 (Operand.Runtime LimitPlusSlop,
Operand.Runtime Frontier),
- dst = SOME (res, Type.word),
- prim = Prim.word32Sub}
+ dst = SOME (res, Type.defaultWord),
+ prim = Prim.wordSub WordSize.default}
val (statements, transfer) =
- primApp (Prim.word32Gt,
+ primApp (Prim.wordGt WordSize.default,
amount,
- Operand.Var {var = res, ty = Type.word},
+ Operand.Var {var = res, ty = Type.defaultWord},
z)
val statements = Vector.concat [Vector.new1 s, statements]
in
@@ -338,7 +342,7 @@
frontierCheck (isFirst,
Prim.eq,
Operand.Runtime Limit,
- Operand.int 0,
+ Operand.int (IntX.zero IntSize.default),
{collect = collect,
dontCollect = newBlock (false,
statements,
@@ -355,11 +359,14 @@
fun heapCheckNonZero (bytes: Word.t): Label.t =
if bytes <= Word.fromInt Runtime.limitSlop
then frontierCheck (true,
- Prim.word32Gt,
+ Prim.wordGt WordSize.default,
Operand.Runtime Frontier,
Operand.Runtime Limit,
- insert (Operand.word 0w0))
- else heapCheck (true, Operand.word bytes)
+ insert (Operand.word
+ (WordX.zero WordSize.default)))
+ else heapCheck (true,
+ Operand.word (WordX.make (bytes,
+ WordSize.default)))
fun smallAllocation _ =
let
val w = blockCheckAmount {blockIndex = i}
@@ -376,10 +383,10 @@
in
case bytesNeeded of
Operand.Const c =>
- (case Const.node c of
- Const.Node.Word w =>
+ (case c of
+ Const.Word w =>
heapCheckNonZero
- (MLton.Word.addCheck (w, extraBytes)
+ (MLton.Word.addCheck (WordX.toWord w, extraBytes)
handle Overflow => Runtime.allocTooLarge)
| _ => Error.bug "strange primitive bytes needed")
| _ =>
@@ -390,16 +397,18 @@
(true,
Vector.new0 (),
Transfer.Arith
- {args = Vector.new2 (Operand.word extraBytes,
+ {args = Vector.new2 (Operand.word
+ (WordX.make (extraBytes,
+ WordSize.default)),
bytesNeeded),
dst = bytes,
overflow = allocTooLarge (),
- prim = Prim.word32AddCheck,
+ prim = Prim.wordAddCheck WordSize.default,
success = (heapCheck
(false,
Operand.Var {var = bytes,
- ty = Type.word})),
- ty = Type.word})
+ ty = Type.defaultWord})),
+ ty = Type.defaultWord})
end
end
val bs = {big = bigAllocation,
1.9 +69 -63 mlton/mlton/backend/machine-atoms.fun
Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- machine-atoms.fun 18 Apr 2003 22:44:59 -0000 1.8
+++ machine-atoms.fun 23 Jun 2003 04:58:56 -0000 1.9
@@ -9,6 +9,8 @@
struct
open S
+datatype z = datatype IntSize.t
+datatype z = datatype WordSize.t
structure ProfileLabel = ProfileLabel ()
@@ -44,7 +46,7 @@
* {STACK,STRING,THREAD,WEAK_GONE,WORD_VECTOR}_TYPE_INDEX.
*)
val stack = new ()
- val string = new ()
+ val word8Vector = new ()
val thread = new ()
val weakGone = new ()
val wordVector = new ()
@@ -53,17 +55,16 @@
structure TypeAndMemChunk =
struct
datatype ty =
- Char
- | CPointer
+ CPointer
| EnumPointers of {enum: int vector,
pointers: PointerTycon.t vector}
| ExnStack
- | Int
+ | Int of IntSize.t
| IntInf
| Label of Label.t
| MemChunk of memChunk
- | Real
- | Word
+ | Real of RealSize.t
+ | Word of WordSize.t
and memChunk =
T of {components: {mutable: bool,
offset: int,
@@ -75,8 +76,7 @@
open Layout
in
case t of
- Char => str "char"
- | CPointer => str "cpointer"
+ CPointer => str "cpointer"
| EnumPointers {enum, pointers} =>
if 0 = Vector.length enum
andalso 1 = Vector.length pointers
@@ -86,12 +86,12 @@
(Vector.concat [Vector.map (enum, Int.layout),
Vector.map (pointers, PointerTycon.layout)])
| ExnStack => str "exnStack"
- | Int => str "int"
+ | Int s => str (concat ["Int", IntSize.toString s])
| IntInf => str "intInf"
| Label l => seq [str "Label ", Label.layout l]
| MemChunk m => seq [str "MemChunk ", layoutMemChunk m]
- | Real => str "real"
- | Word => str "word"
+ | Real s => str (concat ["Real", RealSize.toString s])
+ | Word s => str (concat ["Word", WordSize.toString s])
end
and layoutMemChunk (T {components, size}) =
Layout.record
@@ -105,20 +105,19 @@
fun equalsTy (t, t'): bool =
case (t, t') of
- (Char, Char) => true
- | (CPointer, CPointer) => true
+ (CPointer, CPointer) => true
| (EnumPointers {enum = e, pointers = p},
EnumPointers {enum = e', pointers = p'}) =>
e = e'
andalso (MLton.eq (p, p')
orelse Vector.equals (p, p', PointerTycon.equals))
| (ExnStack, ExnStack) => true
- | (Int, Int) => true
+ | (Int s, Int s') => IntSize.equals (s, s')
| (IntInf, IntInf) => true
| (Label l, Label l') => Label.equals (l, l')
| (MemChunk m, MemChunk m') => equalsMemChunk (m, m')
- | (Real, Real) => true
- | (Word, Word) => true
+ | (Real s, Real s') => RealSize.equals (s, s')
+ | (Word s, Word s') => WordSize.equals (s, s')
| _ => false
and equalsMemChunk (T {components = cs, size = s},
T {components = cs', size = s'}) =
@@ -134,34 +133,32 @@
val double: int = 8
in
val size =
- fn Char => byte
- | CPointer => word
+ fn CPointer => word
| EnumPointers _ => word
| ExnStack => word
- | Int => word
+ | Int s => IntSize.bytes s
| IntInf => word
| Label _ => word
| MemChunk _ => word
- | Real => double
- | Word => word
+ | Real s => RealSize.bytes s
+ | Word s => WordSize.bytes s
end
fun isOkTy (t: ty): bool =
case t of
- Char => true
- | CPointer => true
+ CPointer => true
| EnumPointers {enum, pointers} =>
Vector.isSorted (enum, op <=)
andalso Vector.isSorted (pointers, PointerTycon.<=)
andalso (0 = Vector.length pointers
orelse Vector.forall (enum, Int.isOdd))
| ExnStack => true
- | Int => true
+ | Int _ => true
| IntInf => true
| Label _ => true
| MemChunk m => isOkMemChunk m
- | Real => true
- | Word => true
+ | Real _ => true
+ | Word _ => true
and isOkMemChunk (T {components, size = s}) =
let
exception No
@@ -223,8 +220,9 @@
val bool = EnumPointers {enum = Vector.new2 (0, 1),
pointers = Vector.new0 ()}
- val char = Char
val cpointer = CPointer
+ val defaultInt = Int IntSize.default
+ val defaultWord = Word WordSize.default
val exnStack = ExnStack
val int = Int
val intInf = IntInf
@@ -237,9 +235,9 @@
pointers = Vector.new1 pt}
val stack = pointer PointerTycon.stack
- val string = pointer PointerTycon.string
val thread = pointer PointerTycon.thread
val wordVector = pointer PointerTycon.wordVector
+ val word8Vector = pointer PointerTycon.word8Vector
fun containsPointer (t, pt): bool =
case t of
@@ -252,6 +250,10 @@
| IntInf => true
| _ => false
+ val isReal =
+ fn Real _ => true
+ | _ => false
+
fun split ({enum, pointers}) =
{enum = {enum = enum, pointers = Vector.new0 ()},
pointers = {enum = Vector.new0 (), pointers = pointers}}
@@ -262,26 +264,24 @@
val fromRuntime: Runtime.Type.t -> t =
fn t =>
case R.dest t of
- R.Char => char
- | R.Double => real
- | R.Int => int
+ R.Int s => int s
| R.Pointer => cpointer
- | Uint => word
+ | R.Real s => real s
+ | R.Word s => word s
val toRuntime: t -> Runtime.Type.t =
- fn Char => R.char
- | CPointer => R.pointer
+ fn CPointer => R.pointer
| EnumPointers {enum, pointers} =>
if 0 = Vector.length pointers
- then R.int
+ then R.defaultInt
else R.pointer
- | ExnStack => R.uint
- | Int => R.int
+ | ExnStack => R.defaultWord
+ | Int s => R.int s
| IntInf => R.pointer
- | Label _ => R.uint
+ | Label _ => R.defaultWord
| MemChunk _ => R.pointer
- | Real => R.double
- | Word => R.word
+ | Real s => R.real s
+ | Word s => R.word s
val name = R.name o toRuntime
@@ -361,10 +361,10 @@
val stack = Stack
- val string =
+ val word8Vector =
Array (MemChunk.T {components = Vector.new1 {mutable = false,
offset = 0,
- ty = Type.char},
+ ty = Type.word W8},
size = 1})
val thread =
@@ -372,10 +372,10 @@
val components =
Vector.new3 ({mutable = true,
offset = 0,
- ty = Type.word},
+ ty = Type.defaultWord},
{mutable = true,
offset = wordSize,
- ty = Type.word},
+ ty = Type.defaultWord},
{mutable = true,
offset = 2 * wordSize,
ty = Type.stack})
@@ -389,7 +389,7 @@
val wordVector =
Array (MemChunk.T {components = Vector.new1 {mutable = false,
offset = 0,
- ty = Type.word},
+ ty = Type.defaultWord},
size = wordSize})
val isOk =
@@ -425,14 +425,14 @@
val basic =
Vector.fromList
[(PointerTycon.stack, stack),
- (PointerTycon.string, string),
(PointerTycon.thread, thread),
(PointerTycon.weakGone, WeakGone),
- (PointerTycon.wordVector, wordVector)]
+ (PointerTycon.wordVector, wordVector),
+ (PointerTycon.word8Vector, word8Vector)]
end
fun castIsOk {from: Type.t,
- fromInt: int option,
+ fromInt: IntX.t option,
to: Type.t,
tyconTy: PointerTycon.t -> ObjectType.t}: bool =
let
@@ -442,7 +442,7 @@
(Vector.isSubsequence (e, e', op =)
andalso Vector.isSubsequence (p, p', PointerTycon.equals))
orelse
- (* Unsafe Vector_fromArray. *)
+ (* Unsafe Array_toVector. *)
(0 = Vector.length e
andalso 0 = Vector.length e'
andalso 1 = Vector.length p
@@ -483,37 +483,43 @@
datatype z = datatype Type.t
in
not (Type.equals (from, to))
+ andalso Type.size from = Type.size to
andalso
case from of
CPointer =>
(case to of
- Int => true
- | Word => true
+ Int _ => true
+ | Word _ => true
| _ => false)
| EnumPointers (ep as {enum, pointers}) =>
(case to of
EnumPointers ep' => castEnumIsOk (ep, ep')
| IntInf =>
- (* IntInf_fromVector *)
+ (* WordVector_toIntInf *)
0 = Vector.length enum
andalso 1 = Vector.length pointers
andalso PointerTycon.equals (PointerTycon.wordVector,
Vector.sub (pointers, 0))
- | Word => true (* necessary for card marking *)
+ | Word _ => true (* necessary for card marking *)
| _ => false)
- | Int =>
+ | Int _ =>
(case to of
EnumPointers {enum, ...} =>
(case fromInt of
NONE => false
- | SOME int => Vector.exists (enum, fn i => i = int))
+ | SOME int =>
+ Vector.exists (enum, fn i =>
+ IntInf.equals (IntX.toIntInf int,
+ IntInf.fromInt i)))
orelse
(* MLton_bogus *)
(0 = Vector.length enum
andalso (case fromInt of
- SOME 1 => true
- | _ => false))
- | Word => true (* Word32_fromInt *)
+ NONE => false
+ | SOME i =>
+ IntInf.equals (IntX.toIntInf i,
+ IntInf.fromInt 1)))
+ | Word _ => true
| _ => false)
| IntInf =>
(case to of
@@ -523,16 +529,16 @@
andalso 1 = Vector.length pointers
andalso PointerTycon.equals (PointerTycon.wordVector,
Vector.sub (pointers, 0))
- | Word => true (* IntInf_toWord *)
+ | Word s => true (* IntInf_toWord *)
| _ => false)
| MemChunk _ =>
(case to of
- Word => true (* needed for card marking of arrays *)
+ Word _ => true (* needed for card marking of arrays *)
| _ => false)
- | Word =>
+ | Word _ =>
(case to of
- Int => true (* Word32_toIntX *)
- | IntInf => true (* IntInf_fromWord *)
+ Int _ => true (* Word32_toIntX *)
+ | IntInf => true (* Word_toIntInf *)
| _ => false)
| _ => false
end
1.11 +23 -13 mlton/mlton/backend/machine-atoms.sig
Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- machine-atoms.sig 24 Apr 2003 20:50:49 -0000 1.10
+++ machine-atoms.sig 23 Jun 2003 04:58:56 -0000 1.11
@@ -9,10 +9,19 @@
signature MACHINE_ATOMS_STRUCTS =
sig
+ structure IntSize: INT_SIZE
+ structure IntX: INT_X
structure Label: HASH_ID
structure Prim: PRIM
+ structure RealSize: REAL_SIZE
+ structure RealX: REAL_X
structure Runtime: RUNTIME
structure SourceInfo: SOURCE_INFO
+ structure WordSize: WORD_SIZE
+ structure WordX: WORD_X
+ sharing IntSize = IntX.IntSize = Prim.IntSize = Runtime.IntSize
+ sharing RealSize = Prim.RealSize = RealX.RealSize = Runtime.RealSize
+ sharing WordSize = Prim.WordSize = Runtime.WordSize = WordX.WordSize
end
signature MACHINE_ATOMS =
@@ -32,18 +41,17 @@
val new: unit -> t
val plist: t -> PropertyList.t
val stack: t
- val string: t
val thread: t
val toString: t -> string
val wordVector: t
+ val word8Vector: t
end
type memChunk
structure Type:
sig
datatype t =
- Char
- | CPointer
+ CPointer
(* The ints in an enum are in increasing order without dups.
* The pointers are in increasing order (of index in objectTypes
* vector) without dups.
@@ -51,38 +59,40 @@
| EnumPointers of {enum: int vector,
pointers: PointerTycon.t vector}
| ExnStack
- | Int
+ | Int of IntSize.t
| IntInf
| Label of Label.t
| MemChunk of memChunk (* An internal pointer. *)
- | Real
- | Word
+ | Real of RealSize.t
+ | Word of WordSize.t
val align: t * int -> int (* align an address *)
val bool: t
- val char: t
val containsPointer: t * PointerTycon.t -> bool
val cpointer: t
val dePointer: t -> PointerTycon.t option
+ val defaultInt: t
+ val defaultWord: t
val equals: t * t -> bool
val exnStack: t
val fromRuntime: Runtime.Type.t -> t
- val int: t
+ val int: IntSize.t -> t
val intInf: t
val isPointer: t -> bool
+ val isReal: t -> bool
val label: Label.t -> t
val layout: t -> Layout.t
val name: t -> string (* simple one letter abbreviation *)
val pointer: PointerTycon.t -> t
- val real: t
+ val real: RealSize.t -> t
val size: t -> int
val stack: t
- val string: t
val thread: t
val toRuntime: t -> Runtime.Type.t
val toString: t -> string
- val word: t
+ val word: WordSize.t -> t
val wordVector: t
+ val word8Vector: t
end
structure MemChunk:
@@ -111,15 +121,15 @@
val basic: (PointerTycon.t * t) vector
val isOk: t -> bool
val layout: t -> Layout.t
- val string: t
val thread: t
val toRuntime: t -> Runtime.ObjectType.t
val weak: Type.t -> t
val wordVector: t
+ val word8Vector: t
end
val castIsOk: {from: Type.t,
- fromInt: int option,
+ fromInt: IntX.t option,
to: Type.t,
tyconTy: PointerTycon.t -> ObjectType.t} -> bool
end
1.49 +57 -38 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- machine.fun 15 May 2003 14:50:56 -0000 1.48
+++ machine.fun 23 Jun 2003 04:58:56 -0000 1.49
@@ -11,7 +11,17 @@
open S
-structure Runtime = Runtime ()
+structure IntSize = IntX.IntSize
+structure RealSize = RealX.RealSize
+structure WordSize = WordX.WordSize
+
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
+
+structure Runtime = Runtime (structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize)
local
open Runtime
in
@@ -19,10 +29,11 @@
structure GCField = GCField
end
-structure Atoms = MachineAtoms (structure Label = Label
- structure Prim = Prim
+structure Atoms = MachineAtoms (open S
+ structure IntSize = IntSize
+ structure RealSize = RealSize
structure Runtime = Runtime
- structure SourceInfo = SourceInfo)
+ structure WordSize = WordSize)
open Atoms
structure ChunkLabel = IdNoAst (val noname = "ChunkLabel")
@@ -174,23 +185,22 @@
index: t,
ty: Type.t}
| Cast of t * Type.t
- | Char of char
| Contents of {oper: t,
ty: Type.t}
| File
| Frontier
| GCState
| Global of Global.t
- | Int of int
+ | Int of IntX.t
| SmallIntInf of SmallIntInf.t
| Label of Label.t
| Line
| Offset of {base: t, offset: int, ty: Type.t}
| Register of Register.t
- | Real of string
+ | Real of RealX.t
| StackOffset of StackOffset.t
| StackTop
- | Word of Word.t
+ | Word of WordX.t
val rec isLocation =
fn ArrayOffset _ => true
@@ -217,7 +227,6 @@
constrain ty]
| Cast (z, ty) =>
seq [str "Cast ", tuple [layout z, Type.layout ty]]
- | Char c => str (Char.escapeC c)
| Contents {oper, ty} =>
seq [str (concat ["C", Type.name ty, " "]),
paren (layout oper)]
@@ -225,19 +234,19 @@
| Frontier => str "<Frontier>"
| GCState => str "<GCState>"
| Global g => Global.layout g
- | Int i => Int.layout i
+ | Int i => IntX.layout i
| Label l => Label.layout l
| Line => str "<Line>"
| Offset {base, offset, ty} =>
seq [str (concat ["O", Type.name ty, " "]),
tuple [layout base, Int.layout offset],
constrain ty]
- | Real s => str s
+ | Real r => RealX.layout r
| Register r => Register.layout r
| SmallIntInf w => seq [str "SmallIntInf ", paren (Word.layout w)]
| StackOffset so => StackOffset.layout so
| StackTop => str "<StackTop>"
- | Word w => seq [str "0x", Word.layout w]
+ | Word w => WordX.layout w
end
val toString = Layout.toString o layout
@@ -245,22 +254,21 @@
val ty =
fn ArrayOffset {ty, ...} => ty
| Cast (_, ty) => ty
- | Char _ => Type.char
| Contents {ty, ...} => ty
| File => Type.cpointer
- | Frontier => Type.word
+ | Frontier => Type.defaultWord
| GCState => Type.cpointer
| Global g => Global.ty g
- | Int _ => Type.int
+ | Int i => Type.int (IntX.size i)
| Label l => Type.label l
- | Line => Type.int
+ | Line => Type.defaultInt
| Offset {ty, ...} => ty
- | Real _ => Type.real
+ | Real r => Type.real (RealX.size r)
| Register r => Register.ty r
| SmallIntInf _ => Type.intInf
| StackOffset {ty, ...} => ty
- | StackTop => Type.word
- | Word _ => Type.word
+ | StackTop => Type.defaultWord
+ | Word w => Type.word (WordX.size w)
val rec equals =
fn (ArrayOffset {base = b, index = i, ...},
@@ -268,23 +276,22 @@
equals (b, b') andalso equals (i, i')
| (Cast (z, t), Cast (z', t')) =>
Type.equals (t, t') andalso equals (z, z')
- | (Char c, Char c') => c = c'
| (Contents {oper = z, ...}, Contents {oper = z', ...}) =>
equals (z, z')
| (File, File) => true
| (GCState, GCState) => true
| (Global g, Global g') => Global.equals (g, g')
- | (Int i, Int i') => i = i'
+ | (Int i, Int i') => IntX.equals (i, i')
| (Label l, Label l') => Label.equals (l, l')
| (Line, Line) => true
| (Offset {base = b, offset = i, ...},
Offset {base = b', offset = i', ...}) =>
equals (b, b') andalso i = i'
- | (Real s, Real s') => s = s'
+ | (Real r, Real r') => RealX.equals (r, r')
| (Register r, Register r') => Register.equals (r, r')
| (SmallIntInf w, SmallIntInf w') => Word.equals (w, w')
| (StackOffset so, StackOffset so') => StackOffset.equals (so, so')
- | (Word w, Word w') => w = w'
+ | (Word w, Word w') => WordX.equals (w, w')
| _ => false
fun interfere (write: t, read: t): bool =
@@ -732,7 +739,7 @@
maxFrameSize: int,
objectTypes: ObjectType.t vector,
profileInfo: ProfileInfo.t,
- reals: (Global.t * string) list,
+ reals: (Global.t * RealX.t) list,
strings: (Global.t * string) list}
fun clear (T {chunks, profileInfo, ...}) =
@@ -884,16 +891,24 @@
fun tyconTy (pt: PointerTycon.t): ObjectType.t =
Vector.sub (objectTypes, PointerTycon.index pt)
open Layout
- fun globals (name, gs, ty) =
+ fun globals (name, gs, isOk, layout) =
List.foreach
(gs, fn (g, s) =>
- Err.check
- (concat ["global ", name],
- fn () => Type.equals (ty, Global.ty g),
- fn () => seq [String.layout s, str ": ", Type.layout ty]))
- val _ = globals ("real", reals, Type.real)
- val _ = globals ("intInf", intInfs, Type.intInf)
- val _ = globals ("string", strings, Type.string)
+ let
+ val ty = Global.ty g
+ in
+ Err.check
+ (concat ["global ", name],
+ fn () => isOk ty,
+ fn () => seq [layout s, str ": ", Type.layout ty])
+ end)
+ val _ = globals ("real", reals, Type.isReal, RealX.layout)
+ val _ = globals ("intInf", intInfs,
+ fn t => Type.equals (t, Type.intInf),
+ String.layout)
+ val _ = globals ("string", strings,
+ fn t => Type.equals (t, Type.word8Vector),
+ String.layout)
(* Check for no duplicate labels. *)
local
val {get, ...} =
@@ -941,7 +956,6 @@
| _ => NONE),
to = t,
tyconTy = tyconTy}))
- | Char _ => true
| Contents {oper, ...} =>
(checkOperand (oper, alloc)
; Type.equals (Operand.ty oper,
@@ -1001,7 +1015,7 @@
Err.check ("operand", ok, fn () => Operand.layout x)
end
and arrayOffsetIsOk {base, index, ty} =
- Type.equals (Operand.ty index, Type.int)
+ Type.equals (Operand.ty index, Type.defaultInt)
andalso
case Operand.ty base of
Type.CPointer => true (* needed for card marking *)
@@ -1020,7 +1034,12 @@
Vector.sub (components, 0)
in
offset = 0
- andalso Type.equals (ty, ty')
+ andalso (Type.equals (ty, ty')
+ orelse
+ (* Get a word from a word8 array.*)
+ (Type.equals (ty, Type.word W32)
+ andalso
+ Type.equals (ty', Type.word W8)))
end
| _ => false)
| _ => false
@@ -1039,12 +1058,12 @@
| Type.EnumPointers {enum, pointers} =>
0 = Vector.length enum
andalso
- ((* Vector_fromArray header update. *)
+ ((* Array_toVector header update. *)
(offset = Runtime.headerOffset
- andalso Type.equals (ty, Type.word))
+ andalso Type.equals (ty, Type.defaultWord))
orelse
(offset = Runtime.arrayLengthOffset
- andalso Type.equals (ty, Type.int))
+ andalso Type.equals (ty, Type.defaultInt))
orelse
Vector.forall
(pointers, fn p =>
1.37 +13 -6 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- machine.sig 15 May 2003 14:50:56 -0000 1.36
+++ machine.sig 23 Jun 2003 04:58:56 -0000 1.37
@@ -10,9 +10,15 @@
signature MACHINE_STRUCTS =
sig
+ structure IntX: INT_X
structure Label: HASH_ID
structure Prim: PRIM
structure SourceInfo: SOURCE_INFO
+ structure RealX: REAL_X
+ structure WordX: WORD_X
+ sharing IntX.IntSize = Prim.IntSize
+ sharing RealX.RealSize = Prim.RealSize
+ sharing WordX.WordSize = Prim.WordSize
end
signature MACHINE =
@@ -20,9 +26,11 @@
include MACHINE_ATOMS
structure Switch: SWITCH
+ sharing IntX = Switch.IntX
sharing Label = Switch.Label
sharing PointerTycon = Switch.PointerTycon
sharing Type = Switch.Type
+ sharing WordX = Switch.WordX
structure CFunction: C_FUNCTION
sharing CFunction = Runtime.CFunction
structure ChunkLabel: ID_NO_AST
@@ -63,26 +71,25 @@
index: t,
ty: Type.t}
| Cast of t * Type.t
- | Char of char
| Contents of {oper: t,
ty: Type.t}
- | File (* expand by codegen into string constant *)
+ | File (* expanded by codegen into string constant *)
| Frontier
| GCState
| Global of Global.t
- | Int of int
+ | Int of IntX.t
| Label of Label.t
| Line (* expand by codegen into int constant *)
| Offset of {base: t,
offset: int,
ty: Type.t}
- | Real of string
+ | Real of RealX.t
| Register of Register.t
| SmallIntInf of word
| StackOffset of {offset: int,
ty: Type.t}
| StackTop
- | Word of Word.t
+ | Word of WordX.t
val equals: t * t -> bool
val interfere: t * t -> bool
@@ -247,7 +254,7 @@
maxFrameSize: int,
objectTypes: ObjectType.t vector,
profileInfo: ProfileInfo.t,
- reals: (Global.t * string) list,
+ reals: (Global.t * RealX.t) list,
strings: (Global.t * string) list}
val frameSize: t * FrameInfo.t -> int
1.9 +64 -62 mlton/mlton/backend/mtype.fun
Index: mtype.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/mtype.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mtype.fun 14 May 2003 02:50:10 -0000 1.8
+++ mtype.fun 23 Jun 2003 04:58:56 -0000 1.9
@@ -10,79 +10,88 @@
open S
-datatype dest =
- Char
- | Double
- | Int
+datatype t =
+ Int of IntSize.t
| Pointer
- | Uint
+ | Real of RealSize.t
+ | Word of WordSize.t
-datatype t = T of {dest: dest}
+datatype dest = datatype t
-fun dest (T {dest, ...}) = dest
+fun dest t = t
-fun toString t =
- case dest t of
- Char => "Char"
- | Double => "Double"
- | Int => "Int"
- | Pointer => "Pointer"
- | Uint => "Word"
+val isReal =
+ fn Real _ => true
+ | _ => false
+
+fun memo f =
+ let
+ val int = IntSize.memoize (f o Int)
+ val pointer = f Pointer
+ val real = RealSize.memoize (f o Real)
+ val word = WordSize.memoize (f o Word)
+ in
+ fn Int s => int s
+ | Pointer => pointer
+ | Real s => real s
+ | Word s => word s
+ end
+
+val toString =
+ memo
+ (fn t =>
+ case t of
+ Int s => concat ["Int", IntSize.toString s]
+ | Pointer => "Pointer"
+ | Real s => concat ["Real", RealSize.toString s]
+ | Word s => concat ["Word", WordSize.toString s])
val layout = Layout.str o toString
-fun equals (t, t') = dest t = dest t'
+fun equals (t, t') = t = t'
val equals =
Trace.trace2 ("Runtime.Type.equals", layout, layout, Bool.layout) equals
-local
- fun new dest = T {dest = dest}
-in
- val char = new Char
- val double = new Double
- val int = new Int
- val pointer = new Pointer
- val uint = new Uint
-end
-
-val all = [char, double, int, pointer, uint]
+val int = IntSize.memoize Int
+val pointer = Pointer
+val real = RealSize.memoize Real
+val word = WordSize.memoize Word
+
+val all =
+ List.map (IntSize.all, int)
+ @ [pointer]
+ @ List.map (RealSize.all, real)
+ @ List.map (WordSize.all, word)
+
+val bool = int IntSize.I32
+
+val defaultInt = int IntSize.default
+
+val defaultReal = real RealSize.default
+
+val defaultWord = word WordSize.default
-fun memo f =
- let val all = List.revMap (all, fn t => (t, f t))
- in fn t => #2 (valOf (List.peek (all, fn (t', _) => equals (t, t'))))
- end
-
-val bool = int
-val label = uint
-val word = uint
+val label = word WordSize.W32
fun isPointer t =
- case dest t of
+ case t of
Pointer => true
| _ => false
-
-local
- val byte: int = 1
- val word: int = 4
- val double: int = 8
-in
- fun size t =
- case dest t of
- Char => byte
- | Double => double
- | Int => word
- | Pointer => word
- | Uint => word
-end
+
+fun size (t: t): int =
+ case t of
+ Int s => IntSize.bytes s
+ | Pointer => 4
+ | Real s => RealSize.bytes s
+ | Word s => WordSize.bytes s
fun name t =
- case dest t of
- Char => "C"
- | Double => "D"
- | Int => "I"
+ case t of
+ Int s => concat ["I", IntSize.toString s]
| Pointer => "P"
- | Uint => "U"
+ | Real s => concat ["R", RealSize.toString s]
+ | Word s => concat ["W", WordSize.toString s]
local
fun align a b =
@@ -95,14 +104,7 @@
in
val align4 = align 4
val align8 = align 8
+ val align: t * int -> int = fn (ty, n) => align (size ty) n
end
-
-fun align (ty: t, n: int): int =
- case dest ty of
- Char => n
- | Double => align8 n
- | Int => align4 n
- | Pointer => align4 n
- | Uint => align4 n
end
1.6 +16 -11 mlton/mlton/backend/mtype.sig
Index: mtype.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/mtype.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mtype.sig 24 Apr 2003 20:50:51 -0000 1.5
+++ mtype.sig 23 Jun 2003 04:58:56 -0000 1.6
@@ -9,6 +9,9 @@
signature MTYPE_STRUCTS =
sig
+ structure IntSize: INT_SIZE
+ structure RealSize: REAL_SIZE
+ structure WordSize: WORD_SIZE
end
signature MTYPE =
@@ -18,30 +21,32 @@
type t
datatype dest =
- Char
- | Double
- | Int
+ Int of IntSize.t
| Pointer
- | Uint
+ | Real of RealSize.t
+ | Word of WordSize.t
val align4: int -> int
val align8: int -> int
- val align: t * int -> int (* align an address *)
+ val align: t * int -> int (* align an address *)
val all: t list
val bool: t (* same as int *)
- val char: t
+ val defaultInt: t
+ val defaultReal: t
+ val defaultWord: t
val dest: t -> dest
- val double: t
val equals: t * t -> bool
- val int: t
+ val int: IntSize.t -> t
val isPointer: t -> bool
+ val isReal: t -> bool
val label: t (* same as uint *)
val layout: t -> Layout.t
val memo: (t -> 'a) -> (t -> 'a)
- val name: t -> string (* one letter abbreviation: CDIPUV *)
+ (* name: R{32,64} I{8,16,32,64] P W[8,16,32] *)
+ val name: t -> string
val pointer: t
+ val real: RealSize.t -> t
val size: t -> int (* bytes *)
val toString: t -> string
- val uint: t
- val word: t (* synonym for uint *)
+ val word: WordSize.t -> t
end
1.27 +3 -1 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- profile.fun 25 Feb 2003 20:44:22 -0000 1.26
+++ profile.fun 23 Jun 2003 04:58:56 -0000 1.27
@@ -511,7 +511,9 @@
{args = (Vector.new2
(Operand.GCState,
Operand.word
- (Word.fromInt bytesAllocated))),
+ (WordX.make
+ (Word.fromInt bytesAllocated,
+ WordSize.default)))),
func = func,
return = SOME newLabel}
val sourceSeq = Push.toSources pushes
1.15 +10 -9 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- representation.fun 24 Apr 2003 20:50:51 -0000 1.14
+++ representation.fun 23 Jun 2003 04:58:57 -0000 1.15
@@ -16,9 +16,11 @@
local
open Rssa
in
+ structure IntSize = IntSize
structure ObjectType = ObjectType
structure PointerTycon = PointerTycon
structure Runtime = Runtime
+ structure WordSize = WordSize
end
structure S = Ssa
local
@@ -28,6 +30,8 @@
structure Tycon = Tycon
end
+datatype z = datatype WordSize.t
+
structure TyconRep =
struct
datatype t =
@@ -313,7 +317,7 @@
if isTagged
then {mutable = false,
offset = 0,
- ty = R.Type.int} :: components
+ ty = R.Type.int IntSize.default} :: components
else components
val components =
Vector.fromArray
@@ -525,22 +529,20 @@
then new ()
else
case S.Type.dest ty of
- Char => R.Type.string
- | Word => R.Type.wordVector
- | Word8 => R.Type.string
+ Word W8 => R.Type.word8Vector
+ | Word W32 => R.Type.wordVector
| _ => new ()
end
datatype z = datatype S.Type.dest
in
case S.Type.dest t of
Array t => SOME (array {mutable = true, ty = t})
- | Char => SOME R.Type.char
| Datatype tycon => convertDatatype tycon
- | Int => SOME R.Type.int
+ | Int s => SOME (R.Type.int s)
| IntInf => SOME R.Type.intInf
| Pointer => SOME R.Type.cpointer
| PreThread => SOME R.Type.thread
- | Real => SOME R.Type.real
+ | Real s => SOME (R.Type.real s)
| Ref t =>
SOME (pointer {fin = fn r => setRefRep (t, r),
isNormal = true,
@@ -572,8 +574,7 @@
SOME (R.Type.pointer pt)
end
else NONE)
- | Word => SOME R.Type.word
- | Word8 => SOME R.Type.char
+ | Word s => SOME (R.Type.word s)
end))
val toRtype =
Trace.trace
1.8 +4 -1 mlton/mlton/backend/representation.sig
Index: representation.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- representation.sig 7 Dec 2002 02:21:52 -0000 1.7
+++ representation.sig 23 Jun 2003 04:58:57 -0000 1.8
@@ -9,8 +9,11 @@
signature REPRESENTATION_STRUCTS =
sig
- structure Ssa: SSA
structure Rssa: RSSA
+ structure Ssa: SSA
+ sharing Rssa.IntSize = Ssa.IntSize
+ sharing Rssa.RealSize = Ssa.RealSize
+ sharing Rssa.WordSize = Ssa.WordSize
end
signature REPRESENTATION =
1.33 +54 -47 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- rssa.fun 14 May 2003 02:50:10 -0000 1.32
+++ rssa.fun 23 Jun 2003 04:58:57 -0000 1.33
@@ -16,6 +16,8 @@
structure GCField = GCField
end
+datatype z = datatype WordSize.t
+
structure Operand =
struct
datatype t =
@@ -37,41 +39,34 @@
| Var of {var: Var.t,
ty: Type.t}
- val char = Const o Const.fromChar
- val int = Const o Const.fromInt
- val word = Const o Const.fromWord
- fun bool b = Cast (int (if b then 1 else 0), Type.bool)
+ val int = Const o Const.int
+ val real = Const o Const.real
+ val word = Const o Const.word
+
+ fun bool b = Cast (int (IntX.make (IntInf.fromInt (if b then 1 else 0),
+ IntSize.default)),
+ Type.bool)
val ty =
fn ArrayOffset {ty, ...} => ty
| Cast (_, ty) => ty
| Const c =>
let
- datatype z = datatype Const.Node.t
+ datatype z = datatype Const.t
in
- case Const.node c of
- Char _ => Type.char
- | Int _ => Type.int
+ case c of
+ Int i => Type.int (IntX.size i)
| IntInf _ => Type.intInf
- | Real _ => Type.real
- | String _ => Type.string
- | Word _ =>
- let
- val ty = Const.ty c
- in
- if Const.Type.equals (ty, Const.Type.word)
- then Type.word
- else if Const.Type.equals (ty, Const.Type.word8)
- then Type.char
- else Error.bug "strange word"
- end
+ | Real r => Type.real (RealX.size r)
+ | Word w => Type.word (WordX.size w)
+ | Word8Vector _ => Type.word8Vector
end
- | EnsuresBytesFree => Type.word
+ | EnsuresBytesFree => Type.word WordSize.default
| File => Type.cpointer
| GCState => Type.cpointer
- | Line => Type.int
+ | Line => Type.int IntSize.default
| Offset {ty, ...} => ty
- | PointerTycon _ => Type.word
+ | PointerTycon _ => Type.word WordSize.default
| Runtime z => Type.fromRuntime (GCField.ty z)
| SmallIntInf _ => Type.IntInf
| Var {ty, ...} => ty
@@ -139,10 +134,12 @@
small: word -> 'a}): 'a =
case z of
Const c =>
- (case Const.node c of
- Const.Node.Word w =>
- if w <= 0w512 (* pretty arbitrary *)
- then small w
+ (case c of
+ Const.Word w =>
+ (* 512 is pretty arbitrary *)
+ if WordX.<= (w, WordX.fromLargeInt (IntInf.fromInt 512,
+ WordX.size w))
+ then small (WordX.toWord w)
else big z
| _ => Error.bug "strange numBytes")
| _ => big z
@@ -328,7 +325,7 @@
val bug =
CCall {args = (Vector.new1
(Operand.Const
- (Const.fromString "control shouldn't reach here"))),
+ (Const.string "control shouldn't reach here"))),
func = CFunction.bug,
return = NONE}
@@ -394,17 +391,22 @@
fun clear (t: t): unit =
foreachDef (t, Var.clear o #1)
- fun ifBool (test, {falsee, truee}) =
- Switch (Switch.Int
- {cases = Vector.new2 ((0, falsee), (1, truee)),
- default = NONE,
- test = test})
-
- fun ifInt (test, {falsee, truee}) =
- Switch (Switch.Int
- {cases = Vector.new1 (0, falsee),
- default = SOME truee,
- test = test})
+ local
+ fun make i = IntX.make (IntInf.fromInt i, IntSize.default)
+ in
+ fun ifBool (test, {falsee, truee}) =
+ Switch (Switch.Int
+ {cases = Vector.new2 ((make 0, falsee), (make 1, truee)),
+ default = NONE,
+ size = IntSize.default,
+ test = test})
+ fun ifInt (test, {falsee, truee}) =
+ Switch (Switch.Int
+ {cases = Vector.new1 (make 0, falsee),
+ default = SOME truee,
+ size = IntSize.default,
+ test = test})
+ end
end
structure Kind =
@@ -1030,8 +1032,8 @@
{from = Operand.ty z,
fromInt = (case z of
Const c =>
- (case Const.node c of
- Const.Node.Int n => SOME n
+ (case c of
+ Const.Int n => SOME n
| _ => NONE)
| _ => NONE),
to = ty,
@@ -1054,7 +1056,7 @@
val _ = checkOperand base
val _ = checkOperand index
in
- Type.equals (Operand.ty index, Type.int)
+ Type.equals (Operand.ty index, Type.defaultInt)
andalso
case Operand.ty base of
Type.CPointer => true (* needed for card marking *)
@@ -1072,8 +1074,13 @@
val {offset, ty = ty', ...} =
Vector.sub (components, 0)
in
- offset = 0
- andalso Type.equals (ty, ty')
+ 0 = offset
+ andalso (Type.equals (ty, ty')
+ orelse
+ (* Get a word from a word8 array.*)
+ (Type.equals (ty, Type.word W32)
+ andalso
+ Type.equals (ty', Type.word W8)))
end
| _ => false)
| _ => false
@@ -1091,12 +1098,12 @@
Type.EnumPointers {enum, pointers} =>
0 = Vector.length enum
andalso
- ((* Vector_fromArray header update. *)
+ ((* Array_toVector header update. *)
(offset = Runtime.headerOffset
- andalso Type.equals (ty, Type.word))
+ andalso Type.equals (ty, Type.defaultWord))
orelse
(offset = Runtime.arrayLengthOffset
- andalso Type.equals (ty, Type.int))
+ andalso Type.equals (ty, Type.defaultInt))
orelse
Vector.forall
(pointers, fn p =>
1.25 +10 -6 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- rssa.sig 23 Jan 2003 03:34:36 -0000 1.24
+++ rssa.sig 23 Jun 2003 04:58:57 -0000 1.25
@@ -15,12 +15,15 @@
structure Const: CONST
structure Func: HASH_ID
structure Handler: HANDLER
- sharing Handler.Label = Label
structure ProfileExp: PROFILE_EXP
- sharing ProfileExp.SourceInfo = SourceInfo
structure Return: RETURN
- sharing Return.Handler = Handler
structure Var: VAR
+ sharing Handler = Return.Handler
+ sharing IntX = Const.IntX
+ sharing Label = Handler.Label
+ sharing RealX = Const.RealX
+ sharing SourceInfo = ProfileExp.SourceInfo
+ sharing WordX = Const.WordX
end
signature RSSA =
@@ -28,9 +31,11 @@
include RSSA_STRUCTS
structure Switch: SWITCH
+ sharing IntX = Switch.IntX
sharing Label = Switch.Label
sharing PointerTycon = Switch.PointerTycon
sharing Type = Switch.Type
+ sharing WordX = Switch.WordX
structure CFunction: C_FUNCTION
sharing CFunction = Runtime.CFunction
@@ -65,12 +70,11 @@
val caseBytes: t * {big: t -> 'a,
small: word -> 'a} -> 'a
val cast: t * Type.t -> t
- val char: char -> t
- val int: int -> t
+ val int: IntX.t -> t
val layout: t -> Layout.t
val foreachVar: t * (Var.t -> unit) -> unit
val ty: t -> Type.t
- val word: word -> t
+ val word: WordX.t -> t
end
sharing Operand = Switch.Use
1.14 +5 -5 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- runtime.fun 14 May 2003 02:50:10 -0000 1.13
+++ runtime.fun 23 Jun 2003 04:58:57 -0000 1.14
@@ -9,7 +9,7 @@
open S
-structure Type = Mtype ()
+structure Type = Mtype (S)
structure CFunction = CFunction (structure Type = Type)
@@ -32,15 +32,15 @@
val equals: t * t -> bool = op =
val ty =
- fn CanHandle => Type.int
+ fn CanHandle => Type.defaultInt
| CardMap => Type.pointer
| CurrentThread => Type.pointer
- | ExnStack => Type.word
+ | ExnStack => Type.defaultWord
| Frontier => Type.pointer
| Limit => Type.pointer
| LimitPlusSlop => Type.pointer
- | MaxFrameSize => Type.word
- | SignalIsPending => Type.int
+ | MaxFrameSize => Type.defaultWord
+ | SignalIsPending => Type.defaultInt
| StackBottom => Type.pointer
| StackLimit => Type.pointer
| StackTop => Type.pointer
1.23 +6 -0 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- runtime.sig 14 May 2003 02:50:10 -0000 1.22
+++ runtime.sig 23 Jun 2003 04:58:57 -0000 1.23
@@ -10,6 +10,9 @@
signature RUNTIME_STRUCTS =
sig
+ structure IntSize: INT_SIZE
+ structure RealSize: REAL_SIZE
+ structure WordSize: WORD_SIZE
end
signature RUNTIME =
@@ -17,6 +20,9 @@
include RUNTIME_STRUCTS
structure Type: MTYPE
+ sharing IntSize = Type.IntSize
+ sharing RealSize = Type.RealSize
+ sharing WordSize = Type.WordSize
structure CFunction: C_FUNCTION
sharing Type = CFunction.Type
structure GCField:
1.17 +5 -5 mlton/mlton/backend/signal-check.fun
Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- signal-check.fun 12 Feb 2003 05:11:27 -0000 1.16
+++ signal-check.fun 23 Jun 2003 04:58:57 -0000 1.17
@@ -79,10 +79,9 @@
Vector.new1
(Statement.PrimApp
{args = Vector.new2 (Operand.Cast
- (Operand.Runtime
- Runtime.GCField.Limit,
- Type.Word),
- Operand.word 0w0),
+ (Operand.Runtime Runtime.GCField.Limit,
+ Type.defaultWord),
+ Operand.word (WordX.zero WordSize.default)),
dst = SOME (res, Type.bool),
prim = Prim.eq})
val compareTransfer =
@@ -106,7 +105,8 @@
transfer =
Transfer.CCall
{args = Vector.new5 (Operand.GCState,
- Operand.word 0w0,
+ Operand.word (WordX.zero
+ WordSize.default),
Operand.bool false,
Operand.File,
Operand.Line),
1.15 +1 -0 mlton/mlton/backend/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- sources.cm 20 Jan 2003 20:38:31 -0000 1.14
+++ sources.cm 23 Jun 2003 04:58:57 -0000 1.15
@@ -17,6 +17,7 @@
is
../../lib/mlton/sources.cm
+../ast/sources.cm
../atoms/sources.cm
../control/sources.cm
../ssa/sources.cm
1.40 +135 -128 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- ssa-to-rssa.fun 14 May 2003 02:50:10 -0000 1.39
+++ ssa-to-rssa.fun 23 Jun 2003 04:58:57 -0000 1.40
@@ -23,24 +23,13 @@
structure GCField = GCField
end
+datatype z = datatype WordSize.t
+
structure CFunction =
struct
open CFunction
local
- fun make name = vanilla {name = name,
- returnTy = SOME Type.double}
- in
- val cosh = make "cosh"
- val sinh = make "sinh"
- val tanh = make "tanh"
- val pow = make "pow"
- val copysign = make "copysign"
- val frexp = make "frexp"
- val modf = make "modf"
- end
-
- local
fun make (name, i) =
CFunction.make {bytesNeeded = SOME i,
ensuresBytesFree = false,
@@ -69,7 +58,7 @@
local
fun make name = vanilla {name = name,
- returnTy = SOME Type.int}
+ returnTy = SOME Type.defaultInt}
in
val intInfCompare = make "IntInf_compare"
val intInfEqual = make "IntInf_equal"
@@ -200,15 +189,15 @@
(* varInt is set for variables that are constant integers. It is used
* so that we can precompute array numBytes when numElts is known.
*)
- val {get = varInt: Var.t -> int option,
+ val {get = varInt: Var.t -> IntX.t option,
set = setVarInt, ...} =
Property.getSetOnce (Var.plist, Property.initConst NONE)
val _ =
Vector.foreach (globals, fn S.Statement.T {var, exp, ...} =>
case exp of
S.Exp.Const c =>
- (case Const.node c of
- Const.Node.Int n =>
+ (case c of
+ Const.Int n =>
Option.app (var, fn x =>
setVarInt (x, SOME n))
| _ => ())
@@ -296,10 +285,16 @@
val cases =
QuickSort.sortVector
(cases, fn ((i, _), (i', _)) => i <= i')
+ val cases =
+ Vector.map (cases, fn (i, l) =>
+ (IntX.make (IntInf.fromInt i,
+ IntSize.default),
+ l))
in
- Switch (Switch.Int {test = test,
- cases = cases,
- default = default})
+ Switch (Switch.Int {cases = cases,
+ default = default,
+ size = IntSize.default,
+ test = test})
end
end
end
@@ -446,7 +441,7 @@
Control.FirstWord =>
([], Offset {base = test,
offset = tagOffset,
- ty = Type.int})
+ ty = Type.defaultInt})
| Control.Header =>
let
val headerOffset = ~4
@@ -455,14 +450,14 @@
PrimApp {args = (Vector.new2
(Offset {base = test,
offset = headerOffset,
- ty = Type.word},
- Operand.word 0w1)),
- dst = SOME (tagVar, Type.word),
- prim = Prim.word32Rshift}
+ ty = Type.defaultWord},
+ Operand.word (WordX.one WordSize.default))),
+ dst = SOME (tagVar, Type.defaultWord),
+ prim = Prim.wordRshift WordSize.default}
in
- ([s], Cast (Var {ty = Type.word,
+ ([s], Cast (Var {ty = Type.defaultWord,
var = tagVar},
- Type.int))
+ Type.defaultInt))
end
| HeaderIndirect =>
Error.bug "HeaderIndirect unimplemented"
@@ -508,27 +503,23 @@
| TyconRep.Void => ([], prim ())
end
fun translateCase ({test: Var.t,
- cases: Label.t S.Cases.t,
+ cases: S.Cases.t,
default: Label.t option})
: Statement.t list * Transfer.t =
let
fun id x = x
- fun simple (l, make, branch, le) =
+ fun simple (s, cs, make, branch, le) =
([],
Switch
- (make {test = varOp test,
- cases = (QuickSort.sortVector
- (Vector.map (l, fn (i, j) => (branch i, j)),
+ (make {cases = (QuickSort.sortVector
+ (Vector.map (cs, fn (i, j) => (branch i, j)),
fn ((i, _), (i', _)) => le (i, i'))),
- default = default}))
+ default = default,
+ size = s,
+ test = varOp test}))
in
case cases of
- S.Cases.Char cs => simple (cs, Switch.Char, id, Char.<=)
- | S.Cases.Int cs => simple (cs, Switch.Int, id, Int.<=)
- | S.Cases.Word cs => simple (cs, Switch.Word, id, Word.<=)
- | S.Cases.Word8 cs =>
- simple (cs, Switch.Char, Word8.toChar, Char.<=)
- | S.Cases.Con cases =>
+ S.Cases.Con cases =>
(case (Vector.length cases, default) of
(0, NONE) => ([], Transfer.bug)
| _ =>
@@ -542,6 +533,8 @@
testRep = tyconRep tycon}
else Error.bug "strange type in case"
end)
+ | S.Cases.Int (s, cs) => simple (s, cs, Switch.Int, id, IntX.<=)
+ | S.Cases.Word (s, cs) => simple (s, cs, Switch.Word, id, WordX.<=)
end
val {get = labelInfo: (Label.t ->
{args: (Var.t * S.Type.t) vector,
@@ -702,18 +695,16 @@
val c = Operand.Const
in
case t of
- Type.Char =>
- c (Const.fromChar #"\000")
- | Type.CPointer => Error.bug "bogus CPointer"
+ Type.CPointer => Error.bug "bogus CPointer"
| Type.EnumPointers (ep as {enum, ...}) =>
- Operand.Cast (Operand.int 1, t)
+ Operand.Cast (Operand.int (IntX.one IntSize.default), t)
| Type.ExnStack => Error.bug "bogus ExnStack"
- | Type.Int => c (Const.fromInt 0)
+ | Type.Int s => c (Const.int (IntX.zero s))
| Type.IntInf => SmallIntInf 0wx1
| Type.Label _ => Error.bug "bogus Label"
| Type.MemChunk _ => Error.bug "bogus MemChunk"
- | Type.Real => c (Const.fromReal "0.0")
- | Type.Word => c (Const.fromWord 0w0)
+ | Type.Real s => c (Const.real (RealX.make ("0.0", s)))
+ | Type.Word s => c (Const.word (WordX.zero s))
end
fun translateStatementsTransfer (statements, ss, transfer) =
let
@@ -767,8 +758,12 @@
{dst = valOf var,
size = size + Runtime.normalHeaderSize,
stores = (Vector.concat
- [Vector.new1 {offset = tagOffset,
- value = Operand.int n},
+ [Vector.new1
+ {offset = tagOffset,
+ value = (Operand.int
+ (IntX.make
+ (IntInf.fromInt n,
+ IntSize.default)))},
makeStores (ys, offsets)]),
ty = ty,
tycon = tycon})
@@ -782,7 +777,11 @@
(case conRep con of
ConRep.Void => none ()
| ConRep.IntAsTy {int, ty} =>
- move (Operand.Cast (Operand.int int, ty))
+ move (Operand.Cast
+ (Operand.int
+ (IntX.make (IntInf.fromInt int,
+ IntSize.default)),
+ ty))
| ConRep.TagTuple {rep, tag} =>
if !Control.variant = Control.FirstWord
then allocateTagged (tag, args, rep)
@@ -812,7 +811,7 @@
move (Operand.Offset
{base = varOp (a 0),
offset = Runtime.arrayLengthOffset,
- ty = Type.int})
+ ty = Type.defaultInt})
fun arrayOffset (ty: Type.t): Operand.t =
ArrayOffset {base = varOp (a 0),
index = varOp (a 1),
@@ -836,14 +835,18 @@
val res = Var.newNoname ()
in
[Statement.PrimApp
- {args = Vector.new2 (canHandle,
- Operand.int n),
- dst = SOME (res, Type.int),
- prim = Prim.intAdd},
+ {args = (Vector.new2
+ (canHandle,
+ (Operand.int
+ (IntX.make
+ (IntInf.fromInt n,
+ IntSize.default))))),
+ dst = SOME (res, Type.defaultInt),
+ prim = Prim.intAdd IntSize.default},
Statement.Move
{dst = canHandle,
src = Operand.Var {var = res,
- ty = Type.int}}]
+ ty = Type.defaultInt}}]
end
fun ccallGen
{args: Operand.t vector,
@@ -923,21 +926,24 @@
val ss =
(PrimApp
{args = (Vector.new2
- (Operand.Cast (addr, Type.Word),
+ (Operand.Cast (addr, Type.defaultWord),
Operand.word
- (Word.fromInt
- (!Control.cardSizeLog2)))),
- dst = SOME (index, Type.int),
- prim = Prim.word32Rshift})
+ (WordX.make
+ (Word.fromInt
+ (!Control.cardSizeLog2),
+ WordSize.default)))),
+ dst = SOME (index, Type.defaultInt),
+ prim = Prim.wordRshift WordSize.default})
:: (Move
{dst = (Operand.ArrayOffset
{base = (Operand.Runtime
GCField.CardMap),
- index = Operand.Var {ty = Type.int,
- var = index},
- ty = Type.char}),
- src = Operand.char #"\001"})
- :: assign
+ index = (Operand.Var
+ {ty = Type.defaultInt,
+ var = index}),
+ ty = Type.word W8}),
+ src = Operand.word (WordX.one W8)})
+ :: assign
:: ss
in
loop (i - 1, prefix ss, t)
@@ -948,8 +954,9 @@
val src = varOp (a 2)
val arrayOp = varOp (a 0)
val temp = Var.newNoname ()
- val tempOp = Operand.Var {var = temp,
- ty = Type.word}
+ val tempOp =
+ Operand.Var {var = temp,
+ ty = Type.defaultWord}
val addr = Var.newNoname ()
val mc =
case Type.dePointer (Operand.ty arrayOp) of
@@ -965,18 +972,20 @@
(PrimApp
{args = Vector.new2
(Operand.Cast (varOp (a 1),
- Type.Word),
+ Type.defaultWord),
Operand.word
- (Word.fromInt (Type.size ty))),
- dst = SOME (temp, Type.word),
- prim = Prim.word32Mul})
+ (WordX.make
+ (Word.fromInt (Type.size ty),
+ WordSize.default))),
+ dst = SOME (temp, Type.defaultWord),
+ prim = Prim.wordMul WordSize.default})
:: (PrimApp
{args = (Vector.new2
(Operand.Cast (arrayOp,
- Type.Word),
+ Type.defaultWord),
tempOp)),
dst = SOME (addr, Type.MemChunk mc),
- prim = Prim.word32Add})
+ prim = Prim.wordAdd WordSize.default})
:: ss
val assign =
Move {dst = (Operand.Offset
@@ -1006,19 +1015,40 @@
case Prim.name prim of
Array_array =>
array (Operand.Var {var = a 0,
- ty = Type.int})
+ ty = Type.defaultInt})
| Array_length => arrayOrVectorLength ()
| Array_sub =>
(case targ () of
NONE => none ()
| SOME t => sub t)
+ | Array_toVector =>
+ let
+ val array = varOp (a 0)
+ val vecTy = valOf (toRtype ty)
+ val pt =
+ case Type.dePointer vecTy of
+ NONE => Error.bug "strange Array_toVector"
+ | SOME pt => pt
+ in
+ loop
+ (i - 1,
+ Move
+ {dst = (Offset
+ {base = array,
+ offset = Runtime.headerOffset,
+ ty = Type.defaultWord}),
+ src = PointerTycon pt}
+ :: Bind {isMutable = false,
+ oper = (Operand.Cast
+ (array, vecTy)),
+ var = valOf var}
+ :: ss,
+ t)
+ end
| Array_update =>
(case targ () of
NONE => none ()
| SOME ty => arrayUpdate ty)
- | Byte_byteToChar => cast ()
- | Byte_charToByte => cast ()
- | C_CS_charArrayToWord8Array => cast ()
| FFI name =>
if Option.isNone (Prim.numArgs prim)
then normal ()
@@ -1036,11 +1066,13 @@
Type.toRuntime)})
| GC_collect =>
ccall
- {args = Vector.new5 (Operand.GCState,
- Operand.int 0,
- Operand.bool true,
- Operand.File,
- Operand.Line),
+ {args = (Vector.new5
+ (Operand.GCState,
+ Operand.int (IntX.zero
+ IntSize.default),
+ Operand.bool true,
+ Operand.File,
+ Operand.Line)),
func = (CFunction.gc
{maySwitchThreads = false})}
| GC_pack =>
@@ -1057,8 +1089,6 @@
simpleCCall CFunction.intInfCompare
| IntInf_equal =>
simpleCCall CFunction.intInfEqual
- | IntInf_fromVector => cast ()
- | IntInf_fromWord => cast ()
| IntInf_gcd => simpleCCall CFunction.intInfGcd
| IntInf_lshift =>
simpleCCall CFunction.intInfLshift
@@ -1081,16 +1111,10 @@
| MLton_bug => simpleCCall CFunction.bug
| MLton_eq =>
(case targ () of
- NONE => move (Operand.int 1)
+ NONE => move (Operand.int
+ (IntX.defaultInt 1))
| SOME _ => normal ())
| MLton_size => simpleCCall CFunction.size
- | Real_Math_cosh => simpleCCall CFunction.cosh
- | Real_Math_sinh => simpleCCall CFunction.sinh
- | Real_Math_tanh => simpleCCall CFunction.tanh
- | Real_Math_pow => simpleCCall CFunction.pow
- | Real_copysign => simpleCCall CFunction.copysign
- | Real_frexp => simpleCCall CFunction.frexp
- | Real_modf => simpleCCall CFunction.modf
| Ref_assign =>
(case targ () of
NONE => none ()
@@ -1106,8 +1130,6 @@
allocate
(Vector.new1 (a 0),
refRep (Vector.sub (targs, 0)))
- | String_fromWord8Vector => cast ()
- | String_toWord8Vector => cast ()
| Thread_atomicBegin =>
(* assert (s->canHandle >= 0);
* s->canHandle++;
@@ -1125,24 +1147,27 @@
Vector.new2
(Statement.PrimApp
{args = Vector.new2 (a, b),
- dst = SOME (tmp, Type.word),
+ dst = SOME (tmp,
+ Type.defaultWord),
prim = prim},
Statement.Move
{dst = (Operand.Cast
(Operand.Runtime dst,
- Type.Word)),
+ Type.defaultWord)),
src = (Operand.Var
{var = tmp,
- ty = Type.word})})
+ ty = Type.defaultWord})})
end
datatype z = datatype GCField.t
val statements =
doit (Limit,
- Prim.word32Sub,
+ Prim.wordSub WordSize.default,
Operand.Runtime LimitPlusSlop,
Operand.word
- (Word.fromInt
- Runtime.limitSlop))
+ (WordX.make
+ (Word.fromInt
+ Runtime.limitSlop,
+ WordSize.default)))
val l' =
newBlock
{args = Vector.new0 (),
@@ -1174,8 +1199,10 @@
(Statement.Move
{dst = (Operand.Cast
(Operand.Runtime Limit,
- Type.Word)),
- src = Operand.word 0w0})
+ Type.defaultWord)),
+ src =
+ Operand.word
+ (WordX.zero WordSize.default)})
val l'' =
newBlock
{args = Vector.new0 (),
@@ -1217,30 +1244,6 @@
(varOp (a 0),
Operand.EnsuresBytesFree)),
func = CFunction.threadSwitchTo}
- | Vector_fromArray =>
- let
- val array = varOp (a 0)
- val vecTy = valOf (toRtype ty)
- val pt =
- case Type.dePointer vecTy of
- NONE => Error.bug "strange Vector_fromArray"
- | SOME pt => pt
- in
- loop
- (i - 1,
- Move
- {dst = (Offset
- {base = array,
- offset = Runtime.headerOffset,
- ty = Type.word}),
- src = PointerTycon pt}
- :: Bind {isMutable = false,
- oper = (Operand.Cast
- (array, vecTy)),
- var = valOf var}
- :: ss,
- t)
- end
| Vector_length => arrayOrVectorLength ()
| Vector_sub =>
(case targ () of
@@ -1272,8 +1275,12 @@
func = CFunction.weakNew}
end,
none)
- | Word32_toIntX => cast ()
- | Word32_fromInt => cast ()
+ | Word_toIntInf => cast ()
+ | WordVector_toIntInf => cast ()
+ | Word8Array_subWord => sub Type.defaultWord
+ | Word8Array_updateWord =>
+ arrayUpdate Type.defaultWord
+ | Word8Vector_subWord => sub Type.defaultWord
| World_save =>
ccall {args = (Vector.new2
(Operand.GCState,
1.3 +33 -42 mlton/mlton/backend/switch.fun
Index: switch.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/switch.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- switch.fun 10 Dec 2002 21:45:49 -0000 1.2
+++ switch.fun 23 Jun 2003 04:58:57 -0000 1.3
@@ -41,14 +41,12 @@
andalso not (isRedundant {cases = cases, equals = equals})
datatype t =
- Char of {cases: (char * Label.t) vector,
- default: Label.t option,
- test: Use.t}
- | EnumPointers of {enum: Label.t,
+ EnumPointers of {enum: Label.t,
pointers: Label.t,
test: Use.t}
- | Int of {cases: (int * Label.t) vector,
+ | Int of {cases: (IntX.t * Label.t) vector,
default: Label.t option,
+ size: IntSize.t,
test: Use.t}
| Pointer of {cases: {dst: Label.t,
tag: int,
@@ -56,14 +54,15 @@
default: Label.t option,
tag: Use.t,
test: Use.t} (* of type int*)
- | Word of {cases: (word * Label.t) vector,
+ | Word of {cases: (WordX.t * Label.t) vector,
default: Label.t option,
+ size: WordSize.t,
test: Use.t}
fun layout s =
let
open Layout
- fun simple ({cases, default, test}, name, lay) =
+ fun simple ({cases, default, size, test}, name, lay) =
seq [str (concat ["switch", name, " "]),
record [("test", Use.layout test),
("default", Option.layout Label.layout default),
@@ -73,13 +72,12 @@
cases)]]
in
case s of
- Char z => simple (z, "Char", Char.layout)
- | EnumPointers {enum, pointers, test} =>
+ EnumPointers {enum, pointers, test} =>
seq [str "SwitchEP ",
record [("test", Use.layout test),
("enum", Label.layout enum),
("pointers", Label.layout pointers)]]
- | Int z => simple (z, "Int", Int.layout)
+ | Int z => simple (z, "Int", IntX.layout)
| Pointer {cases, default, tag, test} =>
seq [str "SwitchPointer ",
record [("test", Use.layout test),
@@ -92,59 +90,52 @@
("tag", Int.layout tag),
("tycon", PointerTycon.layout tycon)])
cases)]]
- | Word z => simple (z, "Word", Word.layout)
+ | Word z => simple (z, "Word", WordX.layout)
end
val allChars = Vector.tabulate (Char.numChars, Char.fromInt)
fun isOk (s, {checkUse, labelIsOk}): bool =
case s of
- Char {cases, default, test} =>
- (checkUse test
- ; (Type.equals (Use.ty test, Type.char)
- andalso (case default of
- NONE => true
- | SOME l => labelIsOk l)
- andalso Vector.forall (cases, labelIsOk o #2)
- andalso Vector.isSorted (cases, fn ((c, _), (c', _)) => c <= c')
- andalso exhaustiveAndIrredundant {all = allChars,
- cases = Vector.map (cases, #1),
- default = default,
- equals = op =}))
- | EnumPointers {enum, pointers, test, ...} =>
+ EnumPointers {enum, pointers, test, ...} =>
(checkUse test
; (labelIsOk enum
andalso labelIsOk pointers
andalso (case Use.ty test of
Type.EnumPointers _ => true
| _ => false)))
- | Int {cases, default, test} =>
+ | Int {cases, default, size, test} =>
(checkUse test
; ((case default of
NONE => true
| SOME l => labelIsOk l)
andalso Vector.forall (cases, labelIsOk o #2)
- andalso Vector.isSorted (cases, fn ((i, _), (i', _)) => i <= i')
+ andalso Vector.isSorted (cases, fn ((i, _), (i', _)) =>
+ IntX.<= (i, i'))
andalso
(case Use.ty test of
- Type.Int =>
- Option.isSome default
- andalso not (isRedundant
- {cases = cases,
- equals = fn ((i, _), (i', _)) => i = i'})
- | Type.EnumPointers {enum, pointers} =>
+ Type.EnumPointers {enum, pointers} =>
0 = Vector.length pointers
andalso
exhaustiveAndIrredundant
- {all = enum,
+ {all = Vector.map (enum, fn i =>
+ IntX.make (IntInf.fromInt i, size)),
cases = Vector.map (cases, #1),
default = default,
- equals = op =}
+ equals = IntX.equals}
+ | Type.Int s =>
+ IntSize.equals (size, s)
+ andalso Option.isSome default
+ andalso not (isRedundant
+ {cases = cases,
+ equals = fn ((i, _), (i', _)) =>
+ IntX.equals (i, i')})
+
| _ => false)))
| Pointer {cases, default, tag, test} =>
(checkUse tag
; checkUse test
- ; (Type.equals (Use.ty tag, Type.int)
+ ; (Type.equals (Use.ty tag, Type.defaultInt)
andalso (case default of
NONE => true
| SOME l => labelIsOk l)
@@ -163,22 +154,23 @@
default = default,
equals = PointerTycon.equals}
| _ => false))
- | Word {cases, default, test} =>
+ | Word {cases, default, size, test} =>
(checkUse test
- ; (Type.equals (Use.ty test, Type.word)
+ ; (Type.equals (Use.ty test, Type.word size)
andalso (case default of
NONE => false
| SOME l => labelIsOk l)
andalso Vector.forall (cases, labelIsOk o #2)
- andalso Vector.isSorted (cases, fn ((w, _), (w', _)) => w <= w')
+ andalso Vector.isSorted (cases, fn ((w, _), (w', _)) =>
+ WordX.<= (w, w'))
andalso
not (isRedundant
{cases = cases,
- equals = fn ((w, _), (w', _)) => w = w'})))
+ equals = fn ((w, _), (w', _)) => WordX.equals (w, w')})))
fun foldLabelUse (s: t, a: 'a, {label, use}): 'a =
let
- fun simple {cases, default, test} =
+ fun simple {cases, default, size, test} =
let
val a = use (test, a)
val a = Option.fold (default, a, label)
@@ -189,8 +181,7 @@
end
in
case s of
- Char z => simple z
- | EnumPointers {enum, pointers, test} =>
+ EnumPointers {enum, pointers, test} =>
let
val a = use (test, a)
val a = label (enum, a)
1.3 +5 -7 mlton/mlton/backend/switch.sig
Index: switch.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/switch.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- switch.sig 10 Dec 2002 21:45:49 -0000 1.2
+++ switch.sig 23 Jun 2003 04:58:57 -0000 1.3
@@ -25,16 +25,13 @@
include SWITCH_STRUCTS
datatype t =
- Char of {(* Cases are in increasing order of char. *)
- cases: (char * Label.t) vector,
- default: Label.t option,
- test: Use.t}
- | EnumPointers of {enum: Label.t,
+ EnumPointers of {enum: Label.t,
pointers: Label.t,
test: Use.t}
| Int of {(* Cases are in increasing order of int. *)
- cases: (int * Label.t) vector,
+ cases: (IntX.t * Label.t) vector,
default: Label.t option,
+ size: IntSize.t,
test: Use.t}
| Pointer of {(* Cases are in increasing order of tycon. *)
cases: {dst: Label.t,
@@ -44,8 +41,9 @@
tag: Use.t, (* of type int *)
test: Use.t}
| Word of {(* Cases are in increasing order of word. *)
- cases: (word * Label.t) vector,
+ cases: (WordX.t * Label.t) vector,
default: Label.t option,
+ size: WordSize.t,
test: Use.t}
val foldLabelUse: t * 'a * {label: Label.t * 'a -> 'a,
1.8 +1 -1 mlton/mlton/closure-convert/abstract-value.fun
Index: abstract-value.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- abstract-value.fun 18 Apr 2003 22:44:59 -0000 1.7
+++ abstract-value.fun 23 Jun 2003 04:58:58 -0000 1.8
@@ -444,7 +444,7 @@
in
r
end
- | Vector_fromArray =>
+ | Array_toVector =>
let val r = result ()
in (case (dest (oneArg ()), dest r) of
(Type _, Type _) => ()
1.27 +9 -6 mlton/mlton/closure-convert/closure-convert.fun
Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- closure-convert.fun 18 Apr 2003 22:45:00 -0000 1.26
+++ closure-convert.fun 23 Jun 2003 04:58:58 -0000 1.27
@@ -805,8 +805,7 @@
fun doit (l, f) = doCases (l, f, fn i => fn e => (i, e))
val (cases, ac) =
case cases of
- Scases.Char l => doit (l, Dexp.Char)
- | Scases.Con cases =>
+ Scases.Con cases =>
doCases
(cases, Dexp.Con,
fn Spat.T {con, arg, ...} =>
@@ -817,11 +816,15 @@
| (SOME v, SOME (arg, _)) =>
Vector.new1 (newVar arg, valueType v)
| _ => Error.bug "constructor mismatch"
- in fn body => {con = con, args = args, body = body}
+ in
+ fn body => {args = args,
+ body = body,
+ con = con}
end)
- | Scases.Int l => doit (l, Dexp.Int)
- | Scases.Word l => doit (l, Dexp.Word)
- | Scases.Word8 l => doit (l, Dexp.Word8)
+ | Scases.Int (s, cs) =>
+ doit (cs, fn cs => Dexp.Int (s, cs))
+ | Scases.Word (s, cs) =>
+ doit (cs, fn cs => Dexp.Word (s, cs))
in (Dexp.casee
{test = convertVarExp test,
ty = ty, cases = cases, default = default},
1.57 +247 -137 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- c-codegen.fun 15 May 2003 14:50:56 -0000 1.56
+++ c-codegen.fun 23 Jun 2003 04:58:58 -0000 1.57
@@ -18,6 +18,8 @@
structure ChunkLabel = ChunkLabel
structure FrameInfo = FrameInfo
structure Global = Global
+ structure IntSize = IntSize
+ structure IntX = IntX
structure Kind = Kind
structure Label = Label
structure ObjectType = ObjectType
@@ -26,6 +28,8 @@
structure ProfileInfo = ProfileInfo
structure ProfileLabel = ProfileLabel
structure Program = Program
+ structure RealSize = RealSize
+ structure RealX = RealX
structure Register = Register
structure Runtime = Runtime
structure SourceInfo = SourceInfo
@@ -33,8 +37,14 @@
structure Switch = Switch
structure Transfer = Transfer
structure Type = Type
+ structure WordSize = WordSize
+ structure WordX = WordX
end
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
+
local
open Runtime
in
@@ -58,6 +68,68 @@
val traceGotoLabel = Trace.trace ("gotoLabel", Label.layout, Unit.layout)
val overhead = "**C overhead**"
+
+structure IntX =
+ struct
+ open IntX
+
+ fun toC (i: t): string =
+ let
+ fun isPos () = i >= zero (size i)
+ fun neg () = concat ["-", String.dropPrefix (toString i, 1)]
+ fun simple s =
+ concat ["(Int", s, ")",
+ if isPos () then toString i else neg ()]
+ (* tricky writes min as a word to avoid a gcc warning. *)
+ fun tricky min =
+ if isPos ()
+ then toString i
+ else if IntX.isMin i
+ then min
+ else neg ()
+ in
+ case size i of
+ I8 => simple "8"
+ | I16 => simple "16"
+ | I32 => tricky ("0x80000000")
+ | I64 => concat ["(Int64)", tricky "0x8000000000000000"]
+ end
+ end
+
+structure RealX =
+ struct
+ open RealX
+
+ fun toC (r: t): string =
+ let
+ (* The only 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)
+ in
+ case size r of
+ R32 => concat ["(Real32)", s]
+ | R64 => s
+ end
+ end
+
+structure WordX =
+ struct
+ open WordX
+
+ fun toC (w: t): string =
+ let
+ fun simple s =
+ concat ["(Word", s, ")0x", toString w]
+ in
+ case size w of
+ W8 => simple "8"
+ | W16 => simple "16"
+ | W32 => concat ["0x", toString w]
+ end
+ end
structure C =
struct
@@ -83,29 +155,20 @@
(callNoSemi (f, xs, print)
; print ";\n")
- fun int (n: int): string =
- if n >= 0
- then Int.toString n
- else if n = Int.minInt
- then "(int)0x80000000" (* because of goofy gcc warning *)
- else concat ["-", String.dropPrefix (Int.toString n, 1)]
-
fun char (c: char) =
concat [if Char.ord c >= 0x80 then "(uchar)" else "",
"'", Char.escapeC c, "'"]
- fun word (w: Word.t) = "0x" ^ Word.toString w
-
- (* The only difference between SML reals and C floats/doubles is that
- * SML uses "~" while C uses "-".
- *)
- fun real s = String.translate (s, fn #"~" => "-" | c => String.fromChar c)
+ fun int (i: int) =
+ IntX.toC (IntX.make (IntInf.fromInt i, IntSize.default))
fun string s =
let val quote = "\""
in concat [quote, String.escapeC s, quote]
end
+ fun word (w: Word.t) = "0x" ^ Word.toString w
+
fun bug (s: string, print) =
call ("MLton_bug", [concat ["\"", String.escapeC s, "\""]], print)
@@ -142,6 +205,30 @@
fun declareProfileLabel (l, print) =
C.call ("DeclareProfileLabel", [ProfileLabel.toString l], print)
+fun declareGlobals (prefix: string, print) =
+ let
+ (* gcState can't be static because stuff in mlton-lib.c refers to
+ * it.
+ *)
+ val _ = print (concat [prefix, "struct GC_state gcState;\n"])
+ val _ =
+ List.foreach
+ (Runtime.Type.all, fn t =>
+ let
+ val s = Runtime.Type.toString t
+ in
+ print (concat [prefix, s, " global", s,
+ " [", C.int (Global.numberOfType t), "];\n"])
+ ; print (concat [prefix, s, " CReturn", Runtime.Type.name t, ";\n"])
+ end)
+ val _ =
+ print (concat [prefix, "Pointer globalPointerNonRoot [",
+ C.int (Global.numberOfNonRoot ()),
+ "];\n"])
+ in
+ ()
+ end
+
fun outputDeclarations
{additionalMainArgs: string list,
includes: string list,
@@ -152,15 +239,25 @@
rest: unit -> unit
}: unit =
let
- fun declareGlobals () =
- C.call ("Globals",
- List.map (List.map (let open Runtime.Type
- in [char, double, int, pointer, uint]
- end,
- Global.numberOfType)
- @ [Global.numberOfNonRoot ()],
- C.int),
- print)
+ fun declareLoadSaveGlobals () =
+ let
+ val _ =
+ (print "static void saveGlobals (int fd) {\n"
+ ; (List.foreach
+ (Runtime.Type.all, fn t =>
+ print (concat ["\tSaveArray (global",
+ Runtime.Type.toString t, ", fd);\n"])))
+ ; print "}\n")
+ val _ =
+ (print "static void loadGlobals (FILE *file) {\n"
+ ; (List.foreach
+ (Runtime.Type.all, fn t =>
+ print (concat ["\tLoadArray (global",
+ Runtime.Type.toString t, ", file);\n"])))
+ ; print "}\n")
+ in
+ ()
+ end
fun declareIntInfs () =
(print "BeginIntInfs\n"
; List.foreach (intInfs, fn (g, s) =>
@@ -181,14 +278,13 @@
; print "\n"))
; print "EndStrings\n")
fun declareReals () =
- (print "BeginReals\n"
- ; List.foreach (reals, fn (g, f) =>
- (C.callNoSemi ("Real",
- [C.int (Global.index g),
- C.real f],
- print)
- ; print "\n"))
- ; print "EndReals\n")
+ (print "static void real_Init() {\n"
+ ; List.foreach (reals, fn (g, r) =>
+ print (concat ["\tglobalReal",
+ RealSize.toString (RealX.size r),
+ "[", C.int (Global.index g), "] = ",
+ RealX.toC r, ";\n"]))
+ ; print "}\n")
fun declareFrameOffsets () =
Vector.foreachi
(frameOffsets, fn (i, v) =>
@@ -289,7 +385,8 @@
end
in
outputIncludes (includes, print)
- ; declareGlobals ()
+ ; declareGlobals ("", print)
+ ; declareLoadSaveGlobals ()
; declareIntInfs ()
; declareStrings ()
; declareReals ()
@@ -305,21 +402,29 @@
struct
open Type
- fun toC (t: t): string =
- case t of
- Char => "Char"
- | CPointer => "Pointer"
- | EnumPointers {pointers, ...} =>
- if 0 = Vector.length pointers
- then "Int"
- else "Pointer"
- | ExnStack => "Word"
- | Int => "Int"
- | IntInf => "Pointer"
- | Label _ => "Word"
- | Real => "Double"
- | Word => "Word"
- | _ => Error.bug (concat ["Type.toC strange type: ", toString t])
+ local
+ fun make (name, memo, toString) =
+ memo (fn s => concat [name, toString s])
+ val int = make ("Int", IntSize.memoize, IntSize.toString)
+ val real = make ("Real", RealSize.memoize, RealSize.toString)
+ val word = make ("Word", WordSize.memoize, WordSize.toString)
+ val pointer = "Pointer"
+ in
+ fun toC (t: t): string =
+ case t of
+ CPointer => pointer
+ | EnumPointers {pointers, ...} =>
+ if 0 = Vector.length pointers
+ then int I32
+ else pointer
+ | ExnStack => word W32
+ | Int s => int s
+ | IntInf => pointer
+ | Label _ => word W32
+ | Real s => real s
+ | Word s => word s
+ | _ => Error.bug (concat ["Type.toC strange type: ", toString t])
+ end
end
structure Prim =
@@ -333,19 +438,23 @@
val {get: Tycon.t -> string option, set, ...} =
Property.getSetOnce (Tycon.plist, Property.initConst NONE)
val tycons =
- [(Tycon.char, "Char"),
- (Tycon.int, "Int"),
- (Tycon.intInf, "Pointer"),
- (Tycon.pointer, "Pointer"),
- (Tycon.preThread, "Pointer"),
- (Tycon.real, "Double"),
- (Tycon.reff, "Pointer"),
- (Tycon.thread, "Pointer"),
- (Tycon.tuple, "Pointer"),
- (Tycon.vector, "Pointer"),
- (Tycon.weak, "Pointer"),
- (Tycon.word, "Word32"),
- (Tycon.word8, "Word8")]
+ List.map
+ (IntSize.all, fn s =>
+ (Tycon.int s, concat ["Int", IntSize.toString s]))
+ @ [(Tycon.intInf, "Pointer"),
+ (Tycon.pointer, "Pointer"),
+ (Tycon.preThread, "Pointer")]
+ @ (List.map
+ (RealSize.all, fn s =>
+ (Tycon.real s, concat ["Real", RealSize.toString s])))
+ @ [(Tycon.reff, "Pointer"),
+ (Tycon.thread, "Pointer"),
+ (Tycon.tuple, "Pointer"),
+ (Tycon.vector, "Pointer"),
+ (Tycon.weak, "Pointer")]
+ @ (List.map
+ (WordSize.all, fn s =>
+ (Tycon.word s, concat ["Word", WordSize.toString s])))
val _ =
List.foreach (tycons, fn (tycon, s) => set (tycon, SOME s))
in
@@ -360,7 +469,9 @@
end
end
end
-
+
+fun contents (ty, z) = concat ["C", C.args [Type.toC ty, z]]
+
fun output {program as Machine.Program.T {chunks,
frameLayouts,
main = {chunkLabel, label}, ...},
@@ -454,7 +565,7 @@
src: string, srcIsMem: bool,
ty: Type.t}: string =
if handleMisalignedReals
- andalso Type.equals (ty, Type.real)
+ andalso Type.equals (ty, Type.real R64)
then
case (dstIsMem, srcIsMem) of
(false, false) => concat [dst, " = ", src, ";\n"]
@@ -467,45 +578,41 @@
fun toString (z: Operand.t): string =
case z of
ArrayOffset {base, index, ty} =>
- concat ["X", Type.name ty,
- C.args [toString base, toString index]]
- | Cast (z, ty) =>
- concat ["(", Runtime.Type.toString (Type.toRuntime ty), ")",
- toString z]
- | Char c => C.char c
- | Contents {oper, ty} =>
- concat ["C", Type.name ty, "(", toString oper, ")"]
+ concat ["X", C.args [Type.toC ty,
+ toString base,
+ toString index]]
+ | Cast (z, ty) => concat ["(", Type.toC ty, ")", toString z]
+ | Contents {oper, ty} => contents (ty, toString oper)
| File => "__FILE__"
| Frontier => "Frontier"
| GCState => "GCState"
| Global g =>
- concat ["G", Type.name (Global.ty g),
- if Global.isRoot g
- then ""
- else "NR",
- "(", Int.toString (Global.index g), ")"]
- | Int n => C.int n
+ if Global.isRoot g
+ then concat ["G",
+ C.args [Type.toC (Global.ty g),
+ Int.toString (Global.index g)]]
+ else concat ["GPNR", C.args [Int.toString (Global.index g)]]
+ | Int i => IntX.toC i
| Label l => labelToStringIndex l
| Line => "__LINE__"
| Offset {base, offset, ty} =>
- concat ["O", Type.name ty,
- C.args [toString base, C.int offset]]
- | Real s => C.real s
+ concat ["O", C.args [Type.toC ty, toString base, C.int offset]]
+ | Real r => RealX.toC r
| Register r =>
- concat ["R", Type.name (Register.ty r),
- "(", Int.toString (Register.index r), ")"]
+ concat [Type.name (Register.ty r), "_",
+ Int.toString (Register.index r)]
| SmallIntInf w =>
concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
| StackOffset {offset, ty} =>
- concat ["S", Type.name ty, "(", C.int offset, ")"]
+ concat ["S", C.args [Type.toC ty, C.int offset]]
| StackTop => "StackTop"
- | Word w => C.word w
+ | Word w => WordX.toC w
in
val operandToString = toString
end
fun fetchOperand (z: Operand.t): string =
if handleMisalignedReals
- andalso Type.equals (Operand.ty z, Type.real)
+ andalso Type.equals (Operand.ty z, Type.real R64)
andalso Operand.isMem z
then realFetch (operandToString z)
else operandToString z
@@ -535,12 +642,12 @@
let
val ty = Operand.ty value
val dst =
- concat
- ["C", Type.name (Operand.ty value),
- "(Frontier + ",
- C.int (offset
- + Runtime.normalHeaderSize),
- ")"]
+ contents
+ (Operand.ty value,
+ concat ["Frontier + ",
+ C.int
+ (offset
+ + Runtime.normalHeaderSize)])
in
print "\t"
; (print
@@ -758,12 +865,8 @@
val _ =
print
(concat
- ["\t",
- Runtime.Type.toString
- (Type.toRuntime ty),
- " ", tmp, " = ",
- fetchOperand z,
- ";\n"])
+ ["\t", Type.toC ty, " ", tmp, " = ",
+ fetchOperand z, ";\n"])
in
tmp
end
@@ -890,36 +993,40 @@
fun const1 () = const 1
in
case Prim.name prim of
- Int_addCheck =>
- if const0 ()
- then "\tInt_addCheckCX"
- else if const1 ()
- then "\tInt_addCheckXC"
- else "\tInt_addCheck"
- | Int_mulCheck => "\tInt_mulCheck"
- | Int_negCheck => "\tInt_negCheck"
- | Int_subCheck =>
- if const0 ()
- then "\tInt_subCheckCX"
- else if const1 ()
- then "\tInt_subCheckXC"
- else "\tInt_subCheck"
- | Word32_addCheck =>
- if const0 ()
- then "\tWord32_addCheckCX"
- else if const1 ()
- then "\tWord32_addCheckXC"
- else "\tWord32_addCheck"
- | Word32_mulCheck => "\tWord32_mulCheck"
+ Int_addCheck _ =>
+ concat [Prim.toString prim,
+ if const0 ()
+ then "CX"
+ else if const1 ()
+ then "XC"
+ else ""]
+ | Int_mulCheck _ => Prim.toString prim
+ | Int_negCheck _ => Prim.toString prim
+ | Int_subCheck _ =>
+ concat [Prim.toString prim,
+ if const0 ()
+ then "CX"
+ else if const1 ()
+ then "XC"
+ else ""]
+ | Word_addCheck _ =>
+ concat [Prim.toString prim,
+ if const0 ()
+ then "CX"
+ else if const1 ()
+ then "XC"
+ else ""]
+ | Word_mulCheck _ => Prim.toString prim
| _ => Error.bug "strange overflow prim"
end
val _ = force overflow
in
- C.call (prim,
- operandToString dst
- :: (Vector.toListMap (args, operandToString)
- @ [Label.toString overflow]),
- print)
+ print "\t"
+ ; C.call (prim,
+ operandToString dst
+ :: (Vector.toListMap (args, operandToString)
+ @ [Label.toString overflow]),
+ print)
; gotoLabel success
; maybePrintLabel overflow
end
@@ -1030,7 +1137,7 @@
#2 (Vector.sub (cases, 0)))
| (_, SOME l) => switch (cases, l)
end
- fun simple ({cases, default, test}, f) =
+ fun simple ({cases, default, size, test}, f) =
doit {cases = Vector.map (cases, fn (c, l) =>
(f c, l)),
default = default,
@@ -1038,27 +1145,28 @@
datatype z = datatype Switch.t
in
case switch of
- Char z => simple (z, C.char)
- | EnumPointers {enum, pointers, test} =>
+ EnumPointers {enum, pointers, test} =>
iff (concat
["IsInt (", operandToString test, ")"],
enum, pointers)
- | Int (z as {cases, default, test}) =>
+ | Int (z as {cases, default, size, test}) =>
let
- fun normal () = simple (z, C.int)
+ fun normal () = simple (z, IntX.toC)
in
if 2 = Vector.length cases
+ andalso Option.isNone default
then
let
- val c0 = Vector.sub (cases, 0)
- val c1 = Vector.sub (cases, 1)
+ val (c0, l0) = Vector.sub (cases, 0)
+ val (c1, l1) = Vector.sub (cases, 1)
in
- case (c0, c1, default) of
- ((0, f), (1, t), NONE) =>
- bool (test, t, f)
- | ((1, t), (0, f), NONE) =>
- bool (test, t, f)
- | _ => normal ()
+ if IntX.isZero c0
+ andalso IntX.isOne c1
+ then bool (test, l1, l0)
+ else if (IntX.isOne c0
+ andalso IntX.isZero c1)
+ then bool (test, l0, l1)
+ else normal ()
end
else normal ()
end
@@ -1068,17 +1176,18 @@
(Int.toString tag, dst))),
default = default,
test = tag}
- | Word z => simple (z, C.word)
+ | Word z => simple (z, WordX.toC)
end
end
fun declareRegisters () =
List.foreach
(Runtime.Type.all, fn t =>
let
- val d = concat ["D", Runtime.Type.name t]
+ val pre = concat ["\t", Runtime.Type.toString t, " ",
+ Runtime.Type.name t, "_"]
in
Int.for (0, 1 + regMax t, fn i =>
- C.call (d, [C.int i], print))
+ print (concat [pre, C.int i, ";\n"]))
end)
fun outputOffsets () =
List.foreach
@@ -1092,6 +1201,7 @@
in
outputIncludes (["c-chunk.h"], print)
; outputOffsets ()
+ ; declareGlobals ("extern ", print)
; declareFFI ()
; declareChunks ()
; declareProfileLabels ()
1.40 +11 -14 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.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- x86-codegen.fun 14 May 2003 02:50:11 -0000 1.39
+++ x86-codegen.fun 23 Jun 2003 04:58:58 -0000 1.40
@@ -159,22 +159,19 @@
[mainLabel, if reserveEsp then C.truee else C.falsee]
end
fun declareLocals () =
- let
- val tyMax =
- Runtime.Type.memo
- (fn t =>
+ List.foreach
+ (Runtime.Type.all,
+ fn t =>
+ let
+ val m =
List.fold
(chunks, ~1, fn (Machine.Chunk.T {regMax, ...}, max) =>
- Int.max (max, regMax t)))
- in
- print
- (concat ["Locals",
- Layout.toString
- (Layout.tuple (List.map
- (Runtime.Type.all, fn t =>
- Int.layout (1 + tyMax t)))),
- ";\n"])
- end
+ Int.max (max, regMax t))
+ val m = m + 1
+ in
+ print (concat ["local", Runtime.Type.toString t,
+ "[", Int.toString m, "];\n"])
+ end)
fun rest () =
declareLocals ()
in
1.19 +75 -45 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.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- x86-mlton-basic.fun 15 May 2003 14:50:57 -0000 1.18
+++ x86-mlton-basic.fun 23 Jun 2003 04:58:58 -0000 1.19
@@ -12,6 +12,13 @@
open x86
structure Runtime = Machine.Runtime
+ local
+ open Runtime
+ in
+ structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize
+ end
(*
* x86.Size.t equivalents
@@ -30,23 +37,40 @@
local
datatype z = datatype Runtime.Type.dest
+ datatype z = datatype x86.Size.t
in
- fun toX86Size' t
- = case t
- of Char => x86.Size.BYTE
- | Double => x86.Size.DBLE
- | Int => x86.Size.LONG
- | Pointer => x86.Size.LONG
- | Uint => x86.Size.LONG
+ fun toX86Size' t =
+ case t of
+ Int s =>
+ let
+ datatype z = datatype IntSize.t
+ in
+ case s of
+ I8 => BYTE
+ | I16 => WORD
+ | I32 => LONG
+ | I64 => Error.bug "FIXME"
+ end
+ | Pointer => LONG
+ | Real s =>
+ let
+ datatype z = datatype RealSize.t
+ in
+ case s of
+ R32 => SNGL
+ | R64 => DBLE
+ end
+ | Word s =>
+ let
+ datatype z = datatype WordSize.t
+ in
+ case s of
+ W8 => BYTE
+ | W16 => WORD
+ | W32 => LONG
+ end
val toX86Size = fn t => toX86Size' (Runtime.Type.dest t)
- fun toX86Scale' t
- = case t
- of Char => x86.Scale.One
- | Double => x86.Scale.Eight
- | Int => x86.Scale.Four
- | Pointer => x86.Scale.Four
- | Uint => x86.Scale.Four
- val toX86Scale = fn t => toX86Scale' (Runtime.Type.dest t)
+ fun toX86Scale t = x86.Scale.fromBytes (Runtime.Type.size t)
end
(*
@@ -251,45 +275,51 @@
= Operand.memloc fpswTempContents
local
- val localC_base = Label.fromString "localuchar"
- val localD_base = Label.fromString "localdouble"
- val localI_base = Label.fromString "localint"
- val localP_base = Label.fromString "localpointer"
- val localU_base = Label.fromString "localuint"
+ val localI_base =
+ IntSize.memoize
+ (fn s => Label.fromString (concat ["localInt", IntSize.toString s]))
+ val localP_base = Label.fromString "localPointer"
+ val localR_base =
+ RealSize.memoize
+ (fn s => Label.fromString (concat ["localReal", RealSize.toString s]))
+ val localW_base =
+ WordSize.memoize
+ (fn s => Label.fromString (concat ["localWord", WordSize.toString s]))
datatype z = datatype Runtime.Type.dest
in
- fun local_base ty
- = case Runtime.Type.dest ty
- of Char => localC_base
- | Double => localD_base
- | Int => localI_base
- | Pointer => localP_base
- | Uint => localU_base
+ fun local_base ty =
+ case Runtime.Type.dest ty of
+ Int s => localI_base s
+ | Pointer => localP_base
+ | Real s => localR_base s
+ | Word s => localW_base s
end
local
- val globalC_base = Label.fromString "globaluchar"
- val globalC_num = Label.fromString "num_globaluchar"
- val globalD_base = Label.fromString "globaldouble"
- val globalD_num = Label.fromString "num_globaldouble"
- val globalI_base = Label.fromString "globalint"
- val globalI_num = Label.fromString "num_globalint"
- val globalP_base = Label.fromString "globalpointer"
- val globalP_num = Label.fromString "num_globalpointer"
- val globalU_base = Label.fromString "globaluint"
- val globalU_num = Label.fromString "num_globaluint"
+ fun make (name, memo, toString) =
+ (memo (fn s =>
+ Label.fromString (concat ["global", name, toString s])),
+ memo (fn s =>
+ Label.fromString (concat ["num_global", name, toString s])))
+ val (globalI_base, globalI_num) =
+ make ("Int", IntSize.memoize, IntSize.toString)
+ val globalP_base = Label.fromString "globalPointer"
+ val globalP_num = Label.fromString "num_globalpointer"
+ val (globalR_base, globalR_num) =
+ make ("Real", RealSize.memoize, RealSize.toString)
+ val (globalW_base, globalW_num) =
+ make ("Word", WordSize.memoize, WordSize.toString)
datatype z = datatype Runtime.Type.dest
in
- fun global_base ty
- = case Runtime.Type.dest ty
- of Char => globalC_base
- | Double => globalD_base
- | Int => globalI_base
- | Pointer => globalP_base
- | Uint => globalU_base
+ fun global_base ty =
+ case Runtime.Type.dest ty of
+ Int s => globalI_base s
+ | Pointer => globalP_base
+ | Real s => globalR_base s
+ | Word s => globalW_base s
end
- val globalPointerNonRoot_base = Label.fromString "globalpointerNonRoot"
+ val globalPointerNonRoot_base = Label.fromString "globalPointerNonRoot"
val saveGlobals = Label.fromString "saveGlobals"
val loadGlobals = Label.fromString "loadGlobals"
1.44 +110 -225 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.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- x86-mlton.fun 14 May 2003 02:50:11 -0000 1.43
+++ x86-mlton.fun 23 Jun 2003 04:58:58 -0000 1.44
@@ -17,6 +17,9 @@
structure CFunction = CFunction
structure Prim = Prim
structure Runtime = Runtime
+ datatype z = datatype IntSize.t
+ datatype z = datatype RealSize.t
+ datatype z = datatype WordSize.t
end
type transInfo = {addData : x86.Assembly.t list -> unit,
@@ -54,110 +57,6 @@
statements = [Assembly.comment ("UNIMPLEMENTED PRIM: " ^ s)],
transfer = NONE}]
- fun subWord8ArrayVector ()
- = let
- val (dst,dstsize) = getDst ()
- val _
- = Assert.assert
- ("applyPrim: subWord8ArrayVector, dstsize",
- fn () => dstsize = Size.LONG)
- val ((src1,src1size),
- (src2,src2size)) = getSrc2 ()
- val _
- = Assert.assert
- ("applyPrim: subWord8ArrayVector, src1size",
- fn () => src1size = pointerSize)
- val _
- = Assert.assert
- ("applyPrim: subWord8ArrayVector, src2size",
- fn () => src2size = pointerSize)
-
- val base
- = case (Operand.deMemloc src1)
- of SOME base => base
- | NONE => Error.bug "applyPrim: subWord8ArrayVector, src1"
- val memloc
- = case (Operand.deImmediate src2,
- Operand.deMemloc src2)
- of (SOME index, _)
- => MemLoc.simple
- {base = base,
- index = index,
- scale = Scale.Four,
- size = Size.LONG,
- class = Classes.Heap}
- | (_, SOME index)
- => MemLoc.complex
- {base = base,
- index = index,
- scale = Scale.Four,
- size = Size.LONG,
- class = Classes.Heap}
- | _ => Error.bug "applyPrim: subWord8ArrayVector, src2"
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_mov
- {dst = dst,
- src = Operand.memloc memloc,
- size = dstsize}],
- transfer = NONE}]
- end
-
- fun updateWord8Array ()
- = let
- val ((src1,src1size),
- (src2,src2size),
- (src3,src3size)) = getSrc3 ()
- val _
- = Assert.assert
- ("applyPrim: updateWord8Array, src1size",
- fn () => src1size = pointerSize)
- val _
- = Assert.assert
- ("applyPrim: updateWord8Array, src2size",
- fn () => src2size = wordSize)
- val _
- = Assert.assert
- ("applyPrim: updateWord8Array, src3size",
- fn () => src3size = wordSize)
-
- val base
- = case (Operand.deMemloc src1)
- of SOME base => base
- | NONE => Error.bug "applyPrim: updateWord8Array, src1"
- val memloc
- = case (Operand.deImmediate src2,
- Operand.deMemloc src2)
- of (SOME index, _)
- => MemLoc.simple
- {base = base,
- index = index,
- scale = Scale.Four,
- size = Size.LONG,
- class = Classes.Heap}
- | (_, SOME index)
- => MemLoc.complex
- {base = base,
- index = index,
- scale = Scale.Four,
- size = Size.LONG,
- class = Classes.Heap}
- | _ => Error.bug "applyPrim: updateWord8Array, src2"
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_mov
- {dst = Operand.memloc memloc,
- src = src3,
- size = src3size}],
- transfer = NONE}]
- end
-
fun mov ()
= let
val (dst,dstsize) = getDst ()
@@ -650,13 +549,7 @@
AppendList.appends
[comment_begin,
(case Prim.name prim of
- Char_lt => cmp Instruction.B
- | Char_le => cmp Instruction.BE
- | Char_gt => cmp Instruction.A
- | Char_ge => cmp Instruction.AE
- | Char_chr => xvom ()
- | Char_ord => movx Instruction.MOVZX
- | Cpointer_isNull
+ Cpointer_isNull
=> let
val (dst,dstsize) = getDst ()
val (src,srcsize) = getSrc1 ()
@@ -706,22 +599,39 @@
transfer = NONE}]
end
| SOME _ => Error.bug "prim: FFI")
- | Int_add => binal Instruction.ADD
- | Int_sub => binal Instruction.SUB
- | Int_mul => imul2 ()
- | Int_quot => pmd Instruction.IDIV
- | Int_rem => pmd Instruction.IMOD
- | Int_neg => unal Instruction.NEG
- | Int_lt => cmp Instruction.L
- | Int_le => cmp Instruction.LE
- | Int_gt => cmp Instruction.G
- | Int_ge => cmp Instruction.GE
- | Int_gtu => cmp Instruction.A
- | Int_geu => cmp Instruction.AE
+ | Int_ge _ => cmp Instruction.GE
+ | Int_gt _ => cmp Instruction.G
+ | Int_le _ => cmp Instruction.LE
+ | Int_lt _ => cmp Instruction.L
+ | Int_mul _ => imul2 ()
+ | 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
+ | 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
+ | Int_toWord (s, s') =>
+ (case (s, s') of
+ (I32, W8) => xvom ()
+ | (I32, W32) => mov ()
+ | _ => Error.bug (Prim.toString prim))
| MLton_eq => cmp Instruction.E
- | MLton_serialize => unimplemented primName
- | MLton_deserialize => unimplemented primName
- | Real_Math_acos
+ | Real_Math_acos _
=> let
val (dst,dstsize) = getDst ()
val (src,srcsize) = getSrc1 ()
@@ -771,7 +681,7 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_Math_asin
+ | Real_Math_asin _
=> let
val (dst,dstsize) = getDst ()
val (src,srcsize) = getSrc1 ()
@@ -817,7 +727,7 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_Math_atan
+ | Real_Math_atan _
=> let
val (dst,dstsize) = getDst ()
val (src,srcsize) = getSrc1 ()
@@ -845,7 +755,7 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_Math_atan2
+ | Real_Math_atan2 _
=> let
val (dst,dstsize) = getDst ()
val ((src1,src1size),
@@ -871,8 +781,8 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_Math_cos => funa Instruction.FCOS
- | Real_Math_exp
+ | Real_Math_cos _ => funa Instruction.FCOS
+ | Real_Math_exp _
=> let
val (dst,dstsize) = getDst ()
val (src,srcsize) = getSrc1 ()
@@ -927,11 +837,11 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_Math_ln => flogarithm Instruction.LN2
- | Real_Math_log10 => flogarithm Instruction.LG2
- | Real_Math_sin => funa Instruction.FSIN
- | Real_Math_sqrt => funa Instruction.FSQRT
- | Real_Math_tan
+ | Real_Math_ln _ => flogarithm Instruction.LN2
+ | Real_Math_log10 _ => flogarithm Instruction.LG2
+ | Real_Math_sin _ => funa Instruction.FSIN
+ | Real_Math_sqrt _ => funa Instruction.FSQRT
+ | Real_Math_tan _
=> let
val (dst,dstsize) = getDst ()
val (src,srcsize) = getSrc1 ()
@@ -953,13 +863,13 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_mul => fbina Instruction.FMUL
- | Real_muladd => fbina_fmul Instruction.FADD
- | Real_mulsub => fbina_fmul Instruction.FSUB
- | Real_add => fbina Instruction.FADD
- | Real_sub => fbina Instruction.FSUB
- | Real_div => fbina Instruction.FDIV
- | Real_lt
+ | Real_mul _ => fbina Instruction.FMUL
+ | Real_muladd _ => fbina_fmul Instruction.FADD
+ | Real_mulsub _ => fbina_fmul Instruction.FSUB
+ | Real_add _ => fbina Instruction.FADD
+ | Real_sub _ => fbina Instruction.FSUB
+ | Real_div _ => fbina Instruction.FDIV
+ | Real_lt _
=> let
val (dst,dstsize) = getDst ()
val ((src1,src1size),
@@ -990,7 +900,7 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_le
+ | Real_le _
=> let
val (dst,dstsize) = getDst ()
val ((src1,src1size),
@@ -1021,7 +931,7 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_equal
+ | Real_equal _
=> let
val (dst,dstsize) = getDst ()
val ((src1,src1size),
@@ -1057,7 +967,7 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_gt
+ | Real_gt _
=> let
val (dst,dstsize) = getDst ()
val ((src1,src1size),
@@ -1088,7 +998,7 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_ge
+ | Real_ge _
=> let
val (dst,dstsize) = getDst ()
val ((src1,src1size),
@@ -1119,7 +1029,7 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_qequal
+ | Real_qequal _
=> let
val (dst,dstsize) = getDst ()
val ((src1,src1size),
@@ -1150,24 +1060,8 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_abs => funa Instruction.FABS
- | Real_fromInt
- => 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
- | Real_toInt
+ | Real_abs _ => funa Instruction.FABS
+ | Real_toInt _
=> let
val (dst,dstsize) = getDst ()
val (src,srcsize) = getSrc1 ()
@@ -1183,7 +1077,7 @@
dstsize = dstsize}],
transfer = NONE}]
end
- | Real_ldexp
+ | Real_ldexp _
=> let
val (dst,dstsize) = getDst ()
val ((src1,src1size),
@@ -1217,58 +1111,49 @@
size = dstsize}],
transfer = NONE}]
end
- | Real_neg => funa Instruction.FCHS
- | Real_round => funa Instruction.FRNDINT
- | Word8_toInt => movx Instruction.MOVZX
- | Word8_toIntX => movx Instruction.MOVSX
- | Word8_fromInt => xvom ()
- | Word8_toLargeWord => movx Instruction.MOVZX
- | Word8_toLargeWordX => movx Instruction.MOVSX
- | Word8_fromLargeWord => xvom ()
- | Word8_add => binal Instruction.ADD
- | Word8_sub => binal Instruction.SUB
- | Word8_andb => binal Instruction.AND
- | Word8_orb => binal Instruction.OR
- | Word8_xorb => binal Instruction.XOR
- | Word8_mul => pmd Instruction.MUL
- | Word8_div => pmd Instruction.DIV
- | Word8_mod => pmd Instruction.MOD
- | Word8_neg => unal Instruction.NEG
- | Word8_notb => unal Instruction.NOT
- | Word8_lt => cmp Instruction.B
- | Word8_le => cmp Instruction.BE
- | Word8_gt => cmp Instruction.A
- | Word8_ge => cmp Instruction.AE
- | Word8_rol => sral Instruction.ROL
- | Word8_ror => sral Instruction.ROR
- | Word8_lshift => sral Instruction.SHL
- | Word8_rshift => sral Instruction.SHR
- | Word8_arshift => sral Instruction.SAR
- | Word8Array_subWord => subWord8ArrayVector ()
- | Word8Array_updateWord => updateWord8Array ()
- | Word8Vector_subWord => subWord8ArrayVector ()
- | Word32_add => binal Instruction.ADD
- | Word32_sub => binal Instruction.SUB
- | Word32_andb => binal Instruction.AND
- | Word32_orb => binal Instruction.OR
- | Word32_xorb => binal Instruction.XOR
-(*
- | Word32_mul => pmd Instruction.MUL
-*)
- | Word32_mul => imul2 ()
- | Word32_div => pmd Instruction.DIV
- | Word32_mod => pmd Instruction.MOD
- | Word32_neg => unal Instruction.NEG
- | Word32_notb => unal Instruction.NOT
- | Word32_lt => cmp Instruction.B
- | Word32_le => cmp Instruction.BE
- | Word32_gt => cmp Instruction.A
- | Word32_ge => cmp Instruction.AE
- | Word32_rol => sral Instruction.ROL
- | Word32_ror => sral Instruction.ROR
- | Word32_lshift => sral Instruction.SHL
- | Word32_rshift => sral Instruction.SHR
- | Word32_arshift => sral Instruction.SAR
+ | Real_neg _ => funa Instruction.FCHS
+ | Real_round _ => funa Instruction.FRNDINT
+ | Word_add _ => binal Instruction.ADD
+ | Word_andb _ => binal Instruction.AND
+ | Word_arshift _ => sral Instruction.SAR
+ | Word_div _ => pmd Instruction.DIV
+ | Word_ge _ => cmp Instruction.AE
+ | Word_gt _ => cmp Instruction.A
+ | Word_le _ => cmp Instruction.BE
+ | Word_lshift _ => sral Instruction.SHL
+ | Word_lt _ => cmp Instruction.B
+ | Word_mod _ => pmd Instruction.MOD
+ | Word_mul s =>
+ (case s of
+ W8 => pmd Instruction.MUL
+ | W16 => Error.bug "FIXME"
+ | W32 => imul2 ())
+ | Word_neg _ => unal Instruction.NEG
+ | Word_notb _ => unal Instruction.NOT
+ | Word_orb _ => binal Instruction.OR
+ | Word_rol _ => sral Instruction.ROL
+ | Word_ror _ => sral Instruction.ROR
+ | Word_rshift _ => sral Instruction.SHR
+ | Word_sub _ => binal Instruction.SUB
+ | Word_toInt (s, s') =>
+ (case (s, s') of
+ (W8, I32) => movx Instruction.MOVZX
+ | _ => Error.bug (Prim.toString prim))
+ | Word_toIntX (s, s') =>
+ (case (s, s') of
+ (W8, I32) => movx Instruction.MOVSX
+ | (W32, I32) => mov ()
+ | _ => Error.bug (Prim.toString prim))
+ | Word_toWord (s, s') =>
+ (case (s, s') of
+ (W8, W32) => movx Instruction.MOVZX
+ | (W32, W8) => xvom ()
+ | _ => Error.bug (Prim.toString prim))
+ | Word_toWordX (s, s') =>
+ (case (s, s') of
+ (W8, W32) => movx Instruction.MOVSX
+ | _ => Error.bug (Prim.toString prim))
+ | Word_xorb _ => binal Instruction.XOR
| _ => Error.bug ("prim: strange Prim.Name.t: " ^ primName)),
comment_end]
end
@@ -1497,12 +1382,12 @@
AppendList.appends
[comment_begin,
(case Prim.name prim of
- Int_addCheck => binal (x86.Instruction.ADD, x86.Instruction.O)
- | Int_subCheck => binal (x86.Instruction.SUB, x86.Instruction.O)
- | Int_mulCheck => imul2_check x86.Instruction.O
- | Int_negCheck => unal (x86.Instruction.NEG, x86.Instruction.O)
- | Word32_addCheck => binal (x86.Instruction.ADD, x86.Instruction.C)
- | Word32_mulCheck => pmd (x86.Instruction.MUL, x86.Instruction.C)
+ Int_addCheck _ => binal (x86.Instruction.ADD, x86.Instruction.O)
+ | Int_subCheck _ => binal (x86.Instruction.SUB, x86.Instruction.O)
+ | Int_mulCheck _ => imul2_check x86.Instruction.O
+ | Int_negCheck _ => unal (x86.Instruction.NEG, x86.Instruction.O)
+ | Word_addCheck _ => binal (x86.Instruction.ADD, x86.Instruction.C)
+ | Word_mulCheck _ => pmd (x86.Instruction.MUL, x86.Instruction.C)
| _ => Error.bug ("arith: strange Prim.Name.t: " ^ primName))]
end
1.43 +60 -7 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.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- x86-translate.fun 15 May 2003 14:50:58 -0000 1.42
+++ x86-translate.fun 23 Jun 2003 04:58:58 -0000 1.43
@@ -27,8 +27,12 @@
local
open Machine
in
+ structure IntSize = IntSize
+ structure IntX = IntX
structure Label = Label
structure Prim = Prim
+ structure RealSize = RealSize
+ structure RealX = RealX
structure Register = Register
structure Runtime = Runtime
local
@@ -37,7 +41,13 @@
structure GCField = GCField
end
structure Type = Type
+ structure WordSize = WordSize
+ structure WordX = WordX
end
+
+ datatype z = datatype IntSize.t
+ datatype z = datatype RealSize.t
+ datatype z = datatype WordSize.t
structure Global =
struct
@@ -101,7 +111,6 @@
x86.Operand.memloc memloc
end
| Cast (z, _) => toX86Operand z
- | Char c => x86.Operand.immediate_const_char c
| Contents {oper, ty} =>
let
val ty = Type.toRuntime ty
@@ -128,7 +137,14 @@
| Frontier => x86MLton.gcState_frontierContentsOperand ()
| GCState => x86.Operand.label x86MLton.gcState_label
| Global g => x86.Operand.memloc (Global.toX86MemLoc g)
- | Int i => x86.Operand.immediate_const_int i
+ | Int i =>
+ let
+ val i' = IntX.toIntInf i
+ in
+ case IntX.size i of
+ I32 => x86.Operand.immediate_const_int (IntInf.toInt i')
+ | _ => Error.bug "FIXME"
+ end
| Label l => x86.Operand.immediate_label l
| Line => x86MLton.fileLine ()
| Offset {base = GCState, offset, ty} =>
@@ -185,7 +201,17 @@
x86.Operand.memloc memloc
end
| StackTop => x86MLton.gcState_stackTopContentsOperand ()
- | Word w => x86.Operand.immediate_const_word w
+ | Word w =>
+ let
+ val w' = WordX.toWord w
+ in
+ case WordX.size w of
+ W8 =>
+ x86.Operand.immediate_const_char
+ (Word8.toChar (Word8.fromWord w'))
+ | W16 => Error.bug "FIXME"
+ | W32 => x86.Operand.immediate_const_word w'
+ end
val toX86Operand =
fn operand =>
@@ -681,8 +707,7 @@
in
case switch of
- Char z => simple (z, doSwitchChar)
- | EnumPointers {enum, pointers, test} =>
+ EnumPointers {enum, pointers, test} =>
let
val size = Operand.toX86Size test
val test = Operand.toX86Operand test
@@ -706,7 +731,16 @@
truee = enum,
falsee = pointers})}))
end
- | Int z => simple (z, doSwitchInt)
+ | Int {cases, default, size, test} =>
+ (case size of
+ I32 =>
+ simple ({cases = (Vector.map
+ (cases, fn (i, l) =>
+ (IntX.toInt i, l))),
+ default = default,
+ test = test},
+ doSwitchInt)
+ | _ => Error.bug "FIXME")
| Pointer {cases, default, tag, ...} =>
simple ({cases = (Vector.map
(cases, fn {dst, tag, ...} =>
@@ -714,7 +748,26 @@
default = default,
test = tag},
doSwitchInt)
- | Word z => simple (z, doSwitchWord)
+ | Word {cases, default, size, test} =>
+ (case size of
+ W8 =>
+ simple ({cases = (Vector.map
+ (cases, fn (w, l) =>
+ (Word8.toChar
+ (Word8.fromWord
+ (WordX.toWord w)),
+ l))),
+ default = default,
+ test = test},
+ doSwitchChar)
+ | W32 =>
+ simple ({cases = (Vector.map
+ (cases, fn (w, l) =>
+ (WordX.toWord w, l))),
+ default = default,
+ test = test},
+ doSwitchWord)
+ | _ => Error.bug "FIXME")
end
| Goto label
=> (AppendList.append
1.21 +37 -59 mlton/mlton/core-ml/lookup-constant.fun
Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- lookup-constant.fun 14 May 2003 02:50:11 -0000 1.20
+++ lookup-constant.fun 23 Jun 2003 04:58:58 -0000 1.21
@@ -9,32 +9,7 @@
struct
open S
-
-structure Int =
- struct
- open Int
- val fromString =
- Trace.trace ("Int.fromString", String.layout, Option.layout layout)
- fromString
- end
-
-structure Word =
- struct
- open Word
- val fromString =
- Trace.trace ("Word.fromString", String.layout, Option.layout layout)
- fromString
- end
-
-structure Const =
- struct
- datatype t =
- Bool of bool
- | Int of int
- | Real of string
- | String of string
- | Word of word
- end
+open CoreML
fun unescape s =
let
@@ -54,16 +29,16 @@
structure ConstType =
struct
- datatype t = Bool | Int | Real | String | Word
+ datatype t = Int | Real | String | Word
end
datatype z = datatype ConstType.t
type res = (string * ConstType.t) list
-fun decsConstants (decs: CoreML.Dec.t vector): res =
+fun decsConstants (decs: Dec.t vector): res =
let
- open CoreML
- open Exp Dec
+ datatype z = datatype Exp.node
+ datatype z = datatype Dec.node
fun loopExp (e: Exp.t, ac: res): res =
case Exp.node e of
App (e, e') => loopExp (e, loopExp (e', ac))
@@ -78,27 +53,24 @@
fun strange () =
Error.bug
(concat ["constant with strange type: ", c])
- in case Prim.scheme p of
- Scheme.T {tyvars, ty as Type.Con (tc, ts)} =>
- if 0 = Vector.length tyvars
- then
- let
- val ty = Const.Type.make
- (Type.deconConst ty)
- val tys = [(Const.Type.bool, Bool),
- (Const.Type.int, Int),
- (Const.Type.real, Real),
- (Const.Type.string, String),
- (Const.Type.word, Word)]
- in case (List.peek
- (tys, fn (ty', _) =>
- Const.Type.equals (ty, ty'))) of
- NONE => strange ()
- | SOME (_,t) => (c,t) :: ac
-
- end
- else strange ()
- | _ => strange ()
+ val Scheme.T {tyvars, ty} = Prim.scheme p
+ in
+ if 0 = Vector.length tyvars
+ then
+ let
+ val tys =
+ [(Type.defaultInt, Int),
+ (Type.defaultReal, Real),
+ (Type.word8Vector, String),
+ (Type.defaultWord, Word)]
+ in case (List.peek
+ (tys, fn (ty', _) =>
+ Type.equals (ty, ty'))) of
+ NONE => strange ()
+ | SOME (_, t) => (c, t) :: ac
+
+ end
+ else strange ()
end
| _ => ac)
| Raise {exn, ...} => loopExp (exn, ac)
@@ -163,11 +135,10 @@
value, ");"]
in
case ty of
- Bool => doit ("%s", concat [value, "? \"true\" : \"false\""])
- | Int => doit ("%d", value)
+ Int => doit ("%d", value)
| Real => doit ("%.20f", value)
| String => concat ["MLton_printStringEscaped (f, ", value, ");"]
- | Word => doit ("%x", value)
+ | Word => doit ("%u", value)
end),
["return 0;}"]],
fn l => (Out.output (out, l); Out.newline out))
@@ -194,11 +165,18 @@
| _ => Error.bug (concat ["strange constants line ", s])
in
case ty of
- Bool => Const.Bool (valOf (Bool.fromString s))
- | Int => Const.Int (valOf (Int.fromString s))
- | String => Const.String (unescape s)
- | Real => Const.Real s
- | Word => Const.Word (valOf (Word.fromString s))
+ Int =>
+ (case IntInf.fromString s of
+ NONE => Error.bug "strange Int constant"
+ | SOME i =>
+ Const.Int (IntX.make (i, IntSize.default)))
+ | String => Const.string (unescape s)
+ | Real => Const.Real (RealX.make (s, RealSize.default))
+ | Word =>
+ (case IntInf.fromString s of
+ NONE => Error.bug "strange Word constant"
+ | SOME i =>
+ Const.Word (WordX.fromLargeInt (i, WordSize.default)))
end)
val lookupConstant =
String.memoizeList
1.4 +1 -21 mlton/mlton/core-ml/lookup-constant.sig
Index: lookup-constant.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- lookup-constant.sig 16 Apr 2002 12:10:52 -0000 1.3
+++ lookup-constant.sig 23 Jun 2003 04:58:58 -0000 1.4
@@ -17,26 +17,6 @@
sig
include LOOKUP_CONSTANT_STRUCTS
- structure Const:
- sig
- datatype t =
- Bool of bool
- | Int of int
- | Real of string
- | String of string
- | Word of word
- end
-
val build: CoreML.Dec.t vector * Out.t -> unit
- val load: CoreML.Dec.t vector * In.t -> string -> Const.t
+ val load: CoreML.Dec.t vector * In.t -> string -> CoreML.Const.t
end
-
-
-functor TestLookupConstant (S: LOOKUP_CONSTANT): sig end =
-struct
-
-open S
-
-val _ = Assert.assert("LookupConstant", fn () => true)
-
-end
1.5 +2 -0 mlton/mlton/front-end/import.cm
Index: import.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/import.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- import.cm 16 Apr 2002 12:10:52 -0000 1.4
+++ import.cm 23 Jun 2003 04:58:58 -0000 1.5
@@ -10,9 +10,11 @@
structure Array
structure Char
structure Error
+structure Exn
structure File
structure In
structure Int
+structure IntInf
structure Layout
structure List
structure Out
1.9 +157 -167 mlton/mlton/front-end/ml.grm
Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- ml.grm 28 Feb 2002 18:29:49 -0000 1.8
+++ ml.grm 23 Jun 2003 04:58:59 -0000 1.9
@@ -212,8 +212,8 @@
EOF | SEMICOLON
| LONGID of string
| TYVAR of string
- | INT of string
- | WORD of Word32.word
+ | INT of IntInf.t
+ | WORD of IntInf.t
| REAL of string
| STRING of string
| CHAR of char
@@ -228,185 +228,168 @@
(* primitives *)
| PRIM | FFI | CONST | BUILD_CONST
-%nonterm digit of int
- | int of int
+%nonterm
+ aexp of Exp.node
+ | andspecs of wherespec list
+ | apat of Pat.t
+ | apat' of Pat.t
+ | apatnode of Pat.node
+ | apats of Pat.t list
+ | app_exp of Exp.t list
+ | app_exp1 of Exp.t list
+ | arg_fct of Strexp.t
+ | clause of clause
+ | clauses of clause list
+ | clausesTop of clauses
+ | commapats of Pat.t list
+ | con of Con.t
+ | const of Const.t
+ | const' of Const.node
+ | constr of Con.t * Type.t option
+ | constraint of Type.t option
+ | constrs of (Con.t * Type.t option) list
+ | datBind of DatBind.t
+ | datBindNoWithtype of DatBind.t
+ | datatypeRhs of DatatypeRhs.t
+ | datatypeRhsNoWithtype of DatatypeRhs.t
+ | datatypeRhsnode of DatatypeRhs.node
+ | datatypeRhsnodeNoWithtype of DatatypeRhs.node
+ | db of db
+ | dbs of db list
+ | dec of Dec.t
+ | decnode of Dec.node
+ | decnolocal of Dec.node
+ | decs of Dec.t
+ | decsnode of Dec.node
+ | digit of int
+ | eb of eb
+ | ebrhs of EbRhs.t
+ | ebrhsnode of EbRhs.node
+ | ebs of eb list
+ | elabel of (Field.t * Exp.t)
+ | elabels of (Field.t * Exp.t) list
+ | exndesc of exndesc
+ | exndescs of exndesc list
+ | exp of Exp.t
+ | exp_2c of Exp.t list
+ | exp_list of Exp.t list
+ | exp_ps of Exp.t list
+ | expnode of Exp.node
+ | fctarg of FctArg.node
+ | fctid of Fctid.t
+ | field of Field.t
+ | fixity of Fixity.t
+ | funbinds of funbind list
+ | funbinds' of Strexp.t * funbind list
+ | funbinds'1 of funbind whereAnd
+ | funbinds'1' of funbind whereAnd
+ | funbinds'2 of funbind list
+ | funs of clauses list
| id of string * Region.t
| idEqual of string * Region.t
| idNoAsterisk of string * Region.t
- | longidNoAsterisk of string * Region.t
+ | int of IntInf.t
+ | leadExps of Topdec.t list
+ | longcon of Longcon.t
| longid of string * Region.t
| longidEqual of string * Region.t
- | const of Const.t
- | const' of Const.node
- | vid of Vid.t
- | vidNoEqual of Vid.t
- | vids of Vid.t list
- | var of Var.t
- | con of Con.t
- | opcon of Con.t
- | tyvar of Tyvar.t
- | tycon of Tycon.t
- | field of Field.t
- | strid of Strid.t
- | sigid of Sigid.t
- | sigids of Sigid.t list
- | fctid of Fctid.t
+ | longidNoAsterisk of string * Region.t
+ | longstrid of Longstrid.t
+ | longstrideqns of Longstrid.t list
+ | longstrids of Longstrid.t list
| longtycon of Longtycon.t
+ | longtyconeqns of Longtycon.t list
| longvar of Longvar.t
| longvarands of Longvar.t list
- | longcon of Longcon.t
| longvid of Longvid.t
| longvidNoEqual of Longvid.t
- | longstrid of Longstrid.t
- | longstrids of Longstrid.t list
-
- | tlabel of (Field.t * Type.t)
- | tlabels of (Field.t * Type.t) list
- | ty' of Type.t
- | ty'node of Type.node
- | tuple_ty of Type.t list
- | ty of Type.t
- | tynode of Type.node
- | ty1 of Type.t
- | tyOpt of Type.t option
- | ty0_pc of Type.t list
-
| match of Match.t
- | rules of rule list
- | rule of rule
- | elabel of (Field.t * Exp.t)
- | elabels of (Field.t * Exp.t) list
- | exp_ps of Exp.t list
- | exp of Exp.t
- | expnode of Exp.node
- | app_exp of Exp.t list
- | app_exp1 of Exp.t list
- | aexp of Exp.node
+ | opaspat of Pat.t option
+ | opcon of Con.t
| ot_list of Exp.t list
- | exp_2c of Exp.t list
- | exp_list of Exp.t list
-
| pat of Pat.t
- | patnode of Pat.node
- | apats of Pat.t list
- | apat of Pat.t
- | apatnode of Pat.node
- | apat' of Pat.t
- | patitems of (Pat.Item.t list * bool)
- | patitem of Pat.Item.t
| pat_2c of Pat.t list
+ | patitem of Pat.Item.t
+ | patitems of (Pat.Item.t list * bool)
+ | patnode of Pat.node
| pats of Pat.t list
- | commapats of Pat.t list
- | opaspat of Pat.t option
-
- | valbindTop of vb vector * rvb vector
- | valbind of vb list * rvb list
- | valbindRest of vb list * rvb list
+ | program of Program.t
+ | repl of DatatypeRhs.node
+ | rule of rule
+ | rules of rule list
| rvalbind of rvb list
| rvalbindRest of rvb list
- | constraint of Type.t option
- | funs of clauses list
- | clausesTop of clauses
- | clauses of clause list
- | clause of clause
-
- | typBind of TypBind.t
- | typBind' of TypBind.node
-
- | tyvars of Tyvar.t vector
- | tyvarseq of Tyvar.t vector
- | tyvar_pc of Tyvar.t list
- | constrs of (Con.t * Type.t option) list
- | constr of Con.t * Type.t option
- | ebs of eb list
- | eb of eb
- | ebrhs of EbRhs.t
- | ebrhsnode of EbRhs.node
- | fixity of Fixity.t
-
- | dec of Dec.t
- | decnode of Dec.node
- | decnolocal of Dec.node
- | decs of Dec.t
- | decsnode of Dec.node
-
- | specs of Spec.t
- | spec of Spec.t
- | specnode of Spec.node
+ | sdec of Dec.t
+ | sdecs of Dec.t
+ | sdecsPlus of Dec.t
| sharespec of Equation.node
-
- | strdescs of strdesc list
- | strdescs' of strdesc whereAnd
- | strdescs'' of strdesc whereAnd
-
- | typdescs of typdesc list
- | typdesc of typdesc
- | typdefs of typdef list
- | typdef of typdef
- | valdescs of valdesc list
- | valdesc of valdesc
- | exndescs of exndesc list
- | exndesc of exndesc
- | longtyconeqns of Longtycon.t list
- | longstrideqns of Longstrid.t list
-
- | wherespec of wherespec
-
+ | sigbinds of sigbind list
+ | sigbinds' of sigbind whereAnd
+ | sigbinds'' of sigbind whereAnd
+ | sigconst of SigConst.t
| sigexp of Sigexp.t
- | sigexpnode of Sigexp.node
| sigexp' of Sigexp.t
| sigexp'node of Sigexp.node
- | sigconst of SigConst.t
- | arg_fct of Strexp.t
- | sdecs of Dec.t
- | sdec of Dec.t
- | sdecsPlus of Dec.t
-
+ | sigexpnode of Sigexp.node
+ | sigid of Sigid.t
+ | sigids of Sigid.t list
+ | spec of Spec.t
+ | specnode of Spec.node
+ | specs of Spec.t
| strbinds of strbind list
| strbinds' of Strexp.t * strbind list
| strbinds'1 of strbind whereAnd
- | strbinds'2 of strbind list
| strbinds'1' of strbind whereAnd
-
- | sigbinds of sigbind list
- | sigbinds' of sigbind whereAnd
- | sigbinds'' of sigbind whereAnd
-
- | wherespecs of wherespec list
- | andspecs of wherespec list
-
- | funbinds of funbind list
- | funbinds' of Strexp.t * funbind list
- | funbinds'1 of funbind whereAnd
- | funbinds'1' of funbind whereAnd
- | funbinds'2 of funbind list
- | fctarg of FctArg.node
-
- | datatypeRhs of DatatypeRhs.t
- | datatypeRhsNoWithtype of DatatypeRhs.t
- | datatypeRhsnode of DatatypeRhs.node
- | datatypeRhsnodeNoWithtype of DatatypeRhs.node
- | repl of DatatypeRhs.node
- | datBind of DatBind.t
- | datBindNoWithtype of DatBind.t
- | db of db
- | dbs of db list
- | withtypes of TypBind.t
- | strdecs of Strdec.t
- | strdecsnode of Strdec.node
+ | strbinds'2 of strbind list
| strdec of Strdec.t
| strdecnode of Strdec.node
- | topdec of Topdec.t
- | topdecnode of Topdec.node
- | topdecs of Topdec.t list
- | leadExps of Topdec.t list
- | program of Program.t
-
+ | strdecs of Strdec.t
+ | strdecsnode of Strdec.node
+ | strdescs of strdesc list
+ | strdescs' of strdesc whereAnd
+ | strdescs'' of strdesc whereAnd
| strexp of Strexp.t
- | strexpnode of Strexp.node
| strexp1 of Strexp.t * (Sigexp.t -> SigConst.t) * Sigexp.t
| strexp2 of Strexp.t
| strexp2node of Strexp.node
+ | strexpnode of Strexp.node
+ | strid of Strid.t
+ | tlabel of (Field.t * Type.t)
+ | tlabels of (Field.t * Type.t) list
+ | topdec of Topdec.t
+ | topdecnode of Topdec.node
+ | topdecs of Topdec.t list
+ | tuple_ty of Type.t list
+ | ty of Type.t
+ | ty' of Type.t
+ | ty'node of Type.node
+ | ty0_pc of Type.t list
+ | ty1 of Type.t
+ | tyOpt of Type.t option
+ | tycon of Tycon.t
+ | tynode of Type.node
+ | typBind of TypBind.t
+ | typBind' of TypBind.node
+ | typdef of typdef
+ | typdefs of typdef list
+ | typdesc of typdesc
+ | typdescs of typdesc list
+ | tyvar of Tyvar.t
+ | tyvar_pc of Tyvar.t list
+ | tyvars of Tyvar.t vector
+ | tyvarseq of Tyvar.t vector
+ | valbind of vb list * rvb list
+ | valbindRest of vb list * rvb list
+ | valbindTop of vb vector * rvb vector
+ | valdesc of valdesc
+ | valdescs of valdesc list
+ | var of Var.t
+ | vid of Vid.t
+ | vidNoEqual of Vid.t
+ | vids of Vid.t list
+ | wherespec of wherespec
+ | wherespecs of wherespec list
+ | withtypes of TypBind.t
%verbose
%pos SourcePos.t
@@ -414,7 +397,7 @@
%noshift EOF
%header (functor MLLrValsFun (structure Token: TOKEN
- structure Ast: AST))
+ structure Ast: AST))
%nonassoc WITHTYPE
%right AND
@@ -811,15 +794,13 @@
| INFIXR digit (Fixity.Infixr (SOME digit))
| NONFIX (Fixity.Nonfix)
-int : INT (case Int.fromString INT of
- NONE => (error (reg (INTleft, INTright), "expected integer");
- ~1)
- | SOME n => n)
+int : INT (INT)
-digit : int (if int < 0 orelse int >= 10
- then (error (reg (intleft, intright), "expected single digit") ;
- 0)
- else int)
+digit : int (if IntInf.< (int, IntInf.fromInt 0)
+ orelse IntInf.>= (int, IntInf.fromInt 10)
+ then (error (reg (intleft, intright), "expected single digit")
+ ; 0)
+ else IntInf.toInt int)
datatypeRhs : datatypeRhsnode (DatatypeRhs.makeRegion' (datatypeRhsnode,
datatypeRhsnodeleft,
@@ -1066,14 +1047,23 @@
tyvar : TYVAR (Tyvar.newString (TYVAR, {left = TYVARleft,
right = TYVARright}))
field : id (Field.String (#1 id))
- | int (Field.Int
- (if int <= 0
- then (error (reg (intleft, intright),
- "expected integer")
- ; ~1)
- else
- int - 1))
- (* The int - 1 is because fields are represented zero based. *)
+ | int (let
+ val int =
+ IntInf.toInt int
+ handle Exn.Overflow =>
+ (error (reg (intleft, intright),
+ "field too huge")
+ ; 0)
+ in
+ Field.Int
+ (if int <= 0
+ then (error (reg (intleft, intright),
+ "nonpositive field")
+ ; ~1)
+ else
+ int - 1)
+ end) (* int - 1 because fields are 0-based *)
+
strid : id (Strid.fromString id)
sigid : id (Sigid.fromString id)
sigids : sigid ([sigid])
1.9 +33 -26 mlton/mlton/front-end/ml.lex
Index: ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- ml.lex 28 Feb 2002 18:29:49 -0000 1.8
+++ ml.lex 23 Jun 2003 04:58:59 -0000 1.9
@@ -87,26 +87,27 @@
fun tok' (t, x, s, l) = tok (fn (l, r) => t (x, l, r), s, l, l + size x)
-local
- fun make (scan, token, default, msg) (radix, str, source, left) =
- let
- val right = left + size str
- in
- token ((case StringCvt.scanString (scan radix) str of
- NONE => (error (source, left, right,
- concat ["invalid ", msg, " constant"])
- ; default)
- | SOME n => n)
- handle Overflow =>
- (error (source, left, right,
- concat [msg, " constant out of range"])
- ; default),
- Source.getPos (source, left),
- Source.getPos (source, right))
- end
-in
- val makeWord = make (Word32.scan, Tokens.WORD, 0w0, "word")
-end
+fun scanInt (yytext: string,
+ start: int,
+ radix: StringCvt.radix,
+ negate: bool,
+ makeToken,
+ source,
+ yypos: int) =
+ let
+ val str = String.dropPrefix (yytext, start)
+ val left = yypos
+ val right = left + size str
+ in
+ makeToken ((case (StringCvt.scanString
+ (fn r => IntInf.scan (radix, r)) str) of
+ NONE => (error (source, left, right,
+ concat ["invalid constant: ", yytext])
+ ; IntInf.fromInt 0)
+ | SOME n => if negate then IntInf.~ n else n),
+ Source.getPos (source, left),
+ Source.getPos (source, right))
+ end
%%
%reject
@@ -208,12 +209,18 @@
"*" => tok (Tokens.ASTERISK, source, yypos, yypos + 1)
| _ => tok' (Tokens.LONGID, yytext, source, yypos));
<INITIAL>{real} => (tok' (Tokens.REAL, yytext, source, yypos));
-<INITIAL>{num} => (tok' (Tokens.INT, yytext, source, yypos));
-<INITIAL>~{num} => (tok' (Tokens.INT, yytext, source, yypos));
-<INITIAL>"0x"{hexnum} => (tok' (Tokens.INT, yytext, source, yypos));
-<INITIAL>"~0x"{hexnum} => (tok' (Tokens.INT, yytext, source, yypos));
-<INITIAL>"0w"{num} => (makeWord (StringCvt.DEC, yytext, source, yypos));
-<INITIAL>"0wx"{hexnum} => (makeWord (StringCvt.HEX, yytext, source, yypos));
+<INITIAL>{num} => (scanInt (yytext, 0, StringCvt.DEC, false, Tokens.INT,
+ source, yypos));
+<INITIAL>~{num} => (scanInt (yytext, 1, StringCvt.DEC, true, Tokens.INT,
+ source, yypos));
+<INITIAL>"0x"{hexnum} => (scanInt (yytext, 2, StringCvt.HEX, false, Tokens.INT,
+ source, yypos));
+<INITIAL>"~0x"{hexnum} => (scanInt (yytext, 3, StringCvt.HEX, true, Tokens.INT,
+ source, yypos));
+<INITIAL>"0w"{num} => (scanInt (yytext, 2, StringCvt.DEC, false, Tokens.WORD,
+ source, yypos));
+<INITIAL>"0wx"{hexnum} => (scanInt (yytext, 3, StringCvt.HEX, false, Tokens.WORD,
+ source, yypos));
<INITIAL>\" => (charlist := [""]
; stringStart := Source.getPos (source, yypos)
; stringtype := true
1.52 +33 -12 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- compile.sml 14 May 2003 02:50:12 -0000 1.51
+++ compile.sml 23 Jun 2003 04:58:59 -0000 1.52
@@ -13,15 +13,30 @@
(*---------------------------------------------------*)
structure Ast = Ast ()
-structure Atoms = Atoms (structure Ast = Ast)
+local
+ open Ast.Tycon
+in
+ structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize
+end
+structure Atoms = Atoms (structure Ast = Ast
+ structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize)
+local
+ open Atoms
+in
+ structure Const = Const
+ structure IntX = IntX
+end
structure CoreML = CoreML (open Atoms
structure Type = Prim.Type)
structure Xml = Xml (open Atoms)
structure Sxml = Sxml (open Xml)
structure Ssa = Ssa (open Atoms)
-structure Machine = Machine (structure Label = Ssa.Label
- structure Prim = Atoms.Prim
- structure SourceInfo = Ssa.SourceInfo)
+structure Machine = Machine (open Atoms
+ structure Label = Ssa.Label)
local
open Machine
in
@@ -40,6 +55,11 @@
structure Infer = Infer (structure CoreML = CoreML
structure LookupConstant = LookupConstant
structure Xml = Xml)
+local
+ open Infer
+in
+ structure BuildConst = BuildConst
+end
structure Monomorphise = Monomorphise (structure Xml = Xml
structure Sxml = Sxml)
structure ClosureConvert = ClosureConvert (structure Ssa = Ssa
@@ -342,15 +362,16 @@
CoreML.Program.layoutStats coreML)
val buildConstants =
let
- datatype z = datatype LookupConstant.Const.t
+ val bool = BuildConst.Bool
+ val int = BuildConst.Int
open Control
in
- [("Exn_keepHistory", Bool (!exnHistory)),
- ("MLton_detectOverflow", Bool (!detectOverflow)),
- ("MLton_native", Bool (!Native.native)),
- ("MLton_profile_isOn", Bool (!profile <> ProfileNone)),
- ("MLton_safe", Bool (!safe)),
- ("TextIO_bufSize", Int (!textIOBufSize))]
+ [("Exn_keepHistory", bool (!exnHistory)),
+ ("MLton_detectOverflow", bool (!detectOverflow)),
+ ("MLton_native", bool (!Native.native)),
+ ("MLton_profile_isOn", bool (!profile <> ProfileNone)),
+ ("MLton_safe", bool (!safe)),
+ ("TextIO_bufSize", int (!textIOBufSize))]
end
fun lookupBuildConstant (c: string) =
case List.peek (buildConstants, fn (c', _) => c = c') of
@@ -365,7 +386,7 @@
let
fun get s =
case lookupConstant s of
- LookupConstant.Const.Int n => n
+ Const.Int i => IntX.toInt i
| _ => Error.bug "GC_state offset must be an int"
in
Runtime.GCField.setOffsets
1.21 +7 -9 mlton/mlton/ssa/analyze.fun
Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- analyze.fun 11 Jan 2003 00:34:40 -0000 1.20
+++ analyze.fun 23 Jun 2003 04:58:59 -0000 1.21
@@ -14,7 +14,7 @@
fun 'a analyze
{coerce, conApp, const, copy,
- filter, filterChar, filterInt, filterWord, filterWord8,
+ filter, filterInt, filterWord,
fromType, layout, primApp,
program = Program.T {main, datatypes, globals, functions},
select, tuple, useFromTypeOnBinds} =
@@ -131,19 +131,17 @@
then ()
else Error.bug (concat [Label.toString j,
" must be nullary"])
- fun doit (l, filter) =
- (filter test
- ; Vector.foreach (l, fn (_, j) => ensureNullary j))
+ fun doit (s, cs, filter) =
+ (filter (test, s)
+ ; Vector.foreach (cs, fn (_, j) => ensureNullary j))
datatype z = datatype Cases.t
val _ =
case cases of
- Char l => doit (l, filterChar)
- | Con cases =>
+ Con cases =>
Vector.foreach (cases, fn (c, j) =>
filter (test, c, labelValues j))
- | Int l => doit (l, filterInt)
- | Word l => doit (l, filterWord)
- | Word8 l => doit (l, filterWord8)
+ | Int (s, cs) => doit (s, cs, filterInt)
+ | Word (s, cs) => doit (s, cs, filterWord)
val _ = Option.app (default, ensureNullary)
in ()
end
1.9 +2 -4 mlton/mlton/ssa/analyze.sig
Index: analyze.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- analyze.sig 7 Jul 2002 21:41:51 -0000 1.8
+++ analyze.sig 23 Jun 2003 04:58:59 -0000 1.9
@@ -25,10 +25,8 @@
const: Const.t -> 'a,
copy: 'a -> 'a,
filter: 'a * Con.t * 'a vector -> unit,
- filterChar: 'a -> unit,
- filterInt: 'a -> unit,
- filterWord: 'a -> unit,
- filterWord8: 'a -> unit,
+ filterInt: 'a * IntSize.t -> unit,
+ filterWord: 'a * WordSize.t -> unit,
fromType: Type.t -> 'a,
layout: 'a -> Layout.t,
primApp: {args: 'a vector,
1.23 +2 -2 mlton/mlton/ssa/common-subexp.fun
Index: common-subexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/common-subexp.fun,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- common-subexp.fun 19 Dec 2002 23:43:35 -0000 1.22
+++ common-subexp.fun 23 Jun 2003 04:58:59 -0000 1.23
@@ -206,10 +206,10 @@
case Prim.name prim of
Array_array => knownLength (arg ())
| Array_length => length ()
- | Vector_fromArray => conv ()
- | String_fromWord8Vector => conv ()
+ | Array_toVector => conv ()
| String_toWord8Vector => conv ()
| Vector_length => length ()
+ | Word8Vector_toString => conv ()
| _ => if Prim.isFunctional prim
then doit ()
else keep ()
1.16 +39 -52 mlton/mlton/ssa/constant-propagation.fun
Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- constant-propagation.fun 18 Apr 2003 22:45:00 -0000 1.15
+++ constant-propagation.fun 23 Jun 2003 04:58:59 -0000 1.16
@@ -61,8 +61,8 @@
fun isZero (T {const, ...}) =
case !const of
Const c =>
- (case Const.node c of
- Const.Node.Int 0 => true
+ (case c of
+ Const.Int i => IntX.isZero i
| _ => false)
| _ => false
@@ -398,41 +398,44 @@
in new (Const c', Type.ofConst c)
end
- val zero = const (S.Const.fromInt 0)
+ val zero = IntSize.memoize (fn s => const (S.Const.int (IntX.zero s)))
fun deconst v =
case value v of
Const c => c
| _ => Error.bug "deconst"
+
+ fun constToEltLength (c, err) =
+ let
+ val v = case c of
+ Sconst.Word8Vector v => v
+ | _ => Error.bug err
+ val n = Vector.length v
+ val x = if n = 0
+ then const' (Const.unknown (), Type.word8)
+ else let
+ val w = Vector.sub (v, 0)
+ in
+ if Vector.forall (v, fn w' => w = w')
+ then const (Sconst.word8 w)
+ else const' (Const.unknown (), Type.word8)
+ end
+ val n =
+ const (Sconst.Int (IntX.make
+ (IntInf.fromInt n, IntSize.default)))
+ in
+ {elt = x, length = n}
+ end
local
fun make (err, sel) v =
case value v of
Vector fs => sel fs
- | Const (Const.T {const = ref (Const.Const c), coercedTo}) =>
- let
- val s = case Sconst.node c of
- Sconst.Node.String s => s
- | _ => Error.bug err
- val n = String.length s
- val x = if n = 0
- then const' (Const.unknown(), Type.char)
- else let
- val c = String.sub (s, 0)
- in
- if String.forall (s, fn c' => c = c')
- then (const o Sconst.make)
- (Sconst.Node.Char c,
- Sconst.Type.char)
- else const' (Const.unknown(), Type.char)
- end
- val n = (const o Sconst.make)
- (Sconst.Node.Int n, Sconst.Type.int)
- in
- sel {length = n, elt = x}
- end
+ | Const (Const.T {const = ref (Const.Const c), ...}) =>
+ sel (constToEltLength (c, err))
| _ => Error.bug err
- in val devector = make ("devector", #elt)
+ in
+ val devector = make ("devector", #elt)
val vectorLength = make ("vectorLength", #length)
end
@@ -496,13 +499,13 @@
(case Type.dest t of
Type.Array t => Array {birth = arrayBirth (),
elt = loop t,
- length = loop Type.int}
+ length = loop Type.defaultInt}
| Type.Datatype _ => Datatype (data ())
| Type.Ref t => Ref {arg = loop t,
birth = refBirth ()}
| Type.Tuple ts => Tuple (Vector.map (ts, loop))
| Type.Vector t => Vector {elt = loop t,
- length = loop Type.int}
+ length = loop Type.defaultInt}
| Type.Weak t => Weak (loop t)
| _ => Const (const ()),
t)
@@ -662,28 +665,13 @@
| (Tuple vs, Tuple vs') => coerces {froms = vs, tos = vs'}
| (Weak v, Weak v') => unify (v, v')
| (Const (Const.T {const = ref (Const.Const c), coercedTo}),
- Vector {length, elt}) =>
+ Vector {elt, length}) =>
let
- val s = case Sconst.node c of
- Sconst.Node.String s => s
- | _ => error ()
- val n = String.length s
- val x = if n = 0
- then const' (Const.unknown(), Type.char)
- else let
- val c = String.sub (s, 0)
- in
- if String.forall (s, fn c' => c = c')
- then (const o Sconst.make)
- (Sconst.Node.Char c,
- Sconst.Type.char)
- else const' (Const.unknown(), Type.char)
- end
- val n = (const o Sconst.make)
- (Sconst.Node.Int n, Sconst.Type.int)
+ val {elt = elt', length = length'} =
+ Value.constToEltLength (c, "coerce")
in
- coerce {from = x, to = elt}
- ; coerce {from = n, to = length}
+ coerce {from = elt', to = elt}
+ ; coerce {from = length', to = length}
end
| (_, _) => error ()
end) arg
@@ -785,9 +773,11 @@
in
case Prim.name prim of
Array_array => array (arg 0, bear ())
- | Array_array0Const => array (zero, Birth.here ())
+ | Array_array0Const =>
+ array (zero IntSize.default, Birth.here ())
| Array_length => arrayLength (arg 0)
| Array_sub => dearray (arg 0)
+ | Array_toVector => vectorFromArray (arg 0)
| Array_update => update (arg 0, arg 2)
| Ref_assign =>
(coerce {from = arg 1, to = deref (arg 0)}; unit ())
@@ -802,7 +792,6 @@
in
r
end
- | Vector_fromArray => vectorFromArray (arg 0)
| Vector_length => vectorLength (arg 0)
| Vector_sub => devector (arg 0)
| Weak_get => deweak (arg 0)
@@ -847,10 +836,8 @@
const = Value.const,
copy = Value.fromType o Value.ty,
filter = filter,
- filterChar = filterIgnore,
filterInt = filterIgnore,
filterWord = filterIgnore,
- filterWord8 = filterIgnore,
fromType = Value.fromType,
layout = Value.layout,
primApp = primApp,
1.14 +10 -16 mlton/mlton/ssa/direct-exp.fun
Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- direct-exp.fun 11 Jan 2003 00:34:40 -0000 1.13
+++ direct-exp.fun 23 Jun 2003 04:58:59 -0000 1.14
@@ -60,13 +60,11 @@
ty: Type.t}
| Var of Var.t * Type.t
and cases =
- Char of (char * t) vector
- | Con of {con: Con.t,
+ Con of {con: Con.t,
args: (Var.t * Type.t) vector,
body: t} vector
- | Int of (int * t) vector
- | Word of (word * t) vector
- | Word8 of (Word8.t * t) vector
+ | Int of IntSize.t * (IntX.t * t) vector
+ | Word of WordSize.t * (WordX.t * t) vector
val arith = Arith
val call = Call
@@ -113,7 +111,7 @@
val falsee = make Con.falsee
end
-val int = const o Const.fromInt
+val int = const o Const.int
fun eq (e1, e2, ty) =
primApp {prim = Prim.eq,
@@ -154,15 +152,13 @@
doit (v, (fn (x, e) => (f x, e)))
in
case cases of
- Char v => simple (v, Char.layout)
- | Con v =>
+ Con v =>
doit (v, fn {con, args, body} =>
(seq [Con.layout con,
Vector.layout (Var.layout o #1) args],
body))
- | Int v => simple (v, Int.layout)
- | Word v => simple (v, Word.layout)
- | Word8 v => simple (v, Word8.layout)
+ | Int (_, v) => simple (v, IntX.layout)
+ | Word (_, v) => simple (v, WordX.layout)
end,
case default of
NONE => empty
@@ -433,16 +429,14 @@
(c, newLabel0 (e, h, k)))
in
case cases of
- Char v => Cases.Char (doit v)
- | Con v =>
+ Con v =>
Cases.Con
(Vector.map
(v, fn {con, args, body} =>
(con,
newLabel (args, body, h, k))))
- | Int v => Cases.Int (doit v)
- | Word v => Cases.Word (doit v)
- | Word8 v => Cases.Word8 (doit v)
+ | Int (s, v) => Cases.Int (s, doit v)
+ | Word (s, v) => Cases.Word (s, doit v)
end}})
end
| ConApp {con, args, ty} =>
1.12 +4 -6 mlton/mlton/ssa/direct-exp.sig
Index: direct-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- direct-exp.sig 10 Jan 2003 18:36:13 -0000 1.11
+++ direct-exp.sig 23 Jun 2003 04:58:59 -0000 1.12
@@ -22,13 +22,11 @@
type t
datatype cases =
- Char of (char * t) vector
- | Con of {con: Con.t,
+ Con of {con: Con.t,
args: (Var.t * Type.t) vector,
body: t} vector
- | Int of (int * t) vector
- | Word of (word * t) vector
- | Word8 of (Word8.t * t) vector
+ | Int of IntSize.t * (IntX.t * t) vector
+ | Word of WordSize.t * (WordX.t * t) vector
val arith: {prim: Prim.t,
args: t vector,
@@ -59,7 +57,7 @@
ty: Type.t,
catch: Var.t * Type.t,
handler: t} -> t
- val int: int -> t
+ val int: IntX.t -> t
val layout: t -> Layout.t
val lett: {decs: {var: Var.t, exp: t} list,
body: t} -> t
1.15 +26 -23 mlton/mlton/ssa/poly-equal.fun
Index: poly-equal.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/poly-equal.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- poly-equal.fun 2 Jan 2003 17:45:21 -0000 1.14
+++ poly-equal.fun 23 Jun 2003 04:58:59 -0000 1.15
@@ -44,10 +44,10 @@
open DirectExp
fun add (e1: t, e2: t): t =
- primApp {prim = Prim.intAdd,
+ primApp {prim = Prim.intAdd IntSize.default,
targs = Vector.new0 (),
args = Vector.new2 (e1, e2),
- ty = Type.int}
+ ty = Type.defaultInt}
fun conjoin (e1: t, e2: t): t =
casee {test = e1,
@@ -199,18 +199,19 @@
let
fun length x =
Dexp.primApp {prim = Prim.vectorLength,
- targs = Vector.new1 ty,
- args = Vector.new1 x,
- ty = Type.int}
+ targs = Vector.new1 ty,
+ args = Vector.new1 x,
+ ty = Type.defaultInt}
in
Dexp.disjoin
(Dexp.eq (Dexp.var v1, Dexp.var v2, vty),
Dexp.conjoin
- (Dexp.eq (length dv1, length dv2, Type.int),
+ (Dexp.eq (length dv1, length dv2, Type.defaultInt),
Dexp.call
{func = loop,
args = (Vector.new4
- (Dexp.int 0, length dv1, dv1, dv2)),
+ (Dexp.int (IntX.zero IntSize.default),
+ length dv1, dv1, dv2)),
ty = Type.bool}))
end
val (start, blocks) = Dexp.linearize (body, Handler.Caller)
@@ -225,8 +226,8 @@
start = start}
end
local
- val i = (Var.newNoname (), Type.int)
- val len = (Var.newNoname (), Type.int)
+ val i = (Var.newNoname (), Type.defaultInt)
+ val len = (Var.newNoname (), Type.defaultInt)
val v1 = (Var.newNoname (), vty)
val v2 = (Var.newNoname (), vty)
val args = Vector.new4 (i, len, v1, v2)
@@ -241,17 +242,19 @@
targs = Vector.new1 ty,
args = Vector.new2 (v, i),
ty = ty}
+ val args =
+ Vector.new4
+ (Dexp.add
+ (di, Dexp.int (IntX.one IntSize.default)),
+ dlen, dv1, dv2)
in
Dexp.disjoin
- (Dexp.eq (di, dlen, Type.int),
+ (Dexp.eq (di, dlen, Type.defaultInt),
Dexp.conjoin
(equalExp (sub (dv1, di), sub (dv2, di), ty),
- Dexp.call
- {func = loop,
- args = (Vector.new4
- (Dexp.add (di, Dexp.int 1),
- dlen, dv1, dv2)),
- ty = Type.bool}))
+ Dexp.call {args = args,
+ func = loop,
+ ty = Type.bool}))
end
val (start, blocks) = Dexp.linearize (body, Handler.Caller)
val blocks = Vector.fromList blocks
@@ -283,14 +286,13 @@
in
case Type.dest ty of
Type.Array _ => eq ()
- | Type.Char => eq ()
| Type.Datatype tycon =>
if isEnum tycon orelse hasConstArg ()
then eq ()
else Dexp.call {func = equalFunc tycon,
args = Vector.new2 (dx1, dx2),
ty = Type.bool}
- | Type.Int => eq ()
+ | Type.Int _ => eq ()
| Type.IntInf => if hasConstArg ()
then eq ()
else prim (Prim.intInfEqual, Vector.new0 ())
@@ -320,8 +322,7 @@
Dexp.call {func = vectorEqualFunc ty,
args = Vector.new2 (dx1, dx2),
ty = Type.bool}
- | Type.Word => eq ()
- | Type.Word8 => eq ()
+ | Type.Word _ => eq ()
| _ => Error.bug "equal of strange type"
end
fun loopBind (Statement.T {var, ty, exp}) =
@@ -330,13 +331,15 @@
in
case exp of
Const c =>
- (case Const.node c of
- Const.Node.IntInf i =>
+ (case c of
+ Const.Int _ => const ()
+ | Const.IntInf i =>
if Const.SmallIntInf.isSmall i
then const ()
else ()
| _ => ())
- | ConApp {args, ...} => if Vector.isEmpty args then const () else ()
+ | ConApp {args, ...} =>
+ if Vector.isEmpty args then const () else ()
| _ => ()
end
val _ = Vector.foreach (globals, loopBind)
1.12 +51 -64 mlton/mlton/ssa/redundant-tests.fun
Index: redundant-tests.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant-tests.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- redundant-tests.fun 19 Dec 2002 23:43:36 -0000 1.11
+++ redundant-tests.fun 23 Jun 2003 04:58:59 -0000 1.12
@@ -38,7 +38,7 @@
fn Const c => Const.layout c
| Var x => Var.layout x
- val zero = Const (Const.fromInt 0)
+ val zero = IntSize.memoize (fn s => Const (Const.int (IntX.zero s)))
val equals =
fn (Const c, Const c') => Const.equals (c, c')
| (Var x, Var x') => Var.equals (x, x')
@@ -117,37 +117,19 @@
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
- Char_gt => doit' LT
- | Char_ge => doit' LE
- | Char_lt => doit LT
+ Char_ge => doit' LE
+ | Char_gt => doit' LT
| Char_le => doit LE
- | Int_gt => doit' LT
- | Int_ge => doit' LE
- | Int_geu =>
- Or (Fact.T {rel = LT,
- lhs = arg 0,
- rhs = Oper.zero},
- Fact.T {rel = LE,
- lhs = arg 1,
- rhs = arg 0})
- | Int_gtu =>
- Or (Fact.T {rel = LT,
- lhs = arg 0,
- rhs = Oper.zero},
- Fact.T {rel = LT,
- lhs = arg 1,
- rhs = arg 0})
- | Int_lt => doit LT
- | Int_le => doit LE
+ | Char_lt => doit LT
+ | Int_ge _ => doit' LE
+ | Int_gt _ => doit' LT
+ | Int_le _ => doit LE
+ | Int_lt _ => doit LT
| MLton_eq => doit EQ
- | Word32_ge => doit' LE
- | Word32_gt => doit' LT
- | Word32_le => doit LE
- | Word32_lt => doit LT
- | Word8_ge => doit' LE
- | Word8_gt => doit' LT
- | Word8_le => doit LE
- | Word8_lt => doit LT
+ | Word_ge _ => doit' LE
+ | Word_gt _ => doit' LT
+ | Word_le _ => doit LE
+ | Word_lt _ => doit LT
| _ => None
end
fun setConst (x, c) = setVarInfo (x, Const c)
@@ -172,9 +154,10 @@
val (falseVar, f) = make Con.falsee
end
val one = Var.newNoname ()
- val oneS = Statement.T {exp = Exp.Const (Const.fromInt 1),
- var = SOME one,
- ty = Type.int}
+ val oneS =
+ Statement.T {exp = Exp.Const (Const.int (IntX.one IntSize.default)),
+ ty = Type.defaultInt,
+ var = SOME one}
val globals = Vector.concat [Vector.new3 (t, f, oneS), globals]
val shrink = shrinkFunction globals
val numSimplified = ref 0
@@ -373,7 +356,7 @@
success: Label.t)
: Statement.t vector * Transfer.t =
let
- fun simplify (prim: Prim.t, x: Var.t) =
+ fun simplify (prim: Prim.t, x: Var.t, s: IntSize.t) =
let
val res = Var.newNoname ()
in
@@ -384,75 +367,79 @@
{exp = PrimApp {args = Vector.new2 (x, one),
prim = prim,
targs = Vector.new0 ()},
- ty = Type.int,
+ ty = Type.int s,
var = SOME res})],
Goto {args = Vector.new1 res,
dst = success})
end
- fun add1 (x: Var.t) =
+ fun add1 (x: Var.t, s: IntSize.t) =
if isFact (label, fn Fact.T {lhs, rel, rhs} =>
case (lhs, rel, rhs) of
(Oper.Var x', Rel.LT, _) =>
Var.equals (x, x')
| (Oper.Var x', Rel.LE, Oper.Const c) =>
Var.equals (x, x')
- andalso (case Const.node c of
- Const.Node.Int c =>
- c < Int.maxInt
- | _ => Error.bug "strange fact")
+ andalso
+ (case c of
+ Const.Int i =>
+ IntX.<
+ (i, IntX.max (IntX.size i))
+ | _ => Error.bug "strange fact")
| _ => false)
- then simplify (Prim.intAdd, x)
+ then simplify (Prim.intAdd s, x, s)
else noChange
- fun sub1 (x: Var.t) =
+ fun sub1 (x: Var.t, s: IntSize.t) =
if isFact (label, fn Fact.T {lhs, rel, rhs} =>
case (lhs, rel, rhs) of
(_, Rel.LT, Oper.Var x') =>
Var.equals (x, x')
| (Oper.Const c, Rel.LE, Oper.Var x') =>
Var.equals (x, x')
- andalso (case Const.node c of
- Const.Node.Int c =>
- c > Int.minInt
- | _ => Error.bug "strange fact")
+ andalso
+ (case c of
+ Const.Int i =>
+ IntX.>
+ (i, IntX.min (IntX.size i))
+ | _ => Error.bug "strange fact")
| _ => false)
- then simplify (Prim.intSub, x)
+ then simplify (Prim.intSub s, x, s)
else noChange
- fun add (c: Const.t, x: Var.t) =
- case Const.node c of
- Const.Node.Int i =>
- if i = 1
- then add1 x
- else if i = ~1
- then sub1 x
+ fun add (c: Const.t, x: Var.t, s: IntSize.t) =
+ case c of
+ Const.Int i =>
+ if IntX.isOne i
+ then add1 (x, s)
+ else if IntX.isNegOne i
+ then sub1 (x, s)
else noChange
| _ => Error.bug "add of strange const"
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
- Int_addCheck =>
+ Int_addCheck s =>
let
val x1 = Vector.sub (args, 0)
val x2 = Vector.sub (args, 1)
in
case varInfo x1 of
- Const c => add (c, x2)
+ Const c => add (c, x2, s)
| _ => (case varInfo x2 of
- Const c => add (c, x1)
+ Const c => add (c, x1, s)
| _ => noChange)
end
- | Int_subCheck =>
+ | Int_subCheck s =>
let
val x1 = Vector.sub (args, 0)
val x2 = Vector.sub (args, 1)
in
case varInfo x2 of
Const c =>
- (case Const.node c of
- Const.Node.Int i =>
- if i = ~1
- then add1 x1
- else if i = 1
- then sub1 x1
+ (case c of
+ Const.Int i =>
+ if IntX.isNegOne i
+ then add1 (x1, s)
+ else if IntX.isOne i
+ then sub1 (x1, s)
else noChange
| _ =>
Error.bug "sub of strage const")
1.24 +4 -6 mlton/mlton/ssa/remove-unused.fun
Index: remove-unused.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/remove-unused.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- remove-unused.fun 11 Jan 2003 00:34:40 -0000 1.23
+++ remove-unused.fun 23 Jun 2003 04:58:59 -0000 1.24
@@ -491,12 +491,10 @@
fun doit l = (Vector.foreach (l, fn (_, l) => visitLabel l);
Option.app (default, visitLabel))
in
- case cases
- of Cases.Char l => doit l
- | Cases.Int l => doit l
- | Cases.Word l => doit l
- | Cases.Word8 l => doit l
- | Cases.Con cases
+ case cases of
+ Cases.Int (_, cs) => doit cs
+ | Cases.Word (_, cs) => doit cs
+ | Cases.Con cases
=> if Vector.length cases = 0
then Option.app (default, visitLabel)
else let
1.31 +10 -15 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- shrink.fun 18 Jun 2003 17:40:50 -0000 1.30
+++ shrink.fun 23 Jun 2003 04:58:59 -0000 1.31
@@ -133,7 +133,7 @@
and aux =
Block
| Bug
- | Case of {cases: Label.t Cases.t,
+ | Case of {cases: Cases.t,
default: Label.t option}
| Goto of {dst: t,
args: Positions.t}
@@ -190,7 +190,7 @@
Trace.trace ("Prim.apply",
fn (p, args, _: VarInfo.t * VarInfo.t -> bool) =>
let open Layout
- in seq [Prim.layout p,
+ in seq [Prim.layout p, str " ",
List.layout (Prim.ApplyArg.layout
(Var.layout o VarInfo.var)) args]
end,
@@ -661,8 +661,7 @@
{con = con,
hasArg = not (Vector.isEmpty args)}
else Prim.ApplyArg.Var vi
- | Value.Const c =>
- Prim.ApplyArg.Const (Const.node c)
+ | Value.Const c => Prim.ApplyArg.Const c
| _ => Prim.ApplyArg.Var vi)
| _ => Prim.ApplyArg.Var vi)
in
@@ -1015,19 +1014,15 @@
case (VarInfo.value test, cases) of
(SOME (Value.Const c), _) =>
let
- fun doit (l, z) =
- findCase (l, fn z' => z = z',
+ fun doit (l, z, eq) =
+ findCase (l, fn z' => eq (z, z'),
Vector.new0 ())
in
- case (cases, Const.node c) of
- (Cases.Char l, Const.Node.Char c) =>
- doit (l, c)
- | (Cases.Int l, Const.Node.Int i) =>
- doit (l, i)
- | (Cases.Word l, Const.Node.Word w) =>
- doit (l, w)
- | (Cases.Word8 l, Const.Node.Word w) =>
- doit (l, Word8.fromWord w)
+ case (cases, c) of
+ (Cases.Int (_, cs), Const.Int i) =>
+ doit (cs, i, IntX.equals)
+ | (Cases.Word (_, cs), Const.Word w) =>
+ doit (cs, w, WordX.equals)
| _ =>
Error.bug "strange constant for cases"
end
1.59 +132 -44 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- ssa-tree.fun 11 May 2003 23:44:01 -0000 1.58
+++ ssa-tree.fun 23 Jun 2003 04:58:59 -0000 1.59
@@ -9,6 +9,9 @@
struct
open S
+datatype z = datatype IntSize.t
+datatype z = datatype RealSize.t
+datatype z = datatype WordSize.t
structure Type =
struct
@@ -23,20 +26,18 @@
datatype dest =
Array of t
- | Char
| Datatype of Tycon.t
- | Int
+ | Int of IntSize.t
| IntInf
| Pointer
| PreThread
- | Real
+ | Real of RealSize.t
| Ref of t
| Thread
| Tuple of t vector
| Vector of t
| Weak of t
- | Word
- | Word8
+ | Word of WordSize.t
local
val {get, set, ...} =
@@ -53,20 +54,21 @@
else Error.bug "bogus application of unary tycon"
val tycons =
- [(Tycon.array, unary Array),
- (Tycon.char, nullary Char),
- (Tycon.int, nullary Int),
- (Tycon.intInf, nullary IntInf),
- (Tycon.pointer, nullary Pointer),
- (Tycon.preThread, nullary PreThread),
- (Tycon.real, nullary Real),
- (Tycon.reff, unary Ref),
- (Tycon.thread, nullary Thread),
- (Tycon.tuple, Tuple),
- (Tycon.vector, unary Vector),
- (Tycon.weak, unary Weak),
- (Tycon.word, nullary Word),
- (Tycon.word8, nullary Word8)]
+ [(Tycon.array, unary Array)]
+ @ List.map (Tycon.ints, fn (t, s) =>
+ (t, nullary (Int s)))
+ @ [(Tycon.intInf, nullary IntInf),
+ (Tycon.pointer, nullary Pointer),
+ (Tycon.preThread, nullary PreThread)]
+ @ List.map (Tycon.reals, fn (t, s) =>
+ (t, nullary (Real s)))
+ @ [(Tycon.reff, unary Ref),
+ (Tycon.thread, nullary Thread),
+ (Tycon.tuple, Tuple),
+ (Tycon.vector, unary Vector),
+ (Tycon.weak, unary Weak)]
+ @ List.map (Tycon.words, fn (t, s) =>
+ (t, nullary (Word s)))
in
val _ = List.foreach (tycons, fn (tycon, f) => set (tycon, SOME f))
@@ -89,13 +91,12 @@
(fn (t, layout) =>
case dest t of
Array t => seq [layout t, str " array"]
- | Char => str "char"
| Datatype t => Tycon.layout t
- | Int => str "int"
+ | Int s => str (concat ["int", IntSize.toString s])
| IntInf => str "IntInf.int"
| Pointer => str "pointer"
| PreThread => str "preThread"
- | Real => str "real"
+ | Real s => str (concat ["real", RealSize.toString s])
| Ref t => seq [layout t, str " ref"]
| Thread => str "thread"
| Tuple ts =>
@@ -105,8 +106,7 @@
" * ")))
| Vector t => seq [layout t, str " vector"]
| Weak t => seq [layout t, str " weak"]
- | Word => str "word"
- | Word8 => str "word8"))
+ | Word s => str (concat ["word", WordSize.toString s])))
end
end
@@ -123,8 +123,96 @@
fun newNoname () = newString "L"
end
-structure Cases = Cases (type con = Con.t
- val conEquals = Con.equals)
+structure Cases =
+ struct
+ datatype t =
+ Con of (Con.t * Label.t) vector
+ | Int of IntSize.t * (IntX.t * Label.t) vector
+ | Word of WordSize.t * (WordX.t * Label.t) vector
+
+ fun equals (c1: t, c2: t): bool =
+ let
+ fun doit (l1, l2, eq') =
+ Vector.equals
+ (l1, l2, fn ((x1, a1), (x2, a2)) =>
+ eq' (x1, x2) andalso Label.equals (a1, a2))
+ in
+ case (c1, c2) of
+ (Con l1, Con l2) => doit (l1, l2, Con.equals)
+ | (Int (_, l1), Int (_, l2)) => doit (l1, l2, IntX.equals)
+ | (Word (_, l1), Word (_, l2)) => doit (l1, l2, WordX.equals)
+ | _ => false
+ end
+
+ fun hd (c: t): Label.t =
+ let
+ fun doit v =
+ if Vector.length v >= 1
+ then let val (_, a) = Vector.sub (v, 0)
+ in a
+ end
+ else Error.bug "Cases.hd"
+ in
+ case c of
+ Con cs => doit cs
+ | Int (_, cs) => doit cs
+ | Word (_, cs) => doit cs
+ end
+
+ fun isEmpty (c: t): bool =
+ let
+ fun doit v = 0 = Vector.length v
+ in
+ case c of
+ Con cs => doit cs
+ | Int (_, cs) => doit cs
+ | Word (_, cs) => doit cs
+ end
+
+ fun fold (c: t, b, f) =
+ let
+ fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
+ in
+ case c of
+ Con l => doit l
+ | Int (_, l) => doit l
+ | Word (_, l) => doit l
+ end
+
+ fun map (c: t, f): t =
+ let
+ fun doit l = Vector.map (l, fn (i, x) => (i, f x))
+ in
+ case c of
+ Con l => Con (doit l)
+ | Int (s, l) => Int (s, doit l)
+ | Word (s, l) => Word (s, doit l)
+ end
+
+ fun forall (c: t, f: Label.t -> bool): bool =
+ let
+ fun doit l = Vector.forall (l, fn (_, x) => f x)
+ in
+ case c of
+ Con l => doit l
+ | Int (_, l) => doit l
+ | Word (_, l) => doit l
+ end
+
+ fun length (c: t): int = fold (c, 0, fn (_, i) => i + 1)
+
+ fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
+
+ fun foreach' (c: t, f: Label.t -> unit, fc: Con.t -> unit): unit =
+ let
+ fun doit l = Vector.foreach (l, fn (_, a) => f a)
+ in
+ case c of
+ Con l => Vector.foreach (l, fn (c, a) => (fc c; f a))
+ | Int (_, l) => doit l
+ | Word (_, l) => doit l
+ end
+ end
local open Layout
in
@@ -544,7 +632,7 @@
func: Func.t,
return: Return.t}
| Case of {test: Var.t,
- cases: Label.t Cases.t,
+ cases: Cases.t,
default: Label.t option} (* Must be nullary. *)
| Goto of {dst: Label.t,
args: Var.t vector}
@@ -556,7 +644,9 @@
fun iff (test: Var.t, {truee, falsee}) =
Case
- {cases = Cases.Int (Vector.new2 ((0, falsee), (1, truee))),
+ {cases = Cases.Int (I32,
+ Vector.new2 ((IntX.zero I32, falsee),
+ (IntX.one I32, truee))),
default = NONE,
test = test}
@@ -640,11 +730,9 @@
datatype z = datatype Cases.t
val cases =
case cases of
- Char l => doit (l, Char.layout)
- | Con l => doit (l, Con.layout)
- | Int l => doit (l, Int.layout)
- | Word l => doit (l, Word.layout)
- | Word8 l => doit (l, Word8.layout)
+ Con l => doit (l, Con.layout)
+ | Int (_, l) => doit (l, IntX.layout)
+ | Word (_, l) => doit (l, WordX.layout)
val cases =
case default of
NONE => cases
@@ -697,9 +785,9 @@
Return.equals (return, return')
| (Case {test, cases, default},
Case {test = test', cases = cases', default = default'}) =>
- Var.equals (test, test') andalso
- Cases.equals (cases, cases', Label.equals) andalso
- Option.equals (default, default', Label.equals)
+ Var.equals (test, test')
+ andalso Cases.equals (cases, cases')
+ andalso Option.equals (default, default', Label.equals)
| (Goto {dst, args}, Goto {dst = dst', args = args'}) =>
Label.equals (dst, dst') andalso
varsEquals (args, args')
@@ -1104,11 +1192,11 @@
edge (j, toString x, Solid))
val _ =
case cases of
- Cases.Char v => doit (v, Char.toString)
- | Cases.Con v => doit (v, Con.toString)
- | Cases.Int v => doit (v, Int.toString)
- | Cases.Word v => doit (v, Word.toString)
- | Cases.Word8 v => doit (v, Word8.toString)
+ Cases.Con v => doit (v, Con.toString)
+ | Cases.Int (_, v) =>
+ doit (v, IntX.toString)
+ | Cases.Word (_, v) =>
+ doit (v, WordX.toString)
val _ =
case default of
NONE => ()
@@ -1757,9 +1845,9 @@
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
- Int_addCheck => doit add
- | Int_subCheck => doit sub
- | Int_mulCheck => doit mul
+ Int_addCheck _ => doit add
+ | Int_subCheck _ => doit sub
+ | Int_mulCheck _ => doit mul
| _ => ()
end
| _ => ())
1.48 +18 -7 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- ssa-tree.sig 11 May 2003 23:44:01 -0000 1.47
+++ ssa-tree.sig 23 Jun 2003 04:58:59 -0000 1.48
@@ -62,20 +62,18 @@
datatype dest =
Array of t
- | Char
| Datatype of Tycon.t
- | Int
+ | Int of IntSize.t
| IntInf
| Pointer
| PreThread
- | Real
+ | Real of RealSize.t
| Ref of t
| Thread
| Tuple of t vector
| Vector of t
| Weak of t
- | Word
- | Word8
+ | Word of WordSize.t
val dest: t -> dest
val tyconArgs: t -> Tycon.t * t vector
@@ -126,7 +124,20 @@
val var: t -> Var.t option
end
- structure Cases: CASES sharing type Cases.con = Con.t
+ structure Cases:
+ sig
+ datatype t =
+ Con of (Con.t * Label.t) vector
+ | Int of IntSize.t * (IntX.t * Label.t) vector
+ | Word of WordSize.t * (WordX.t * Label.t) vector
+
+ val forall: t * (Label.t -> bool) -> bool
+ val foreach: t * (Label.t -> unit) -> unit
+ val hd: t -> Label.t
+ val isEmpty: t -> bool
+ val length: t -> int
+ val map: t * (Label.t -> Label.t) -> t
+ end
structure Handler: HANDLER
sharing Handler.Label = Label
@@ -147,7 +158,7 @@
func: Func.t,
return: Return.t}
| Case of {test: Var.t,
- cases: Label.t Cases.t,
+ cases: Cases.t,
default: Label.t option (* Must be nullary. *)
}
| Goto of {dst: Label.t,
1.23 +7 -11 mlton/mlton/ssa/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- type-check.fun 11 Jan 2003 00:34:40 -0000 1.22
+++ type-check.fun 23 Jun 2003 04:58:59 -0000 1.23
@@ -74,7 +74,6 @@
fn Arith {args, ...} => getVars args
| Bug => ()
| Call {func, args, ...} => (getFunc func; getVars args)
-
| Case {test, cases, default, ...} =>
let
fun doit (cases: ('a * 'b) vector,
@@ -123,12 +122,9 @@
val _ = getVar test
in
case cases of
- Cases.Char cases => doit (cases, Char.equals, Word.fromChar)
- | Cases.Con cases => doitCon cases
- | Cases.Int cases => doit (cases, Int.equals, Word.fromInt)
- | Cases.Word cases => doit (cases, Word.equals, Word.fromWord)
- | Cases.Word8 cases =>
- doit (cases, Word8.equals, Word.fromWord8)
+ Cases.Con cs => doitCon cs
+ | Cases.Int (_, cs) => doit (cs, IntX.equals, IntX.hash)
+ | Cases.Word (_, cs) => doit (cs, WordX.equals, WordX.toWord)
end
| Goto {args, ...} => getVars args
| Raise xs => getVars xs
@@ -407,10 +403,10 @@
const = Type.ofConst,
copy = fn x => x,
filter = filter,
- filterChar = filterGround Type.char,
- filterInt = filterGround Type.int,
- filterWord = filterGround Type.word,
- filterWord8 = filterGround Type.word8,
+ filterInt = fn (from, s) => coerce {from = from,
+ to = Type.int s},
+ filterWord = fn (from, s) => coerce {from = from,
+ to = Type.word s},
fromType = fn x => x,
layout = Type.layout,
primApp = primApp,
1.19 +41 -44 mlton/mlton/ssa/useless.fun
Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- useless.fun 3 Jun 2003 20:04:32 -0000 1.18
+++ useless.fun 23 Jun 2003 04:58:59 -0000 1.19
@@ -252,7 +252,7 @@
case Type.dest t of
Type.Array t =>
let val elt as (_, e) = slot t
- val length = loop Type.int
+ val length = loop Type.defaultInt
in Exists.addHandler
(e, fn () => Useful.makeUseful (deground length))
; Array {useful = useful (),
@@ -262,7 +262,7 @@
| Type.Ref t => Ref {arg = slot t,
useful = useful ()}
| Type.Tuple ts => Tuple (Vector.map (ts, slot))
- | Type.Vector t => Vector {length = loop Type.int,
+ | Type.Vector t => Vector {length = loop Type.defaultInt,
elt = slot t}
| Type.Weak t => Weak {arg = slot t,
useful = useful ()}
@@ -287,7 +287,7 @@
in
v
end
- val int = fromType Type.int
+ val int = fromType Type.defaultInt
fun detupleSlots (v: t): slot vector =
case value v of
@@ -526,17 +526,17 @@
| Array_array0Const => ()
| Array_length => return (arrayLength (arg 0))
| Array_sub => sub ()
+ | Array_toVector =>
+ (case (value (arg 0), value result) of
+ (Array {length = l, elt = e, ...},
+ Vector {length = l', elt = e', ...}) =>
+ (unify (l, l'); unifySlot (e, e'))
+ | _ => Error.bug "strange Array_toVector")
| Array_update => update ()
| MLton_equal => Vector.foreach (args, deepMakeUseful)
| Ref_assign => coerce {from = arg 1, to = deref (arg 0)}
| Ref_deref => return (deref (arg 0))
| Ref_ref => coerce {from = arg 0, to = deref result}
- | Vector_fromArray =>
- (case (value (arg 0), value result) of
- (Array {length = l, elt = e, ...},
- Vector {length = l', elt = e', ...}) =>
- (unify (l, l'); unifySlot (e, e'))
- | _ => Error.bug "strange Vector_fromArray")
| Vector_length => return (vectorLength (arg 0))
| Vector_sub => (arg 1 dependsOn result
; return (devector (arg 0)))
@@ -576,10 +576,8 @@
const = Value.const,
copy = Value.fromType o Value.ty,
filter = filter,
- filterChar = filterGround,
- filterInt = filterGround,
- filterWord = filterGround,
- filterWord8 = filterGround,
+ filterInt = filterGround o #1,
+ filterWord = filterGround o #1,
fromType = Value.fromType,
layout = Value.layout,
primApp = primApp,
@@ -947,37 +945,36 @@
(0, NONE) => ([], Bug)
| _ => ([], t)
datatype z = datatype Cases.t
- in case cases of
- Char l => doit l
- | Int l => doit l
- | Word l => doit l
- | Word8 l => doit l
- | Con cases =>
- case (Vector.length cases, default) of
- (0, NONE) => ([], Bug)
- | _ =>
- let
- val (cases, blocks) =
- Vector.mapAndFold
- (cases, [], fn ((c, l), blocks) =>
- let
- val args = label l
- in if Vector.forall (args, Value.isUseful)
- then ((c, l), blocks)
- else
- let
- val (l', b) =
- dropUseless
- (conArgs c, args, fn args =>
- Goto {dst = l, args = args})
- in ((c, l'), b :: blocks)
- end
- end)
- in (blocks,
- Case {test = test,
- cases = Cases.Con cases,
- default = default})
- end
+ in
+ case cases of
+ Con cases =>
+ (case (Vector.length cases, default) of
+ (0, NONE) => ([], Bug)
+ | _ =>
+ let
+ val (cases, blocks) =
+ Vector.mapAndFold
+ (cases, [], fn ((c, l), blocks) =>
+ let
+ val args = label l
+ in if Vector.forall (args, Value.isUseful)
+ then ((c, l), blocks)
+ else
+ let
+ val (l', b) =
+ dropUseless
+ (conArgs c, args, fn args =>
+ Goto {dst = l, args = args})
+ in ((c, l'), b :: blocks)
+ end
+ end)
+ in (blocks,
+ Case {test = test,
+ cases = Cases.Con cases,
+ default = default})
+ end)
+ | Int (_, cs) => doit cs
+ | Word (_, cs) => doit cs
end
| Goto {dst, args} =>
([], Goto {dst = dst, args = keepUseful (args, label dst)})
1.24 +82 -65 mlton/mlton/type-inference/infer.fun
Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- infer.fun 18 May 2003 23:57:50 -0000 1.23
+++ infer.fun 23 Jun 2003 04:59:00 -0000 1.24
@@ -12,6 +12,8 @@
open CoreML.Atoms
+datatype z = datatype WordSize.t
+
structure Srecord = SortedRecord
structure Field = Record.Field
structure Scope = Scope (structure CoreML = CoreML)
@@ -49,6 +51,13 @@
structure XvarExp = VarExp
end
+structure BuildConst =
+ struct
+ datatype t =
+ Bool of bool
+ | Int of int
+ end
+
structure Type =
struct
open Type
@@ -81,10 +90,8 @@
open Xcases
type t = exp t
- val char = Char
val int = Int
val word = Word
- val word8 = Word8
fun con v =
Con (Vector.map
(v, fn {con, targs, arg, rhs} =>
@@ -170,54 +177,42 @@
fun makeXconst (c: Aconst.t, ty: Type.t): Xconst.t =
let
- val ty = Xconst.Type.make (Xtype.deconConst (Type.toXml (ty, Aconst.region c)))
- datatype z = datatype Xconst.Node.t
fun error m =
Control.error (Aconst.region c,
Layout.str (concat [m, ": ", Aconst.toString c]),
Layout.empty)
+ val ty = Type.toXml (ty, Aconst.region c)
+ fun choose (all, sizeTy, name, make) =
+ case List.peek (all, fn s => Xtype.equals (ty, sizeTy s)) of
+ NONE => Error.bug (concat ["strange ", name, " type: ",
+ Layout.toString (Xtype.layout ty)])
+ | SOME s => make s
in
- Xconst.make
- (case Aconst.node c of
- Aconst.Char c => Char c
- | Aconst.Int s =>
- if Xconst.Type.equals (ty, Xconst.Type.intInf)
- then
- IntInf (stringToIntInf s)
- handle _ => (error "invalid IntInf";
- IntInf (valOf (IntInf.fromString "~1")))
- else
- Int
- (let
- val radix =
- if String.isPrefix {string = s, prefix = "0x"}
- orelse String.isPrefix {string = s, prefix = "~0x"}
- then StringCvt.HEX
- else StringCvt.DEC
- in
- case StringCvt.scanString (Pervasive.Int32.scan radix) s of
- NONE => (error "invalid int constant"; ~1)
- | SOME n =>
- if Xconst.Type.equals (ty, Xconst.Type.int)
- then n
- else (error (concat ["int can't be of type ",
- Xconst.Type.toString ty])
- ; ~1)
- end
- handle Overflow =>
- (error "int constant too big"; ~1))
- | Aconst.Real r => Real r
- | Aconst.String s => String s
- | Aconst.Word w =>
- Word (if Xconst.Type.equals (ty, Xconst.Type.word)
- then w
- else if Xconst.Type.equals (ty, Xconst.Type.word8)
- then if w = Word.andb (w, 0wxFF)
- then w
- else (error "word8 too big"; 0w0)
- else (error ("strange word " ^ (Xconst.Type.toString ty))
- ; 0w0)),
- ty)
+ case Aconst.node c of
+ Aconst.Char c =>
+ Xconst.Word (WordX.make (Word8.toWord (Word8.fromChar c),
+ WordSize.W8))
+ | Aconst.Int i =>
+ if Xtype.equals (ty, Xtype.intInf)
+ then Xconst.IntInf i
+ else
+ choose (IntSize.all, Xtype.int, "int", fn s =>
+ Xconst.Int
+ (IntX.make (i, s)
+ handle Overflow =>
+ (error (concat [Xtype.toString ty, " too big"])
+ ; IntX.zero s)))
+ | Aconst.Real r =>
+ choose (RealSize.all, Xtype.real, "real", fn s =>
+ Xconst.Real (RealX.make (r, s)))
+ | Aconst.String s => Xconst.string s
+ | Aconst.Word w =>
+ choose (WordSize.all, Xtype.word, "word", fn s =>
+ Xconst.Word
+ (if IntInf.<= (w, Word.toIntInf (WordSize.max s))
+ then WordX.fromLargeInt (w, s)
+ else (error (concat [Xtype.toString ty, " too big"])
+ ; WordX.zero s)))
end
fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector =
@@ -1158,30 +1153,52 @@
in
eta (instance, fn (arg, resultType) =>
let
- fun constant c =
- let
- datatype z = datatype LookupConstant.Const.t
- in
- case c of
- Bool b => if b then Xexp.truee ()
- else Xexp.falsee ()
- | Int i => Xexp.const (Const.fromInt i)
- | Real r => Xexp.const (Const.fromReal r)
- | String s =>
- Xexp.const (Const.fromString s)
- | Word w => Xexp.const (Const.fromWord w)
- end
+ datatype z = datatype Prim.Name.t
fun make (args: Xexp.t vector): Xexp.t =
- case Prim.name prim of
- Prim.Name.BuildConstant c =>
- constant (lookupBuildConstant c)
- | Prim.Name.Constant c =>
- constant (lookupConstant c)
- | _ =>
- Xexp.primApp {prim = prim,
+ let
+ fun app p =
+ Xexp.primApp {prim = p,
targs = targs (),
args = args,
ty = resultType}
+ fun id () = Vector.sub (args, 0)
+ in
+ case Prim.name prim of
+ BuildConstant c =>
+ let
+ datatype z = datatype BuildConst.t
+ in
+ case lookupBuildConstant c of
+ Bool b =>
+ if b
+ then Xexp.truee ()
+ else Xexp.falsee ()
+ | Int i =>
+ Xexp.const
+ (Const.int
+ (IntX.make
+ (IntInf.fromInt i,
+ IntSize.default)))
+ end
+ | Byte_byteToChar => id ()
+ | Byte_charToByte => id ()
+ | C_CS_charArrayToWord8Array => id ()
+ | Char_chr =>
+ app (Prim.intToWord
+ (IntSize.default, W8))
+ | Char_ge => app (Prim.wordGe W8)
+ | Char_gt => app (Prim.wordGt W8)
+ | Char_le => app (Prim.wordLe W8)
+ | Char_lt => app (Prim.wordLt W8)
+ | Char_ord =>
+ app (Prim.wordToInt
+ (W8, IntSize.default))
+ | Constant c =>
+ Xexp.const (lookupConstant c)
+ | String_toWord8Vector => id ()
+ | Word8Vector_toString => id ()
+ | _ => app prim
+ end
in
case (Prim.numArgs prim, arg) of
(NONE, NONE) => make (Vector.new0 ())
1.4 +10 -3 mlton/mlton/type-inference/infer.sig
Index: infer.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- infer.sig 10 Apr 2002 07:02:21 -0000 1.3
+++ infer.sig 23 Jun 2003 04:59:00 -0000 1.4
@@ -19,11 +19,18 @@
signature INFER =
sig
include INFER_STRUCTS
-
+
+ structure BuildConst:
+ sig
+ datatype t =
+ Bool of bool
+ | Int of int
+ end
+
val infer:
{program: CoreML.Program.t,
- lookupBuildConstant: string -> LookupConstant.Const.t,
- lookupConstant: string -> LookupConstant.Const.t}
+ lookupBuildConstant: string -> BuildConst.t,
+ lookupConstant: string -> CoreML.Const.t}
-> Xml.Program.t
end
1.4 +14 -20 mlton/mlton/type-inference/match-compile.fun
Index: match-compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/match-compile.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- match-compile.fun 12 Dec 2002 01:14:23 -0000 1.3
+++ match-compile.fun 23 Jun 2003 04:59:00 -0000 1.4
@@ -144,28 +144,22 @@
end
local
- fun make (inj, get) (cases, finish) =
- inj (Vector.map
- (cases, fn {const, infos: Info.t list} =>
- (get (Const.node const), finish (Vector.fromList infos))))
+ fun make (all, ty, inj, get) =
+ List.map (all, fn s =>
+ (ty s,
+ fn (cases, finish) =>
+ inj (s,
+ Vector.map
+ (cases, fn {const, infos: Info.t list} =>
+ (get const, finish (Vector.fromList infos))))))
in
val directCases =
- [(Type.char,
- make (Cases.char,
- fn Const.Node.Char c => c
- | _ => Error.bug "caseChar type error")),
- (Type.int,
- make (Cases.int,
- fn Const.Node.Int i => i
- | _ => Error.bug "caseInt type error")),
- (Type.word,
- make (Cases.word,
- fn Const.Node.Word w => w
- | _ => Error.bug "caseWord type error")),
- (Type.word8,
- make (Cases.word8,
- fn Const.Node.Word w => Word8.fromWord w
- | _ => Error.bug "caseWord8 type error"))]
+ make (IntSize.all, Type.int, Cases.int,
+ fn Const.Int i => i
+ | _ => Error.bug "caseInt type error")
+ @ make (WordSize.all, Type.word, Cases.word,
+ fn Const.Word w => w
+ | _ => Error.bug "caseWord type error")
end
(*---------------------------------------------------*)
1.4 +5 -9 mlton/mlton/type-inference/match-compile.sig
Index: match-compile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/match-compile.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- match-compile.sig 12 Dec 2002 01:14:23 -0000 1.3
+++ match-compile.sig 23 Jun 2003 04:59:00 -0000 1.4
@@ -16,32 +16,28 @@
sig
type t
- val char: t
val detuple: t -> t vector
val equals: t * t -> bool
- val int: t
+ val int: IntSize.t -> t
val layout: t -> Layout.t
- val word: t
- val word8: t
+ val word: WordSize.t -> t
end
structure Cases:
sig
type exp
-
type t
- val char: (char * exp) vector -> t
val con: {con: Con.t,
targs: Type.t vector,
arg: (Var.t * Type.t) option,
rhs: exp} vector -> t
- val int: (int * exp) vector -> t
- val word: (word * exp) vector -> t
- val word8: (Word8.t * exp) vector -> t
+ val int: IntSize.t * (IntX.t * exp) vector -> t
+ val word: WordSize.t * (WordX.t * exp) vector -> t
end
structure Exp:
sig
type t
+
val const: Const.t -> t
val var: Var.t * Type.t -> t
val detuple: {tuple: t,
1.12 +105 -83 mlton/mlton/type-inference/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/type-env.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- type-env.fun 18 May 2003 23:57:50 -0000 1.11
+++ type-env.fun 23 Jun 2003 04:59:00 -0000 1.12
@@ -50,7 +50,7 @@
id = newId ()}
fun join (T r, T r'): t =
- T {equality = #equality r orelse #equality r',
+ T {equality = #equality r andalso #equality r',
canGeneralize = #canGeneralize r andalso #canGeneralize r',
id = newId ()}
end
@@ -183,6 +183,7 @@
final: FinalRecordType.t,
region: Region.t,
spine: Spine.t}
+ | Real (* an unresolved real type *)
| Record of t Srecord.t
| Unknown of Unknown.t
| Var of Tyvar.t
@@ -206,7 +207,6 @@
Con (c, ts) =>
paren (align [seq [str "Con ", Tycon.layout c],
Vector.layout layout ts])
- | Int => str "Int"
| FlexRecord {fields, final, region, spine} =>
seq [str "Flex ",
record [("fields", layoutFields fields),
@@ -218,6 +218,8 @@
record [("fields", layoutFields fields),
("final", FinalRecordType.layout final),
("spine", Spine.layout spine)]]
+ | Int => str "Int"
+ | Real => str "Real"
| Record r => Srecord.layout {record = r,
separator = ": ",
extra = "",
@@ -228,11 +230,13 @@
| Word => str "Word"
end
+ val toString = Layout.toString o layout
+
fun union (T s, T s') = Set.union (s, s')
fun set (T s, v) = Set.setValue (s, v)
- fun makeHom {con, flexRecord, genFlexRecord, int,
+ fun makeHom {con, flexRecord, genFlexRecord, int, real,
record, recursive, unknown, var, word} =
let
datatype status = Processing | Seen | Unseen
@@ -271,6 +275,7 @@
final = final,
region = region,
spine = spine})
+ | Real => real t
| Record r => record (t, Srecord.map (r, get))
| Unknown u => unknown (t, u)
| Var a => var (t, a)
@@ -283,7 +288,8 @@
fun destroy () =
(destroyStatus ()
; destroyProp ())
- in {hom = get, destroy = destroy}
+ in
+ {hom = get, destroy = destroy}
end
fun hom (ty, z) =
@@ -320,6 +326,7 @@
Spine.layoutPretty spine,
str "}"]
fun genFlexRecord (t, _) = layout t
+ fun real _ = str "real"
fun record (_, r) =
Srecord.layout
{record = r,
@@ -341,6 +348,7 @@
flexRecord = flexRecord,
genFlexRecord = genFlexRecord,
int = int,
+ real = real,
record = record,
recursive = recursive,
unknown = unknown,
@@ -381,9 +389,14 @@
fun con (tycon, ts) =
if Tycon.equals (tycon, Tycon.tuple) then tuple ts
else newTy (Con (tycon, ts))
+
+ val char = con (Tycon.char, Vector.new0 ())
+ val string = con (Tycon.vector, Vector.new1 char)
end
-structure Ops = TypeOps (structure Tycon = Tycon
+structure Ops = TypeOps (structure IntSize = IntSize
+ structure Tycon = Tycon
+ structure WordSize = WordSize
open Type)
structure Type =
@@ -403,34 +416,23 @@
case Aconst.node c of
Aconst.Char _ => char
| Aconst.Int _ => newTy Type.Int
- | Aconst.Real _ => real
+ | Aconst.Real _ => newTy Type.Real
| Aconst.String _ => string
| Aconst.Word _ => newTy Type.Word
-
val traceCanUnify =
Trace.trace2 ("canUnify", layout, layout, Bool.layout)
fun canUnify arg =
traceCanUnify
(fn (t, t') =>
- case (toType t, toType t') of
+ case (toType t, toType t') of
(Unknown _, _) => true
| (_, Unknown _) => true
- | (Con (c, ts), Con (c', ts')) => (Tycon.equals (c, c')
- andalso
- Vector.forall2 (ts, ts', canUnify))
- | (Con (c, ts), Word) =>
- 0 = Vector.length ts andalso Tycon.isWordX c
- | (Word, Con (c, ts)) =>
- 0 = Vector.length ts andalso Tycon.isWordX c
- | (Con (c, ts), Int) =>
- 0 = Vector.length ts andalso Tycon.isIntX c
- | (Int, Con (c, ts)) =>
- 0 = Vector.length ts andalso Tycon.isIntX c
- | (Var a, Var a') => Tyvar.equals (a, a')
- | (Word, Word) => true
+ | (Con (c, ts), t') => conAnd (c, ts, t')
+ | (t', Con (c, ts)) => conAnd (c, ts, t')
| (Int, Int) => true
+ | (Real, Real) => true
| (Record r, Record r') =>
let
val fs = Srecord.toVector r
@@ -440,7 +442,18 @@
Field.equals (f, f')
andalso canUnify (t, t'))
end
- | _ => false) arg
+ | (Var a, Var a') => Tyvar.equals (a, a')
+ | (Word, Word) => true
+ | _ => false) arg
+ and conAnd (c, ts, t') =
+ case t' of
+ Con (c', ts') =>
+ Tycon.equals (c, c')
+ andalso Vector.forall2 (ts, ts', canUnify)
+ | Int => 0 = Vector.length ts andalso Tycon.isIntX c
+ | Real => 0 = Vector.length ts andalso Tycon.isRealX c
+ | Word => 0 = Vector.length ts andalso Tycon.isWordX c
+ | _ => false
val traceUnify = Trace.trace2 ("unify", layout, layout, Unit.layout)
@@ -509,39 +522,67 @@
Error.bug "GenFlexRecord seen in unify"
val {ty = t, plist} = Set.value s
val {ty = t', ...} = Set.value s'
- val t =
- case (t, t') of
- (Unknown r, Unknown r') =>
- Unknown (Unknown.join (r, r'))
- | (t, Unknown _) => t
- | (Unknown _, t) => t
- | (Var a, Var a') =>
- if Tyvar.equals (a, a')
- then t
- else (errorS "type variables not equal"
- ; t)
- | (Con (c, ts), Con (c', ts')) =>
+ fun conAnd (c, ts, t, t') =
+ case t of
+ Con (c', ts') =>
if Tycon.equals (c, c')
then (unifys (ts, ts'); t)
else (errorS "type constructors not equal"; t)
- | (Con (c, ts), Word) =>
- if Tycon.isWordX c andalso Vector.isEmpty ts
- then t
- else (errorS "not a word"; t)
- | (Word, Con (c, ts)) =>
- if Tycon.isWordX c andalso Vector.isEmpty ts
- then t'
- else (errorS "not a word"; t)
- | (Con (c, ts), Int) =>
- if Tycon.isIntX c andalso Vector.isEmpty ts
- then t
- else (errorS "not an int"; t)
- | (Int, Con (c, ts)) =>
+ | Int =>
if Tycon.isIntX c andalso Vector.isEmpty ts
then t'
- else (errorS "not an int"; t)
- | (Word, Word) => t
+ else (errorS "not an int"; t')
+ | Real =>
+ if Tycon.isRealX c andalso Vector.isEmpty ts
+ then t'
+ else (errorS "not a real"; t')
+ | Word =>
+ if Tycon.isWordX c andalso Vector.isEmpty ts
+ then t'
+ else (errorS "not a word"; t')
+ | _ => (errorS "can't unify"; t)
+ val t =
+ case (t, t') of
+ (Unknown r, Unknown r') =>
+ Unknown (Unknown.join (r, r'))
+ | (_, Unknown _) => t
+ | (Unknown _, _) => t'
+ | (Con (c, ts), _) => conAnd (c, ts, t', t)
+ | (_, Con (c, ts)) => conAnd (c, ts, t, t')
+ | (FlexRecord f, res as Record r) =>
+ (oneFlex (f, r); res)
+ | (res as Record r, FlexRecord f) =>
+ (oneFlex (f, r); res)
+ | (FlexRecord {fields = fields, final, region,
+ spine = s},
+ FlexRecord {fields = fields', spine = s', ...}) =>
+ let
+ val _ = Spine.unify (s, s', error)
+ fun subset (fields, fields') =
+ let
+ val res = ref fields'
+ val _ =
+ List.foreach
+ (fields, fn (f, t) =>
+ case List.peek (fields', fn (f', _) =>
+ Field.equals (f, f')) of
+ NONE => List.push (res, (f, t))
+ | SOME (_, t') => unify (t, t'))
+ in
+ !res
+ end
+ val _ = subset (fields, fields')
+ val fields = subset (fields', fields)
+ in
+ FlexRecord {fields = fields,
+ final = final,
+ region = region,
+ spine = s}
+ end
+ | (GenFlexRecord _, _) => genFlexError ()
+ | (_, GenFlexRecord _) => genFlexError ()
| (Int, Int) => t
+ | (Real, Real) => t
| (Record r, Record r') =>
let
val fs = Srecord.toVector r
@@ -559,39 +600,12 @@
else (errorS "different length records"
; t)
end
- | (GenFlexRecord _, _) => genFlexError ()
- | (_, GenFlexRecord _) => genFlexError ()
- | (FlexRecord f, res as Record r) =>
- (oneFlex (f, r); res)
- | (res as Record r, FlexRecord f) =>
- (oneFlex (f, r); res)
- | (FlexRecord {fields = fields, final, region,
- spine = s},
- FlexRecord {fields = fields', spine = s', ...}) =>
- let
- val _ = Spine.unify (s, s', error)
- fun subset (fields, fields') =
- let
- val res = ref fields'
- val _ =
- List.foreach
- (fields, fn (f, t) =>
- case List.peek (fields', fn (f', _) =>
- Field.equals (f, f')) of
- NONE => List.push (res, (f, t))
- | SOME (_, t') => unify (t, t'))
- in
- !res
- end
- val _ = subset (fields, fields')
- val fields = subset (fields', fields)
- in
- FlexRecord {fields = fields,
- final = final,
- region = region,
- spine = s}
- end
- | _ => (errorS "can't unify"; t)
+ | (Var a, Var a') =>
+ if Tyvar.equals (a, a')
+ then t
+ else (errorS "type variables not equal"; t)
+ | (Word, Word) => t
+ | _ => (errorS "can't unify"; t)
val _ = Set.union (s, s')
val _ = Set.setValue (s, {ty = t, plist = plist})
in
@@ -613,7 +627,10 @@
local
structure X = XmlType
- val con = X.con
+ fun con (c, ts) =
+ if Tycon.equals (c, Tycon.char)
+ then X.word8
+ else X.con (c, ts)
val unknown = con (Tycon.tuple, Vector.new0 ())
fun tuple ts =
if 1 = Vector.length ts
@@ -666,12 +683,14 @@
X.unit
end
val int = con (Tycon.defaultInt, Vector.new0 ())
+ val real = con (Tycon.defaultReal, Vector.new0 ())
val word = con (Tycon.defaultWord, Vector.new0 ())
val {hom: Type.t -> X.t, ...} =
makeHom {con = fn (_, c, ts) => con (c, ts),
int = fn _ => int,
flexRecord = flexRecord,
genFlexRecord = genFlexRecord,
+ real = fn _ => real,
record = record,
recursive = recursive,
unknown = fn _ => unknown,
@@ -814,6 +833,7 @@
int = keep,
flexRecord = fn (t, _) => keep t,
genFlexRecord = genFlexRecord,
+ real = keep,
record = record,
recursive = recursive,
unknown = fn (t, _) => keep t,
@@ -974,6 +994,7 @@
int = fn _ => (),
flexRecord = fn (t, _) => add (flexes, t, Type.equals),
genFlexRecord = fn _ => Error.bug "GenFlexRecord seen in Env.close",
+ real = fn _ => (),
record = fn _ => (),
recursive = fn _ => (),
unknown = (fn (t, Unknown.T {canGeneralize, ...}) =>
@@ -1118,6 +1139,7 @@
int = ignore,
flexRecord = flexRecord,
genFlexRecord = ignore,
+ real = ignore,
record = ignore,
recursive = ignore,
unknown = unknown,
1.8 +2 -0 mlton/mlton/type-inference/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/type-env.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- type-env.sig 18 May 2003 23:57:50 -0000 1.7
+++ type-env.sig 23 Jun 2003 04:59:00 -0000 1.8
@@ -25,6 +25,7 @@
(* can two types be unified? not side-effecting. *)
val canUnify: t * t -> bool
val derecord: t * Region.t -> (Record.Field.t * XmlType.t) vector
+ val equals: t * t -> bool
val layout: t -> Layout.t
val layoutPretty: t -> Layout.t
val new: {equality: bool, canGeneralize: bool} -> t
@@ -32,6 +33,7 @@
val record: {flexible: bool,
record: t SortedRecord.t,
region: Region.t} -> t
+ val toString: t -> string
(* cached for speed *)
val toXml: t * Region.t -> XmlType.t
(* make two types identical (recursively). side-effecting. *)
1.9 +2 -2 mlton/mlton/xml/implement-exceptions.fun
Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- implement-exceptions.fun 10 Jan 2003 20:52:51 -0000 1.8
+++ implement-exceptions.fun 23 Jun 2003 04:59:00 -0000 1.9
@@ -508,7 +508,7 @@
targs = Vector.new0 (),
arg = SOME (Var.newNoname (), arg)},
const
- (Const.fromString
+ (Const.string
(Con.originalName con))))),
default = NONE,
ty = Type.string}))
@@ -540,7 +540,7 @@
Type.unit),
MonoVal {var = s,
ty = Type.string,
- exp = Const (Const.fromString
+ exp = Const (Const.string
"toplevel handler not installed")})
end},
Type.unit)
1.9 +3 -5 mlton/mlton/xml/monomorphise.fun
Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- monomorphise.fun 10 Jan 2003 20:09:03 -0000 1.8
+++ monomorphise.fun 23 Jun 2003 04:59:00 -0000 1.9
@@ -363,13 +363,11 @@
Vector.map (cases, fn (c, e) => (c, monoExp e))
val cases =
case cases of
- Xcases.Char l => Scases.Char (doit l)
- | Xcases.Con cases =>
+ Xcases.Con cases =>
Scases.Con (Vector.map (cases, fn (pat, exp) =>
(monoPat pat, monoExp exp)))
- | Xcases.Int l => Scases.Int (doit l)
- | Xcases.Word l => Scases.Word (doit l)
- | Xcases.Word8 l => Scases.Word8 (doit l)
+ | Xcases.Int (s, l) => Scases.Int (s, doit l)
+ | Xcases.Word (s, l) => Scases.Word (s, doit l)
in
SprimExp.Case
{test = monoVarExp test,
1.11 +3 -6 mlton/mlton/xml/polyvariance.fun
Index: polyvariance.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/polyvariance.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- polyvariance.fun 21 Apr 2003 15:16:19 -0000 1.10
+++ polyvariance.fun 23 Jun 2003 04:59:00 -0000 1.11
@@ -316,16 +316,13 @@
(z, loopExp e))
val cases =
case cases of
- Char cases => Char (doit cases)
- | Con cases =>
+ Con cases =>
Con
(Vector.map
(cases, fn (p, e) =>
(bindPat p, loopExp e)))
- | Int cases => Int (doit cases)
- | Word cases => Word (doit cases)
- | Word8 cases =>
- Word8 (doit cases)
+ | Int (s, v) => Int (s, doit v)
+ | Word (s, v) => Word (s, doit v)
in
Case {test = loopVar test,
cases = cases,
1.2 +9 -10 mlton/mlton/xml/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/shrink.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- shrink.fun 21 Apr 2003 15:16:19 -0000 1.1
+++ shrink.fun 23 Jun 2003 04:59:00 -0000 1.2
@@ -366,16 +366,15 @@
end
| (_, SOME (Value.Const c)) =>
let
- fun doit (l, z) = match (l, fn z' => z = z')
- in case (cases, Const.node c) of
- (Cases.Char l, Const.Node.Char c) =>
- doit (l, c)
- | (Cases.Int l, Const.Node.Int i) =>
- doit (l, i)
- | (Cases.Word l, Const.Node.Word w) =>
- doit (l, w)
- | (Cases.Word8 l, Const.Node.Word w) =>
- doit (l, Word8.fromWord w)
+ fun doit (l, z, equals) =
+ match (l, fn z' => equals (z, z'))
+ datatype z = datatype Const.t
+ in
+ case (cases, c) of
+ (Cases.Int (_, l), Int i) =>
+ doit (l, i, IntX.equals)
+ | (Cases.Word (_, l), Word w) =>
+ doit (l, w, WordX.equals)
| _ => Error.bug "strange case"
end
| (_, NONE) => normal varExp
1.7 +3 -5 mlton/mlton/xml/simplify-types.fun
Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- simplify-types.fun 25 Feb 2003 02:50:44 -0000 1.6
+++ simplify-types.fun 23 Jun 2003 04:59:00 -0000 1.7
@@ -249,13 +249,11 @@
fun doit v = Vector.map (v, fn (c, e) => (c, fixExp e))
val cases =
case cases of
- I.Cases.Char v => O.Cases.Char (doit v)
- | I.Cases.Con v =>
+ I.Cases.Con v =>
O.Cases.Con (Vector.map (v, fn (p, e) =>
(fixPat p, fixExp e)))
- | I.Cases.Int v => O.Cases.Int (doit v)
- | I.Cases.Word v => O.Cases.Word (doit v)
- | I.Cases.Word8 v => O.Cases.Word8 (doit v)
+ | I.Cases.Int (s, v) => O.Cases.Int (s, doit v)
+ | I.Cases.Word (s, v) => O.Cases.Word (s, doit v)
in
O.PrimExp.Case {cases = cases,
default = Option.map (default, fn (e, r) =>
1.12 +54 -48 mlton/mlton/xml/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- type-check.fun 18 May 2003 23:57:50 -0000 1.11
+++ type-check.fun 23 Jun 2003 04:59:00 -0000 1.12
@@ -133,34 +133,34 @@
let
fun error msg =
Type.error (msg, let open Layout
- in seq [str "exp: ", PrimExp.layout e]
- end)
+ in seq [str "exp: ", PrimExp.layout e]
+ end)
fun checkApp (t1, x) =
- let val t2 = checkVarExp x
- in case Type.dearrowOpt t1 of
- SOME (t2', t3) =>
- if Type.equals (t2, t2') then t3
- else
- Type.error
- ("actual and formal not of same type",
- let open Layout
- in align [seq [str "actual: ", Type.layout t2],
- seq [str "formal: ", Type.layout t2'],
- seq [str "expression: ",
- PrimExp.layout e]]
- end)
- | NONE => error "function not of arrow type"
+ let
+ val t2 = checkVarExp x
+ in
+ case Type.dearrowOpt t1 of
+ NONE => error "function not of arrow type"
+ | SOME (t2', t3) =>
+ if Type.equals (t2, t2') then t3
+ else
+ Type.error
+ ("actual and formal not of same type",
+ let open Layout
+ in align [seq [str "actual: ", Type.layout t2],
+ seq [str "formal: ", Type.layout t2'],
+ seq [str "expression: ",
+ PrimExp.layout e]]
+ end)
end
fun checkApps (t, es) =
List.fold (es, t, fn (e, t) => checkApp (t, e))
in
case e of
- App {func, arg} => checkApp (checkVarExp func, arg)
- | Case {test, cases, default} =>
+ App {arg, func} => checkApp (checkVarExp func, arg)
+ | Case {cases, default, test} =>
let
- val ty = checkVarExp test
- fun doit (l, t) =
- (Vector.new1 t, Vector.map (l, fn (_, e) => checkExp e))
+ val default = Option.map (default, checkExp o #1)
fun equalss v =
if Vector.isEmpty v
then Error.bug "equalss"
@@ -172,37 +172,41 @@
then SOME t
else NONE
end
+ fun finish (ptys: Type.t vector,
+ etys: Type.t vector): Type.t =
+ case (equalss ptys, equalss etys) of
+ (NONE, _) => error "patterns not of same type"
+ | (_, NONE) => error "branches not of same type"
+ | (SOME pty, SOME ety) =>
+ if Type.equals (checkVarExp test, pty)
+ then
+ case default of
+ NONE => ety
+ | SOME t =>
+ if Type.equals (ety, t)
+ then ety
+ else error "default of wrong type"
+ else error "test and patterns of different types"
+ fun doit (l, t) =
+ finish (Vector.new1 t,
+ Vector.map (l, fn (_, e) => checkExp e))
datatype z = datatype Cases.t
- val (ptys, etys) =
- case cases of
- Char l => doit (l, Type.char)
- | Con cases =>
- Vector.unzip
- (Vector.map (cases, fn (p, e) =>
- (checkPat p, checkExp e)))
- | Int l => doit (l, Type.int)
- | Word l => doit (l, Type.word)
- | Word8 l => doit (l, Type.word8)
- in case (equalss ptys, equalss etys) of
- (NONE, _) => error "patterns not of same type"
- | (_, NONE) => error "branches not of same type"
- | (SOME pty, SOME ety) =>
- if Type.equals (ty, pty)
- then
- case default of
- NONE => ety
- | SOME (e, _) =>
- if Type.equals (ety, checkExp e)
- then ety
- else error "default of wrong type"
- else error "test and patterns of different types"
+ in
+ case cases of
+ Con cases =>
+ finish (Vector.unzip
+ (Vector.map (cases, fn (p, e) =>
+ (checkPat p, checkExp e))))
+ | Int (s, cs) => doit (cs, Type.int s)
+ | Word (s, cs) => doit (cs, Type.word s)
end
| ConApp {con, targs, arg} =>
let
val t = checkConExp (con, targs)
- in case arg of
- NONE => t
- | SOME e => checkApp (t, e)
+ in
+ case arg of
+ NONE => t
+ | SOME e => checkApp (t, e)
end
| Const c => Type.ofConst c
| Handle {try, catch = (catch, catchType), handler, ...} =>
@@ -214,7 +218,9 @@
val _ = setVar (catch, {tyvars = Vector.new0 (),
ty = catchType})
val ty' = checkExp handler
- in if Type.equals (ty, ty') then ty
+ in
+ if Type.equals (ty, ty')
+ then ty
else error "bad handle"
end
| Lambda l => checkLambda l
1.16 +57 -10 mlton/mlton/xml/xml-tree.fun
Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- xml-tree.fun 13 Jan 2003 01:14:28 -0000 1.15
+++ xml-tree.fun 23 Jun 2003 04:59:00 -0000 1.16
@@ -63,9 +63,57 @@
val layout = Apat.layout o toAst
end
-structure Cases = Cases (type con = Pat.t
- val conEquals = fn _ =>
- Error.bug "XmlTree.Cases.conEquals")
+structure Cases =
+ struct
+ datatype 'a t =
+ Con of (Pat.t * 'a) vector
+ | Int of IntSize.t * (IntX.t * 'a) vector
+ | Word of WordSize.t * (WordX.t * 'a) vector
+
+ fun fold (c: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b =
+ let
+ fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
+ in
+ case c of
+ Con l => doit l
+ | Int (_, l) => doit l
+ | Word (_, l) => doit l
+ end
+
+ fun map (c: 'a t, f: 'a -> 'b): 'b t =
+ let
+ fun doit l = Vector.map (l, fn (i, x) => (i, f x))
+ in
+ case c of
+ Con l => Con (doit l)
+ | Int (s, l) => Int (s, doit l)
+ | Word (s, l) => Word (s, doit l)
+ end
+
+ fun forall (c: 'a t, f: 'a -> bool): bool =
+ let
+ fun doit l = Vector.forall (l, fn (_, x) => f x)
+ in
+ case c of
+ Con l => doit l
+ | Int (_, l) => doit l
+ | Word (_, l) => doit l
+ end
+
+ fun length (c: 'a t): int = fold (c, 0, fn (_, i) => i + 1)
+
+ fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
+
+ fun foreach' (c: 'a t, f: 'a -> unit, fc: Pat.t -> unit): unit =
+ let
+ fun doit l = Vector.foreach (l, fn (_, a) => f a)
+ in
+ case c of
+ Con l => Vector.foreach (l, fn (c, a) => (fc c; f a))
+ | Int (_, l) => doit l
+ | Word (_, l) => doit l
+ end
+ end
(*---------------------------------------------------*)
(* VarExp *)
@@ -210,12 +258,10 @@
fn n => Ast.Pat.const (Ast.Const.makeRegion (n, Region.bogus))
val cases =
case cases of
- Char l => doit (l, make o Ast.Const.Char)
- | Con l => Vector.map (l, fn (pat, exp) =>
+ Con l => Vector.map (l, fn (pat, exp) =>
(Pat.toAst pat, expToAst exp))
- | Int l => doit (l, make o Ast.Const.Int o Int.toString)
- | Word l => doit (l, make o Ast.Const.Word)
- | Word8 l => doit (l, make o Ast.Const.Word o Word8.toWord)
+ | Int (_, l) => doit (l, make o Ast.Const.Int o IntX.toIntInf)
+ | Word (_, l) => doit (l, make o Ast.Const.Word o WordX.toIntInf)
val cases =
case default of
NONE => cases
@@ -602,11 +648,12 @@
fun const c = simple (Const c, Type.ofConst c)
- val string = const o Const.fromString
+ val string = const o Const.string
fun varExp (x, t) = simple (Var x, t)
- fun var {var, targs, ty} = varExp (VarExp.T {var = var, targs = targs}, ty)
+ fun var {var, targs, ty} =
+ varExp (VarExp.T {var = var, targs = targs}, ty)
fun monoVar (x, t) = var {var = x, targs = Vector.new0 (), ty = t}
1.12 +12 -1 mlton/mlton/xml/xml-tree.sig
Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- xml-tree.sig 25 Feb 2003 02:50:44 -0000 1.11
+++ xml-tree.sig 23 Jun 2003 04:59:00 -0000 1.12
@@ -41,7 +41,18 @@
val layout: t -> Layout.t
end
- structure Cases: CASES sharing type Cases.con = Pat.t
+ structure Cases:
+ sig
+ datatype 'a t =
+ Con of (Pat.t * 'a) vector
+ | Int of IntSize.t * (IntX.t * 'a) vector
+ | Word of WordSize.t * (WordX.t * 'a) vector
+
+ val fold: 'a t * 'b * ('a * 'b -> 'b) -> 'b
+ val foreach: 'a t * ('a -> unit) -> unit
+ val foreach': 'a t * ('a -> unit) * (Pat.t -> unit) -> unit
+ val map: 'a t * ('a -> 'b) -> 'b t
+ end
structure Lambda:
sig
1.9 +2 -2 mlton/mlyacc/mlyacc-stubs.cm
Index: mlyacc-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc-stubs.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mlyacc-stubs.cm 15 May 2003 20:12:29 -0000 1.8
+++ mlyacc-stubs.cm 23 Jun 2003 04:59:00 -0000 1.9
@@ -131,8 +131,6 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/char.sig
../lib/mlton/basic/char.sml
../lib/mlton/basic/vector.sig
@@ -164,6 +162,8 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
1.6 +2 -2 mlton/mlyacc/mlyacc.cm
Index: mlyacc.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mlyacc.cm 1 Apr 2003 06:16:11 -0000 1.5
+++ mlyacc.cm 23 Jun 2003 04:59:00 -0000 1.6
@@ -97,8 +97,6 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/char.sig
../lib/mlton/basic/char.sml
../lib/mlton/basic/vector.sig
@@ -130,6 +128,8 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
1.64 +0 -4 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- Makefile 19 Jun 2003 15:38:04 -0000 1.63
+++ Makefile 23 Jun 2003 04:59:01 -0000 1.64
@@ -78,13 +78,11 @@
basis/Ptrace/ptrace2.o \
basis/Ptrace/ptrace4.o \
basis/Real/class.o \
- basis/Real/const.o \
basis/Real/gdtoa.o \
basis/Real/isFinite.o \
basis/Real/isNan.o \
basis/Real/isNormal.o \
basis/Real/nextAfter.o \
- basis/Real/qequal.o \
basis/Real/real.o \
basis/Real/round.o \
basis/Real/signBit.o \
@@ -249,13 +247,11 @@
basis/Ptrace/ptrace2-gdb.o \
basis/Ptrace/ptrace4-gdb.o \
basis/Real/class-gdb.o \
- basis/Real/const-gdb.o \
basis/Real/gdtoa-gdb.o \
basis/Real/isFinite-gdb.o \
basis/Real/isNan-gdb.o \
basis/Real/isNormal-gdb.o \
basis/Real/nextAfter-gdb.o \
- basis/Real/qequal-gdb.o \
basis/Real/real-gdb.o \
basis/Real/round-gdb.o \
basis/Real/signBit-gdb.o \
1.144 +3 -3 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.143
retrieving revision 1.144
diff -u -r1.143 -r1.144
--- gc.c 17 Jun 2003 01:23:31 -0000 1.143
+++ gc.c 23 Jun 2003 04:59:01 -0000 1.144
@@ -4549,7 +4549,7 @@
* The second word is the weak pointer.
*/
-Bool GC_weakCanGet (pointer p) {
+bool GC_weakCanGet (pointer p) {
Bool res;
res = WEAK_GONE_HEADER != GC_getHeader (p);
@@ -4559,7 +4559,7 @@
return res;
}
-pointer GC_weakGet (pointer p) {
+Pointer GC_weakGet (Pointer p) {
pointer res;
res = ((GC_weak)p)->object;
@@ -4569,7 +4569,7 @@
return res;
}
-pointer GC_weakNew (GC_state s, W32 header, pointer p) {
+Pointer GC_weakNew (GC_state s, Word32 header, Pointer p) {
pointer res;
res = object (s, header, GC_NORMAL_HEADER_SIZE + 3 * WORD_SIZE,
1.24 +31 -60 mlton/runtime/mlton-basis.h
Index: mlton-basis.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-basis.h,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- mlton-basis.h 19 Jun 2003 15:38:04 -0000 1.23
+++ mlton-basis.h 23 Jun 2003 04:59:01 -0000 1.24
@@ -6,18 +6,9 @@
#endif
#include <sys/resource.h>
-/* Here are the types that the abstract machine deals with.
- * See backend/mtype.sig.
- */
-typedef char Char;
-typedef double Double;
-typedef int Int;
-typedef char *Pointer;
-typedef unsigned long Word32;
-typedef Word32 Word;
+#include "types.h"
/* Here are some type abbreviations for abstract machine types. */
-typedef Int Bool;
typedef Word Cpointer;
typedef Word Cstring;
typedef Pointer Thread;
@@ -28,15 +19,15 @@
/* Array */
/* ------------------------------------------------- */
-Int Array_numElements(Pointer p);
+Int Array_numElements (Pointer p);
/* ------------------------------------------------- */
/* C */
/* ------------------------------------------------- */
-Char C_CS_sub(Cstring s, Int i);
-void C_CS_update(Cstring s, Int i, Char c);
-Cstring C_CSS_sub(CstringArray a, Int i);
+Char C_CS_sub (Cstring s, Int i);
+void C_CS_update (Cstring s, Int i, Char c);
+Cstring C_CSS_sub (CstringArray a, Int i);
/* ------------------------------------------------- */
/* CommandLine */
@@ -81,22 +72,22 @@
/* Debug */
/* ------------------------------------------------- */
-void Debug_enter(Pointer name);
-void Debug_leave(Pointer name);
+void Debug_enter (Pointer name);
+void Debug_leave (Pointer name);
/* ------------------------------------------------- */
/* GC */
/* ------------------------------------------------- */
-void GC_setMessages(Int b);
-void GC_setSummary(Int b);
+void GC_setMessages (Int b);
+void GC_setSummary (Int b);
/* ------------------------------------------------- */
/* IEEEReal */
/* ------------------------------------------------- */
-void IEEEReal_setRoundingMode(Int mode);
-Int IEEEReal_getRoundingMode();
+void IEEEReal_setRoundingMode (Int mode);
+Int IEEEReal_getRoundingMode ();
/* ------------------------------------------------- */
/* Itimer */
@@ -120,12 +111,12 @@
Bool MLton_Callback_fetchB(Int l);
Char MLton_Callback_fetchC(Int l);
Int MLton_Callback_fetchI(Int l);
-Double MLton_Callback_fetchR(Int l);
+Real MLton_Callback_fetchR(Int l);
Word MLton_Callback_fetchW(Int l);
void MLton_Callback_retB(Bool b);
void MLton_Callback_retC(Char c);
void MLton_Callback_retI(Int i);
-void MLton_Callback_retR(Double r);
+void MLton_Callback_retR(Real r);
void MLton_Callback_retW(Word w);
/* C functions */
int MLton_Callback_call(char *rep, char *name, ...);
@@ -153,43 +144,23 @@
/* OS */
/* ------------------------------------------------- */
-Cstring OS_FileSys_tmpnam();
-Int OS_IO_poll(Int *fds, Word *eventss, Int n, Int timeout, Word *reventss);
+Cstring OS_FileSys_tmpnam ();
+Int OS_IO_poll (Int *fds, Word *eventss, Int n, Int timeout, Word *reventss);
/* ------------------------------------------------- */
/* PackReal */
/* ------------------------------------------------- */
-Double PackReal_subVec(Pointer v, Int offset);
-void PackReal_update(Pointer a, Int offset, Double r);
+Real64 PackReal_subVec (Pointer v, Int offset);
+void PackReal_update (Pointer a, Int offset, Real64 r);
/* ------------------------------------------------- */
/* Ptrace */
/* ------------------------------------------------- */
-Int Ptrace_ptrace2(Int request, Int pid);
+Int Ptrace_ptrace2 (Int request, Int pid);
/* data is a word ref */
-Int Ptrace_ptrace4(Int request, Int pid, Word addr, Pointer data);
-
-/* ------------------------------------------------- */
-/* Real */
-/* ------------------------------------------------- */
-
-extern Double Real_Math_e;
-extern Double Real_Math_pi;
-extern Double Real_posInf;
-extern Double Real_maxFinite;
-extern Double Real_minNormalPos;
-extern Double Real_minPos;
-
-Int Real_class (Double d);
-Int Real_isFinite (Double d);
-Int Real_isNan (Double d);
-Int Real_isNormal (Double d);
-Int Real_isPositive (Double d);
-Int Real_qequal (Double x1, Double x2);
-double Real_round (Double d);
-Int Real_signBit (Double d);
+Int Ptrace_ptrace4 (Int request, Int pid, Word addr, Pointer data);
/* ------------------------------------------------- */
/* Rlimit */
@@ -224,23 +195,23 @@
typedef Word Rlimit;
typedef Int Resource;
-Int MLton_Rlimit_get(Resource r);
-Rlimit MLton_Rlimit_getHard();
-Rlimit MLton_Rlimit_getSoft();
-Int MLton_Rlimit_set(Resource r, Rlimit hard, Rlimit soft);
+Int MLton_Rlimit_get (Resource r);
+Rlimit MLton_Rlimit_getHard ();
+Rlimit MLton_Rlimit_getSoft ();
+Int MLton_Rlimit_set (Resource r, Rlimit hard, Rlimit soft);
/* ------------------------------------------------- */
/* Stdio */
/* ------------------------------------------------- */
-void Stdio_print(Pointer s);
-Int Stdio_sprintf(Pointer buf, Pointer fmt, Double x);
+void Stdio_print (Pointer s);
+Int Stdio_sprintf (Pointer buf, Pointer fmt, Real64 x);
/* ------------------------------------------------- */
/* String */
/* ------------------------------------------------- */
-int String_equal(char * s1, char * s2);
+int String_equal (char * s1, char * s2);
/* ------------------------------------------------- */
/* Thread */
@@ -259,20 +230,20 @@
/* Time */
/* ------------------------------------------------- */
-Int Time_gettimeofday();
-Int Time_sec();
-Int Time_usec();
+Int Time_gettimeofday ();
+Int Time_sec ();
+Int Time_usec ();
/* ------------------------------------------------- */
/* Word8 */
/* ------------------------------------------------- */
-Char Word8_arshiftAsm(Char w, Word s);
+Char Word8_arshiftAsm (Char w, Word s);
/* ------------------------------------------------- */
/* Word32 */
/* ------------------------------------------------- */
-Word Word32_arshiftAsm(Word w, Word s);
+Word Word32_arshiftAsm (Word w, Word s);
#endif /* #ifndef _MLTON_BASIS_H_ */
1.1 mlton/runtime/types.h
Index: types.h
===================================================================
#ifndef _TYPES_H_
#define _TYPES_H_
typedef char Int8;
typedef short Int16;
typedef long Int32;
typedef long long Int64;
typedef char *Pointer;
typedef float Real32;
typedef double Real64;
typedef unsigned char Word8;
typedef unsigned short Word16;
typedef unsigned long Word32;
typedef unsigned long long Word64;
typedef Int32 Int;
typedef Real64 Real;
typedef Word8 Char;
typedef Word32 Word;
typedef Int Bool;
#endif /* _TYPES_H_ */
1.2 +2 -2 mlton/runtime/Posix/Process/exit.c
Index: exit.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Process/exit.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- exit.c 18 Jul 2001 05:51:06 -0000 1.1
+++ exit.c 23 Jun 2003 04:59:01 -0000 1.2
@@ -1,6 +1,6 @@
#include <stdlib.h>
#include "mlton-posix.h"
-void Posix_Process_exit(int i) {
- exit(i);
+void Posix_Process_exit (Int i) {
+ exit (i);
}
1.2 +2 -2 mlton/runtime/Posix/Process/sleep.c
Index: sleep.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Process/sleep.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- sleep.c 18 Jul 2001 05:51:06 -0000 1.1
+++ sleep.c 23 Jun 2003 04:59:01 -0000 1.2
@@ -1,6 +1,6 @@
#include <unistd.h>
#include "mlton-posix.h"
-int Posix_Process_sleep(int i) {
- return sleep(i);
+Int Posix_Process_sleep (Int i) {
+ return sleep (i);
}
1.11 +4 -4 mlton/runtime/Posix/Signal/Signal.c
Index: Signal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Signal/Signal.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- Signal.c 12 May 2003 23:14:16 -0000 1.10
+++ Signal.c 23 Jun 2003 04:59:01 -0000 1.11
@@ -5,7 +5,7 @@
extern struct GC_state gcState;
-static void handler (Int signum) {
+static void handler (int signum) {
GC_handler (&gcState, signum);
}
@@ -29,7 +29,7 @@
return sigaction (signum, &sa, NULL);
}
-Int Posix_Signal_handle (int signum) {
+Int Posix_Signal_handle (Int signum) {
static struct sigaction sa;
sigaddset (&gcState.signalsHandled, signum);
@@ -69,11 +69,11 @@
static sigset_t set;
-Int Posix_Signal_sigaddset (int signum) {
+Int Posix_Signal_sigaddset (Int signum) {
return sigaddset (&set, signum);
}
-Int Posix_Signal_sigdelset (int signum) {
+Int Posix_Signal_sigdelset (Int signum) {
return sigdelset (&set, signum);
}
1.3 +1 -1 mlton/runtime/Posix/Signal/isPending.c
Index: isPending.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Signal/isPending.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- isPending.c 12 May 2003 08:40:54 -0000 1.2
+++ isPending.c 23 Jun 2003 04:59:01 -0000 1.3
@@ -18,6 +18,6 @@
return res;
}
-bool Posix_Signal_isPending (Int signum) {
+Bool Posix_Signal_isPending (Int signum) {
return sigismember (&gcState.signalsPending, signum);
}
1.3 +3 -3 mlton/runtime/basis/IEEEReal.c
Index: IEEEReal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/IEEEReal.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- IEEEReal.c 10 Apr 2003 02:03:12 -0000 1.2
+++ IEEEReal.c 23 Jun 2003 04:59:01 -0000 1.3
@@ -14,7 +14,7 @@
#define ROUNDING_CONTROL_MASK 0x0C00
#define ROUNDING_CONTROL_SHIFT 10
-void IEEEReal_setRoundingMode (int mode) {
+void IEEEReal_setRoundingMode (Int mode) {
unsigned short controlWord;
_FPU_GETCW(controlWord);
@@ -34,7 +34,7 @@
#include <ieeefp.h>
-void IEEEReal_setRoundingMode (int mode) {
+void IEEEReal_setRoundingMode (Int mode) {
switch (mode) {
case 0: mode = FP_RN; break;
case 1: mode = FP_RM; break;
@@ -46,7 +46,7 @@
fpsetround (mode);
}
-int IEEEReal_getRoundingMode () {
+Int IEEEReal_getRoundingMode () {
int mode;
mode = fpgetround ();
1.3 +4 -4 mlton/runtime/basis/Stdio.c
Index: Stdio.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Stdio.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- Stdio.c 10 Jan 2003 16:36:20 -0000 1.2
+++ Stdio.c 23 Jun 2003 04:59:01 -0000 1.3
@@ -3,12 +3,12 @@
#include "my-lib.h"
void Stdio_print (Pointer s) {
- if (0 == Array_numElements(s))
+ if (0 == Array_numElements (s))
return;
- while (1 != fwrite(s, Array_numElements(s), 1, stderr))
+ while (1 != fwrite (s, Array_numElements(s), 1, stderr))
/* nothing */;
}
-Int Stdio_sprintf (Pointer buf, Pointer fmt, Double x) {
- return sprintf(buf, (char*) fmt, x);
+Int Stdio_sprintf (Pointer buf, Pointer fmt, Real x) {
+ return sprintf (buf, (char*) fmt, x);
}
1.5 +2 -2 mlton/runtime/basis/Int/quot.c
Index: quot.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/quot.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- quot.c 10 Apr 2003 02:03:12 -0000 1.4
+++ quot.c 23 Jun 2003 04:59:01 -0000 1.5
@@ -26,10 +26,10 @@
* implements / and %.
*/
-Int Int_quot (Int n, Int d) {
+Int32 Int32_quot (Int32 n, Int32 d) {
#if (defined (__i386__) || defined (__sparc__))
return n / d;
#else
-#error check that C / correctly implements Int.quot from the basis library
+#error check that C / correctly implements Int32.quot from the basis library
#endif
}
1.4 +2 -2 mlton/runtime/basis/Int/rem.c
Index: rem.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/rem.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- rem.c 10 Apr 2003 02:03:12 -0000 1.3
+++ rem.c 23 Jun 2003 04:59:01 -0000 1.4
@@ -2,10 +2,10 @@
/* See the comment in quot.c. */
-Int Int_rem (Int n, Int d) {
+Int32 Int32_rem (Int32 n, Int32 d) {
#if (defined (__i386__) || defined (__sparc__))
return n % d;
#else
-#error check that C % correctly implements Int.rem from the basis library
+#error check that C % correctly implements Int32.rem from the basis library
#endif
}
1.2 +6 -6 mlton/runtime/basis/MLton/Callback.c
Index: Callback.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/MLton/Callback.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Callback.c 19 Jun 2003 15:38:04 -0000 1.1
+++ Callback.c 23 Jun 2003 04:59:01 -0000 1.2
@@ -6,13 +6,13 @@
static Bool argB[10];
static Char argC[10];
static Int argI[10];
-static Double argR[10];
+static Real argR[10];
static Word argW[10];
static Bool resB;
static Char resC;
static Int resI;
-static Double resR;
+static Real resR;
static Word resW;
Cstring callbackName;
@@ -39,7 +39,7 @@
return argI[l];
}
-Double MLton_Callback_fetchR(Int l) {
+Real MLton_Callback_fetchR(Int l) {
return argR[l];
}
@@ -59,7 +59,7 @@
resI = i;
}
-void MLton_Callback_retR(Double r) {
+void MLton_Callback_retR(Real r) {
resR = r;
}
@@ -102,7 +102,7 @@
argI[indices[2]++] = va_arg(ap, Int);
break;
case 'R':
- argR[indices[3]++] = va_arg(ap, Double);
+ argR[indices[3]++] = va_arg(ap, Real);
break;
case 'U':
break;
@@ -125,7 +125,7 @@
*(va_arg(ap, Int*)) = resI;
break;
case 'R':
- *(va_arg(ap, Double*)) = resR;
+ *(va_arg(ap, Real*)) = resR;
break;
case 'U':
break;
1.3 +1 -1 mlton/runtime/basis/MLton/exit.c
Index: exit.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/MLton/exit.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- exit.c 6 Jul 2002 17:22:08 -0000 1.2
+++ exit.c 23 Jun 2003 04:59:01 -0000 1.3
@@ -3,7 +3,7 @@
extern struct GC_state gcState;
-void MLton_exit (int status) {
+void MLton_exit (Int status) {
GC_done (&gcState);
exit (status);
}
1.2 +1 -1 mlton/runtime/basis/PackReal/subVec.c
Index: subVec.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/PackReal/subVec.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- subVec.c 18 Jul 2001 05:51:06 -0000 1.1
+++ subVec.c 23 Jun 2003 04:59:01 -0000 1.2
@@ -1,6 +1,6 @@
#include "mlton-basis.h"
-Double PackReal_subVec(Pointer v, Int offset) {
+Real64 PackReal_subVec (Pointer v, Int offset) {
double r;
char *p = (char*)&r;
char *s = v + offset;
1.2 +1 -1 mlton/runtime/basis/PackReal/update.c
Index: update.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/PackReal/update.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- update.c 18 Jul 2001 05:51:06 -0000 1.1
+++ update.c 23 Jun 2003 04:59:01 -0000 1.2
@@ -1,6 +1,6 @@
#include "mlton-basis.h"
-void PackReal_update(Pointer a, Int offset, Double r) {
+void PackReal_update (Pointer a, Int offset, Real r) {
char *p = (char*)&r;
char *s = a + offset;
int i;
1.3 +2 -2 mlton/runtime/basis/Real/class.c
Index: class.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/class.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- class.c 2 Jun 2003 20:59:36 -0000 1.2
+++ class.c 23 Jun 2003 04:59:01 -0000 1.3
@@ -40,7 +40,7 @@
#define SIGNBIT_MASK 0x80000000
#define MANTISSA_HIGHBIT_MASK 0x00080000
-Int Real_class (Double d) {
+Int Real64_class (Real64 d) {
Word word0, word1;
Int res;
@@ -73,7 +73,7 @@
#elif (defined __sparc__)
-Int Real_class (Double d) {
+Int Real64_class (Real64 d) {
fpclass_t c;
c = fpclass (d);
1.2 +1 -1 mlton/runtime/basis/Real/gdtoa.c
Index: gdtoa.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/gdtoa.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- gdtoa.c 1 Jun 2003 00:31:34 -0000 1.1
+++ gdtoa.c 23 Jun 2003 04:59:02 -0000 1.2
@@ -21,7 +21,7 @@
#endif
/* This code is patterned on g_dfmt from the gdtoa sources. */
-char * Real_gdtoa (double d, int mode, int ndig, int *decpt) {
+char * Real64_gdtoa (double d, int mode, int ndig, int *decpt) {
ULong bits[2];
int ex;
static FPI fpi = { 53, 1-1023-53+1, 2046-1023-53+1, 1, 0 };
1.3 +1 -1 mlton/runtime/basis/Real/isFinite.c
Index: isFinite.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isFinite.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- isFinite.c 2 Jun 2003 20:59:36 -0000 1.2
+++ isFinite.c 23 Jun 2003 04:59:02 -0000 1.3
@@ -4,6 +4,6 @@
#endif
#include "mlton-basis.h"
-Int Real_isFinite (Double d) {
+Int Real64_isFinite (Real64 d) {
return finite (d); /* finite is from math.h */
}
1.3 +3 -3 mlton/runtime/basis/Real/isNan.c
Index: isNan.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isNan.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- isNan.c 2 Jun 2003 20:59:36 -0000 1.2
+++ isNan.c 23 Jun 2003 04:59:02 -0000 1.3
@@ -6,13 +6,13 @@
#if (defined (__i386__))
-Int Real_isNan (Double d) {
+Int Real64_isNan (Real64 d) {
return isnan (d); /* isnan is from math.h */
}
#elif (defined __sparc__)
-Int Real_isNan (Double d) {
+Int Real64_isNan (Real64 d) {
fpclass_t c;
c = fpclass (d);
@@ -21,6 +21,6 @@
#else
-#error Real_isNan not defined
+#error Real64_isNan not defined
#endif
1.3 +3 -3 mlton/runtime/basis/Real/isNormal.c
Index: isNormal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/isNormal.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- isNormal.c 2 Jun 2003 20:59:36 -0000 1.2
+++ isNormal.c 23 Jun 2003 04:59:02 -0000 1.3
@@ -9,7 +9,7 @@
#define EXPONENT_MASK 0x7FF00000
-Int Real_isNormal (Double d) {
+Int Real64_isNormal (Real64 d) {
Word word1, exponent;
word1 = ((Word *)&d)[1];
@@ -21,7 +21,7 @@
#elif (defined __sparc__)
-Int Real_isNormal (Double d) {
+Int Real64_isNormal (Real64 d) {
fpclass_t c;
c = fpclass (d);
@@ -30,6 +30,6 @@
#else
-#error Real_isNormal not defined
+#error Real64_isNormal not defined
#endif
1.2 +1 -1 mlton/runtime/basis/Real/nextAfter.c
Index: nextAfter.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/nextAfter.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- nextAfter.c 1 Jun 2003 00:31:34 -0000 1.1
+++ nextAfter.c 23 Jun 2003 04:59:02 -0000 1.2
@@ -1,6 +1,6 @@
#include <math.h>
#include "mlton-basis.h"
-Double Real_nextAfter (Double x1, Double x2) {
+Real64 Real64_nextAfter (Real64 x1, Real64 x2) {
return nextafter (x1, x2);
}
1.2 +5 -8 mlton/runtime/basis/Real/real.c
Index: real.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/real.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- real.c 1 Jun 2003 00:31:34 -0000 1.1
+++ real.c 23 Jun 2003 04:59:02 -0000 1.2
@@ -2,13 +2,10 @@
#include "basis-constants.h"
#include "mlton-basis.h"
-Double Real_Math_pi = M_PI;
-Double Real_Math_e = M_E;
+Real64 Real64_Math_pi = M_PI;
+Real64 Real64_Math_e = M_E;
-#if (defined __sparc__)
+Real64 Real64_maxFinite = 1.7976931348623157e308;
+Real64 Real64_minNormalPos = 2.22507385850720140e-308;
+Real64 Real64_minPos = 4.94065645841246544e-324;
-double Real_maxFinite = 1.7976931348623157e308;
-double Real_minPos = 4.94065645841246544e-324;
-double Real_minNormalPos = 2.22507385850720140e-308;
-
-#endif
1.2 +2 -2 mlton/runtime/basis/Real/round.c
Index: round.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/round.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- round.c 1 Jun 2003 00:31:34 -0000 1.1
+++ round.c 23 Jun 2003 04:59:02 -0000 1.2
@@ -3,7 +3,7 @@
#if (defined (__i386__))
-Double Real_round (Double d) {
+Real64 Real64_round (Real64 d) {
register double f0;
f0 = d;
@@ -16,7 +16,7 @@
#elif (defined __sparc__)
-Double Real_round (Double d) {
+Real64 Real64_round (Real64 d) {
return rint (d);
}
1.2 +1 -1 mlton/runtime/basis/Real/signBit.c
Index: signBit.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/signBit.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- signBit.c 1 Jun 2003 00:31:34 -0000 1.1
+++ signBit.c 23 Jun 2003 04:59:02 -0000 1.2
@@ -1,5 +1,5 @@
#include "mlton-basis.h"
-Int Real_signBit (Double d) {
+Int Real64_signBit (Real64 d) {
return (((unsigned char *)&d)[7] & 0x80) >> 7;
}
1.2 +2 -2 mlton/runtime/basis/Real/strtod.c
Index: strtod.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/strtod.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- strtod.c 1 Jun 2003 00:31:34 -0000 1.1
+++ strtod.c 23 Jun 2003 04:59:02 -0000 1.2
@@ -4,9 +4,9 @@
#include "mlton-basis.h"
#include "my-lib.h"
-Double Real_strtod (char *s) {
+Real64 Real64_strtod (char *s) {
char *endptr;
- Double res;
+ Real64 res;
res = strtod (s, &endptr);
assert (NULL != endptr);
-------------------------------------------------------
This SF.Net email is sponsored by: INetU
Attention Web Developers & Consultants: Become An INetU Hosting Partner.
Refer Dedicated Servers. We Manage Them. You Get 10% Monthly Commission!
INetU Dedicated Managed Hosting http://www.inetu.net/partner/index.php
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel