[MLton] cvs commit: Added Int31 structure
Stephen Weeks
sweeks@mlton.org
Tue, 2 Mar 2004 18:09:08 -0800
sweeks 04/03/02 18:09:08
Modified: basis-library/libs build
basis-library/libs/basis-2002/top-level basis.sig basis.sml
overloads.sml
basis-library/misc primitive.sml
mlton/ast int-size.fun int-size.sig prim-tycons.fun
prim-tycons.sig real-size.fun real-size.sig
word-size.fun word-size.sig
mlton/atoms c-function.fun c-type.fun const.fun int-x.fun
prim.fun type-ops.fun word-x.fun
mlton/backend machine-atoms.fun representation.fun rssa.fun
ssa-to-rssa.fun
mlton/closure-convert closure-convert.fun globalize.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-mlton-basic.fun x86-mlton.fun
x86-translate.fun x86.fun
mlton/match-compile match-compile.fun
mlton/ssa local-ref.fun multi.fun redundant-tests.fun
ssa-tree.fun
mlton/xml implement-exceptions.fun
regression fixed-integer.sml
Added: basis-library/integer embed.sml
Log:
MAIL Added Int31 structure
Most operations are implemented by converting to Int32.int and using
the corresponding operation there.
Added a new primitive "int31" tycon to the compiler, and cleaned up
the compiler internals a bit so that adding more int types should be
very easy. The only int31 primitives that the compiler knows about
are the conversions to and from int32. These conversions are replaced
by no-ops in ssa-to-rssa, which also replaces the int31 type with
int32, so that the codegens don't see anything new.
The reason for propagating the int31 type so far back is that soon the
representation pass will take advantage of the int31 type and will use
only 31 bits to represent it, which will allow sum types like "A of
Int31.int | B of Int31.int" to be represented more efficiently.
I also plan to add all the other int sizes between 1 and 64 soon.
Revision Changes Path
1.1 mlton/basis-library/integer/embed.sml
Index: embed.sml
===================================================================
functor EmbedInt (structure Big: INTEGER
structure Small:
sig
eqtype int
val precision': Int.int
val fromBigUnsafe: Big.int -> int
val toBig: int -> Big.int
end): INTEGER =
struct
open Small
val precision = SOME precision'
val maxIntBig =
Big.fromLarge
(LargeInt.- (Word.toLargeInt (Word.<<
(0w1,
Word.fromInt (Int.- (precision', 1)))),
1))
val maxInt = SOME (fromBigUnsafe maxIntBig)
val minIntBig = Big.- (Big.~ maxIntBig, Big.fromInt 1)
val minInt = SOME (fromBigUnsafe minIntBig)
fun fromBig (i: Big.int): int =
if Big.<= (minIntBig, i) andalso Big.<= (i, maxIntBig)
then fromBigUnsafe i
else raise Overflow
local
val make: (Big.int * Big.int -> Big.int) -> (int * int -> int) =
fn f => fn (x, y) => fromBig (f (toBig x, toBig y))
in
val op * = make Big.*
val op + = make Big.+
val op - = make Big.-
val op div = make Big.div
val op mod = make Big.mod
val quot = make Big.quot
val rem = make Big.rem
end
local
val make: (Big.int * Big.int -> 'a) -> (int * int -> 'a) =
fn f => fn (x, y) => f (toBig x, toBig y)
in
val op < = make Big.<
val op <= = make Big.<=
val op > = make Big.>
val op >= = make Big.>=
val compare = make Big.compare
end
val fromInt = fromBig o Big.fromInt
val toInt = Big.toInt o toBig
local
val make: (Big.int -> Big.int) -> (int -> int) =
fn f => fn x => fromBig (f (toBig x))
in
val ~ = make Big.~
val abs = make Big.abs
end
fun fmt r i = Big.fmt r (toBig i)
val fromLarge = fromBig o Big.fromLarge
fun fromString s = Option.map fromBig (Big.fromString s)
fun max (i, j) = if i >= j then i else j
fun min (i, j) = if i <= j then i else j
fun scan r reader state =
Option.map
(fn (i, state) => (fromBig i, state))
(Big.scan r reader state)
val sign = Big.sign o toBig
fun sameSign (x, y) = sign x = sign y
val toLarge = Big.toLarge o toBig
val toString = Big.toString o toBig
end
structure Int31 = EmbedInt (structure Big = Int32
structure Small = Primitive.Int31)
1.32 +1 -0 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- build 16 Feb 2004 22:43:19 -0000 1.31
+++ build 3 Mar 2004 02:08:58 -0000 1.32
@@ -74,6 +74,7 @@
real/real32.sml
real/real64.sml
integer/patch.sml
+integer/embed.sml
top-level/arithmetic.sml
1.44 +12 -8 mlton/basis-library/libs/basis-2002/top-level/basis.sig
Index: basis.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sig,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- basis.sig 1 Mar 2004 23:23:41 -0000 1.43
+++ basis.sig 3 Mar 2004 02:08:58 -0000 1.44
@@ -141,6 +141,7 @@
structure Int16ArraySlice : MONO_ARRAY_SLICE
structure Int16Vector : MONO_VECTOR
structure Int16VectorSlice : MONO_VECTOR_SLICE
+ structure Int31 : INTEGER
structure Int32 : INTEGER
structure Int32Array : MONO_ARRAY
structure Int32Array2 : MONO_ARRAY2
@@ -589,10 +590,6 @@
where type BinPrimIO.reader = BinPrimIO.reader
where type BinPrimIO.writer = BinPrimIO.writer
where type FixedInt.int = FixedInt.int
- where type Int8.int = Int8.int
- where type Int16.int = Int16.int
- where type Int64.int = Int64.int
- where type IntInf.int = IntInf.int
where type IO.buffer_mode = IO.buffer_mode
where type LargeInt.int = LargeInt.int
where type LargeReal.real = LargeReal.real
@@ -607,7 +604,6 @@
where type Position.int = Position.int
where type Posix.IO.file_desc = Posix.IO.file_desc
where type Posix.Signal.signal = Posix.Signal.signal
- where type Real32.real = Real32.real
where type Socket.dgram = Socket.dgram
where type ('a, 'b) Socket.sock = ('a, 'b) Socket.sock
where type 'a Socket.sock_addr = 'a Socket.sock_addr
@@ -628,12 +624,20 @@
where type 'a Vector.vector = 'a Vector.vector
*)
where type 'a VectorSlice.slice = 'a VectorSlice.slice
- where type Word8.word = Word8.word
- where type Word16.word = Word16.word
- where type Word64.word = Word64.word
where type Word8Array.array = Word8Array.array
where type Word8ArraySlice.slice = Word8ArraySlice.slice
where type Word8ArraySlice.vector_slice = Word8ArraySlice.vector_slice
where type Word8Vector.vector = Word8Vector.vector
+
+ (* Types that must be exposed because constants denote them. *)
+ where type Int8.int = Int8.int
+ where type Int16.int = Int16.int
+ where type Int31.int = Int31.int
+ where type Int64.int = Int64.int
+ where type IntInf.int = IntInf.int
+ where type Real32.real = Real32.real
+ where type Word8.word = Word8.word
+ where type Word16.word = Word16.word
+ where type Word64.word = Word64.word
where type 'a MLton.Thread.t = 'a MLton.Thread.t
1.20 +1 -0 mlton/basis-library/libs/basis-2002/top-level/basis.sml
Index: basis.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sml,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- basis.sml 16 Feb 2004 22:43:20 -0000 1.19
+++ basis.sml 3 Mar 2004 02:08:58 -0000 1.20
@@ -62,6 +62,7 @@
structure Int16ArraySlice = Int16ArraySlice
structure Int16Vector = Int16Vector
structure Int16VectorSlice = Int16VectorSlice
+ structure Int31 = Int31
structure Int32 = Int32
structure Int32Array = Int32Array
structure Int32Array2 = Int32Array2
1.10 +11 -0 mlton/basis-library/libs/basis-2002/top-level/overloads.sml
Index: overloads.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/overloads.sml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- overloads.sml 23 Jan 2004 02:30:23 -0000 1.9
+++ overloads.sml 3 Mar 2004 02:08:58 -0000 1.10
@@ -107,6 +107,7 @@
as Int.~
and Int8.~
and Int16.~
+and Int31.~
and Int32.~
and Int64.~
and IntInf.~
@@ -129,6 +130,7 @@
as Int.+
and Int8.+
and Int16.+
+and Int31.+
and Int32.+
and Int64.+
and IntInf.+
@@ -151,6 +153,7 @@
as Int.-
and Int8.-
and Int16.-
+and Int31.-
and Int32.-
and Int64.-
and IntInf.-
@@ -173,6 +176,7 @@
as Int.*
and Int8.*
and Int16.*
+and Int31.*
and Int32.*
and Int64.*
and IntInf.*
@@ -201,6 +205,7 @@
as Int.div
and Int8.div
and Int16.div
+and Int31.div
and Int32.div
and Int64.div
and IntInf.div
@@ -219,6 +224,7 @@
as Int.mod
and Int8.mod
and Int16.mod
+and Int31.mod
and Int32.mod
and Int64.mod
and IntInf.mod
@@ -237,6 +243,7 @@
as Int.abs
and Int8.abs
and Int16.abs
+and Int31.abs
and Int32.abs
and Int64.abs
and IntInf.abs
@@ -252,6 +259,7 @@
as Int.<
and Int8.<
and Int16.<
+and Int31.<
and Int32.<
and Int64.<
and IntInf.<
@@ -276,6 +284,7 @@
as Int.<=
and Int8.<=
and Int16.<=
+and Int31.<=
and Int32.<=
and Int64.<=
and IntInf.<=
@@ -300,6 +309,7 @@
as Int.>
and Int8.>
and Int16.>
+and Int31.>
and Int32.>
and Int64.>
and IntInf.>
@@ -324,6 +334,7 @@
as Int.>=
and Int8.>=
and Int16.>=
+and Int31.>=
and Int32.>=
and Int64.>=
and IntInf.>=
1.101 +24 -5 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -r1.100 -r1.101
--- primitive.sml 28 Feb 2004 01:54:55 -0000 1.100
+++ primitive.sml 3 Mar 2004 02:08:59 -0000 1.101
@@ -16,53 +16,61 @@
struct
type 'a array = 'a array
end
+
type 'a array = 'a Array.array
+
structure Bool =
struct
datatype bool = datatype bool
end
-(* datatype bool = datatype Bool.bool *)
+
structure Char =
struct
type char = char
end
+
type char = Char.char
+
type exn = exn
+
structure Int8 =
struct
type int = int8
end
+
structure Int16 =
struct
type int = int16
end
+
structure Int32 =
struct
type int = int32
end
+
structure Int = Int32
+
structure Int64 =
struct
type int = int64
end
+
structure IntInf =
struct
type int = intInf
end
-(* datatype list = datatype list *)
-
structure Real32 =
struct
type real = real32
end
+
structure Real64 =
struct
type real = real64
end
-structure Real = Real64
-(* datatype ref = datatype ref *)
+structure Real = Real64
structure String =
struct
@@ -377,6 +385,14 @@
val fromInt = _prim "Int32_toInt16": Int.int -> int;
val toInt = _prim "Int16_toInt32": int -> Int.int;
end
+ structure Int31 =
+ struct
+ type int = int31
+
+ val fromBigUnsafe = _prim "Int32_toInt31": Int32.int -> int;
+ val precision' = 31
+ val toBig = _prim "Int31_toInt32": int -> Int32.int;
+ end
structure Int32 =
struct
type int = Int32.int
@@ -413,6 +429,9 @@
else ~?
val fromInt : int -> int = fn x => x
val toInt : int -> int = fn x => x
+
+(* val fromInt31 = _prim "Int31_toInt32": Int31.int -> int; *)
+(* val toInt31 = _prim "Int32_toInt31": int -> Int31.int; *)
end
structure Int = Int32
1.5 +51 -22 mlton/mlton/ast/int-size.fun
Index: int-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/int-size.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- int-size.fun 19 Feb 2004 22:42:08 -0000 1.4
+++ int-size.fun 3 Mar 2004 02:08:59 -0000 1.5
@@ -3,47 +3,64 @@
open S
-datatype t = I8 | I16 | I32 | I64
+datatype t = T of {precision: int}
+
+fun bits (T {precision = p, ...}) = p
val equals: t * t -> bool = op =
-val all = [I8, I16, I32, I64]
+val sizes: int list = [8, 16, 31, 32, 64]
-val default = I32
+fun isValidSize i = List.exists (sizes, fn i' => i = i')
-val bytes: t -> int =
- fn I8 => 1
- | I16 => 2
- | I32 => 4
- | I64 => 8
+fun make i = T {precision = i}
+
+val allVector = Vector.tabulate (65, fn i =>
+ if isValidSize i
+ then SOME (make i)
+ else NONE)
+
+fun I i =
+ case Vector.sub (allVector, i) handle Subscript => NONE of
+ NONE => Error.bug (concat ["strange int size: ", Int.toString i])
+ | SOME s => s
-fun size s = 8 * bytes s
+val all = List.map (sizes, I)
-val toString = Int.toString o size
+val prims = [I 8, I 16, I 32, I 64]
-val layout = Layout.str o toString
-
+val default = I 32
+
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
+ val v = Vector.map (allVector, fn opt => Option.map (opt, f))
in
- fn I8 => a8
- | I16 => a16
- | I32 => a32
- | I64 => a64
+ fn T {precision = i, ...} => valOf (Vector.sub (v, i))
end
-val cardinality = memoize (fn s => IntInf.pow (2, size s))
+val bytes: t -> int =
+ memoize
+ (fn T {precision, ...} =>
+ if precision <= 8
+ then 1
+ else if precision <= 16
+ then 2
+ else if precision <= 32
+ then 4
+ else 8)
+
+val toString = Int.toString o bits
+
+val layout = Layout.str o toString
+
+val cardinality = memoize (fn s => IntInf.pow (2, bits s))
val range =
memoize
(fn s =>
let
- val pow = IntInf.pow (2, size s - 1)
+ val pow = IntInf.pow (2, bits s - 1)
in
(~ pow, pow - 1)
end)
@@ -58,5 +75,17 @@
val min = #1 o range
val max = #2 o range
+
+datatype prim = I8 | I16 | I32 | I64
+
+val primOpt = memoize (fn T {precision = i, ...} =>
+ List.peekMap ([(8, I8), (16, I16), (32, I32), (64, I64)],
+ fn (i', p) =>
+ if i = i' then SOME p else NONE))
+
+fun prim s =
+ case primOpt s of
+ NONE => Error.bug "IntSize.prim"
+ | SOME p => p
end
1.3 +6 -2 mlton/mlton/ast/int-size.sig
Index: int-size.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/int-size.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- int-size.sig 13 Oct 2003 18:48:36 -0000 1.2
+++ int-size.sig 3 Mar 2004 02:08:59 -0000 1.3
@@ -8,19 +8,23 @@
sig
include INT_SIZE_STRUCTS
- datatype t = I8 | I16 | I32 | I64
+ eqtype t
val all: t list
+ val bits: t -> int
val bytes: t -> int
val cardinality: t -> IntInf.t
val default: t
val equals: t * t -> bool
+ val I : int -> t
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
+ datatype prim = I8 | I16 | I32 | I64
+ val prim: t -> prim
+ val prims: t list
val range: t -> IntInf.t * IntInf.t
- val size: t -> int
val toString: t -> string
end
1.18 +52 -67 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- prim-tycons.fun 19 Feb 2004 22:42:08 -0000 1.17
+++ prim-tycons.fun 3 Mar 2004 02:08:59 -0000 1.18
@@ -10,7 +10,6 @@
open S
-datatype z = datatype IntSize.t
datatype z = datatype RealSize.t
datatype z = datatype WordSize.t
@@ -21,98 +20,84 @@
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 word64 = fromString "word64"
-
-val ints =
- [(int8, I8),
- (int16, I16),
- (int32, I32),
- (int64, I64)]
-
-val reals =
- [(real32, R32),
- (real64, R64)]
-
-val words =
- [(word8, W8),
- (word16, W16),
- (word32, W32),
- (word64, W64)]
datatype z = datatype Kind.t
datatype z = datatype AdmitsEquality.t
-
+
+local
+ fun 'a make (prefix: string,
+ all: 'a list,
+ bits: 'a -> int,
+ default: 'a,
+ equalsA: 'a * 'a -> bool,
+ memo: ('a -> t) -> ('a -> t),
+ admitsEquality: AdmitsEquality.t) =
+ let
+ val all =
+ Vector.fromListMap
+ (all, fn s =>
+ (fromString (concat [prefix, Int.toString (bits s)]), s))
+ val fromSize =
+ memo
+ (fn s =>
+ case Vector.peek (all, fn (_, s') => equalsA (s, s')) of
+ NONE => Error.bug "missing size"
+ | SOME (tycon, _) => tycon)
+ fun is t = Vector.exists (all, fn (t', _) => equals (t, t'))
+ val prims =
+ Vector.toListMap (all, fn (tycon, _) =>
+ (tycon, Arity 0, admitsEquality))
+ in
+ (fromSize default, fromSize, all, is, prims)
+ end
+in
+ val (defaultInt, int, ints, isIntX, primInts) =
+ let
+ open IntSize
+ in
+ make ("int", all, bits, default, equals, memoize, Always)
+ end
+ val (defaultReal, real, reals, isRealX, primReals) =
+ let
+ open RealSize
+ in
+ make ("real", all, bits, default, equals, memoize, Never)
+ end
+ val (defaultWord, word, words, isWordX, primWords) =
+ let
+ open WordSize
+ in
+ make ("word", all, bits, default, equals, memoize, Always)
+ end
+end
+
+val isIntX = fn c => equals (c, intInf) orelse isIntX c
+
val prims =
[(array, Arity 1, Always),
(arrow, Arity 2, Never),
(bool, Arity 0, Always),
(char, Arity 0, Always),
(exn, Arity 0, Never),
- (int8, Arity 0, Always),
- (int16, Arity 0, Always),
- (int32, Arity 0, Always),
- (int64, Arity 0, Always),
(intInf, Arity 0, Always),
(list, Arity 1, Sometimes),
(pointer, Arity 0, Always),
(preThread, Arity 0, Never),
- (real32, Arity 0, Never),
- (real64, Arity 0, Never),
(reff, Arity 1, Always),
(thread, Arity 0, Never),
(tuple, Nary, Sometimes),
(vector, Arity 1, Sometimes),
- (weak, Arity 1, Never),
- (word8, Arity 0, Always),
- (word16, Arity 0, Always),
- (word32, Arity 0, Always),
- (word64, Arity 0, Always)]
-
-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
- | W64 => word64
-
-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, intInf]
- val isRealX = is [real32, real64]
- val isWordX = is [word8, word16, word32, word64]
-end
+ (weak, Arity 1, Never)]
+ @ primInts @ primReals @ primWords
fun layoutApp (c: t,
args: (Layout.t * {isChar: bool, needsParen: bool}) vector) =
1.10 +5 -3 mlton/mlton/ast/prim-tycons.sig
Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- prim-tycons.sig 16 Oct 2003 22:37:12 -0000 1.9
+++ prim-tycons.sig 3 Mar 2004 02:08:59 -0000 1.10
@@ -5,6 +5,8 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+type int = Int.t
+
signature PRIM_TYCONS_STRUCTS =
sig
structure AdmitsEquality: ADMITS_EQUALITY
@@ -39,7 +41,7 @@
val defaultWord: tycon
val exn: tycon
val int: IntSize.t -> tycon
- val ints: (tycon * IntSize.t) list
+ val ints: (tycon * IntSize.t) vector
val intInf: tycon
val isIntX: tycon -> bool
val isRealX: tycon -> bool
@@ -52,12 +54,12 @@
val preThread: tycon
val prims: (tycon * Kind.t * AdmitsEquality.t) list
val real: RealSize.t -> tycon
- val reals: (tycon * RealSize.t) list
+ val reals: (tycon * RealSize.t) vector
val reff: tycon
val thread: tycon
val tuple: tycon
val vector: tycon
val weak: tycon
val word: WordSize.t -> tycon
- val words: (tycon * WordSize.t) list
+ val words: (tycon * WordSize.t) vector
end
1.2 +6 -2 mlton/mlton/ast/real-size.fun
Index: real-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/real-size.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- real-size.fun 23 Jun 2003 04:58:55 -0000 1.1
+++ real-size.fun 3 Mar 2004 02:08:59 -0000 1.2
@@ -6,7 +6,7 @@
datatype t = R32 | R64
val all = [R32, R64]
-
+
val default = R64
val equals: t * t -> bool = op =
@@ -28,5 +28,9 @@
val bytes: t -> int =
fn R32 => 4
| R64 => 8
-
+
+val bits: t -> int =
+ fn R32 => 32
+ | R64 => 64
+
end
1.2 +1 -0 mlton/mlton/ast/real-size.sig
Index: real-size.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/real-size.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- real-size.sig 23 Jun 2003 04:58:55 -0000 1.1
+++ real-size.sig 3 Mar 2004 02:08:59 -0000 1.2
@@ -12,6 +12,7 @@
datatype t = R32 | R64
val all: t list
+ val bits: t -> int
val bytes: t -> int
val default: t
val equals: t * t -> bool
1.6 +8 -4 mlton/mlton/ast/word-size.fun
Index: word-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/word-size.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- word-size.fun 19 Feb 2004 22:42:08 -0000 1.5
+++ word-size.fun 3 Mar 2004 02:08:59 -0000 1.6
@@ -30,15 +30,19 @@
val allOnes = max
+val bits: t -> int =
+ fn W8 => 8
+ | W16 => 16
+ | W32 => 32
+ | W64 => 64
+
val bytes: t -> int =
fn W8 => 1
| W16 => 2
| W32 => 4
| W64 => 8
-fun size s = 8 * bytes s
-
-fun toString w = Int.toString (size w)
+val toString = Int.toString o bits
val memoize: (t -> 'a) -> t -> 'a =
fn f =>
@@ -54,6 +58,6 @@
| W64 => a64
end
-val cardinality = memoize (fn s => IntInf.pow (2, size s))
+val cardinality = memoize (fn s => IntInf.pow (2, bits s))
end
1.5 +1 -1 mlton/mlton/ast/word-size.sig
Index: word-size.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/word-size.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- word-size.sig 1 Dec 2003 18:22:18 -0000 1.4
+++ word-size.sig 3 Mar 2004 02:08:59 -0000 1.5
@@ -13,6 +13,7 @@
val all: t list
val allOnes: t -> LargeWord.t
+ val bits: t -> int
val bytes: t -> int
val cardinality: t -> IntInf.t
val default: t
@@ -20,6 +21,5 @@
val max: t -> LargeWord.t
val memoize: (t -> 'a) -> t -> 'a
val pointer: unit -> t
- val size: t -> int
val toString: t -> string
end
1.3 +2 -3 mlton/mlton/atoms/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- c-function.fun 19 Feb 2004 22:42:08 -0000 1.2
+++ c-function.fun 3 Mar 2004 02:08:59 -0000 1.3
@@ -82,11 +82,10 @@
local
open CType
in
- datatype z = datatype IntSize.t
datatype z = datatype WordSize.t
+ val Int32 = Int (IntSize.I 32)
+ val Word32 = Word W32
end
-val Int32 = Int I32
-val Word32 = Word W32
local
fun make b =
1.2 +2 -3 mlton/mlton/atoms/c-type.fun
Index: c-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- c-type.fun 19 Jul 2003 01:23:26 -0000 1.1
+++ c-type.fun 3 Mar 2004 02:08:59 -0000 1.2
@@ -3,7 +3,6 @@
open S
-datatype z = datatype IntSize.t
datatype z = datatype WordSize.t
datatype t =
@@ -12,7 +11,7 @@
| Real of RealSize.t
| Word of WordSize.t
-val bool = Int I32
+val bool = Int (IntSize.I 32)
val char = Word W8
val defaultInt = Int IntSize.default
val defaultReal = Real RealSize.default
@@ -20,7 +19,7 @@
val pointer = Pointer
val all =
- List.map (IntSize.all, Int)
+ List.map (IntSize.prims, Int)
@ [Pointer]
@ List.map (RealSize.all, Real)
@ List.map (WordSize.all, Word)
1.14 +0 -1 mlton/mlton/atoms/const.fun
Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- const.fun 19 Feb 2004 22:42:09 -0000 1.13
+++ const.fun 3 Mar 2004 02:08:59 -0000 1.14
@@ -21,7 +21,6 @@
structure WordSize = WordSize
end
-datatype z = datatype IntSize.t
datatype z = datatype WordSize.t
structure SmallIntInf =
1.5 +0 -2 mlton/mlton/atoms/int-x.fun
Index: int-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/int-x.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- int-x.fun 9 Oct 2003 18:17:31 -0000 1.4
+++ int-x.fun 3 Mar 2004 02:08:59 -0000 1.5
@@ -3,8 +3,6 @@
open S
-datatype z = datatype IntSize.t
-
datatype t = T of {int: IntInf.t,
size: IntSize.t}
1.70 +3 -4 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- prim.fun 19 Feb 2004 22:42:09 -0000 1.69
+++ prim.fun 3 Mar 2004 02:08:59 -0000 1.70
@@ -15,7 +15,6 @@
open S
-datatype z = datatype IntSize.t
datatype z = datatype RealSize.t
datatype z = datatype WordSize.t
@@ -740,7 +739,7 @@
s: WordSize.t) =
let
val x = f (WordX.toIntInf w, WordX.toIntInf w')
- val x' = x mod (Int.toIntInf (WordSize.size s))
+ val x' = x mod (Int.toIntInf (WordSize.bits s))
in
if x = x'
then word (WordX.fromLargeInt (x, s))
@@ -908,7 +907,7 @@
(WordX.mod
(w,
WordX.make
- (LargeWord.fromInt (WordSize.size s), s)))
+ (LargeWord.fromInt (WordSize.bits s), s)))
then Var x
else Unknown
end
@@ -922,7 +921,7 @@
then Var x
else if (WordX.>=
(w, WordX.make (LargeWord.fromInt
- (WordSize.size s),
+ (WordSize.bits s),
WordSize.default)))
then zero s
else Unknown
1.9 +1 -1 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- type-ops.fun 9 Oct 2003 18:17:31 -0000 1.8
+++ type-ops.fun 3 Mar 2004 02:08:59 -0000 1.9
@@ -17,7 +17,7 @@
structure RealSize = RealSize
structure WordSize = WordSize
end
-datatype intSize = datatype IntSize.t
+type intSize = IntSize.t
datatype realSize = datatype RealSize.t
type tycon = Tycon.t
datatype wordSize = datatype WordSize.t
1.4 +3 -3 mlton/mlton/atoms/word-x.fun
Index: word-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/word-x.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- word-x.fun 19 Feb 2004 22:42:09 -0000 1.3
+++ word-x.fun 3 Mar 2004 02:08:59 -0000 1.4
@@ -70,7 +70,7 @@
let
val {size = s, word = w} = dest w
val {word = w', ...} = dest w'
- val n = Word.fromInt (WordSize.size s)
+ val n = Word.fromInt (WordSize.bits s)
val w' = Word.mod (w', n)
in
make (Word.orb (Word.>> (w, Word.toWord (Word.- (n, w'))),
@@ -82,7 +82,7 @@
let
val {size = s, word = w} = dest w
val {word = w', ...} = dest w'
- val n = Word.fromInt (WordSize.size s)
+ val n = Word.fromInt (WordSize.bits s)
val w' = Word.mod (w', n)
in
make (Word.orb (Word.>> (w, Word.toWord w'),
@@ -147,7 +147,7 @@
local
fun wrap (f: Word.t * PWord.t -> Word.t) (w: t, w': t): t =
- if Word.> (word w', Word.fromInt (WordSize.size (size w)))
+ if Word.> (word w', Word.fromInt (WordSize.bits (size w)))
then zero (size w)
else make (f (word w, Word.toWord (word w')),
size w)
1.13 +0 -1 mlton/mlton/backend/machine-atoms.fun
Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- machine-atoms.fun 19 Feb 2004 22:42:09 -0000 1.12
+++ machine-atoms.fun 3 Mar 2004 02:09:01 -0000 1.13
@@ -9,7 +9,6 @@
struct
open S
-datatype z = datatype IntSize.t
datatype z = datatype WordSize.t
structure ProfileLabel = ProfileLabel ()
1.22 +13 -1 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- representation.fun 20 Feb 2004 02:11:13 -0000 1.21
+++ representation.fun 3 Mar 2004 02:09:01 -0000 1.22
@@ -540,7 +540,19 @@
case S.Type.dest t of
Array t => SOME (array {mutable = true, ty = t})
| Datatype tycon => convertDatatype tycon
- | Int s => SOME (R.Type.int s)
+ | Int s =>
+ let
+ val bits =
+ case IntSize.bits s of
+ 8 => 8
+ | 16 => 16
+ | 31 => 32
+ | 32 => 32
+ | 64 => 64
+ | _ => Error.bug "strange size int"
+ in
+ SOME (R.Type.int (IntSize.I bits))
+ end
| IntInf => SOME R.Type.intInf
| PreThread => SOME R.Type.thread
| Real s => SOME (R.Type.real s)
1.41 +3 -1 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- rssa.fun 20 Feb 2004 02:11:13 -0000 1.40
+++ rssa.fun 3 Mar 2004 02:09:01 -0000 1.41
@@ -648,7 +648,9 @@
fun handlesSignals p =
hasPrim (p, fn p =>
- Prim.name p = Prim.Name.MLton_installSignalHandler)
+ case Prim.name p of
+ Prim.Name.MLton_installSignalHandler => true
+ | _ => false)
fun layouts (T {functions, main, objectTypes, ...},
output': Layout.t -> unit): unit =
1.56 +42 -49 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.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- ssa-to-rssa.fun 19 Feb 2004 22:42:09 -0000 1.55
+++ ssa-to-rssa.fun 3 Mar 2004 02:09:01 -0000 1.56
@@ -23,7 +23,6 @@
structure GCField = GCField
end
-datatype z = datatype IntSize.t
datatype z = datatype WordSize.t
structure CFunction =
@@ -33,8 +32,8 @@
local
open CType
in
- val Int32 = Int I32
- val Int64 = Int I64
+ val Int32 = Int (IntSize.I 32)
+ val Int64 = Int (IntSize.I 64)
val Word32 = Word W32
val Word64 = Word W64
end
@@ -917,10 +916,11 @@
Option.map (toRtype (varType x), fn t =>
(x, t))
| NONE => NONE
- fun normal () =
+ fun primApp prim =
add (PrimApp {dst = dst (),
prim = prim,
args = varOps args})
+ fun normal () = primApp prim
datatype z = datatype Prim.Name.t
fun bumpCanHandle n =
let
@@ -1113,6 +1113,11 @@
then updateCard (addr, fn ss => ss, assign)
else loop (i - 1, assign::ss, t)
end
+ fun int (s, f) =
+ if IntSize.equals (s, IntSize.I 64)
+ andalso !Control.Native.native
+ then simpleCCall f
+ else normal ()
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
@@ -1171,57 +1176,45 @@
ccall {args = Vector.new1 Operand.GCState,
func = CFunction.unpack}
| Int_equal s =>
- if s = IntSize.I64 andalso !Control.Native.native
- then simpleCCall CFunction.int64Equal
- else normal ()
- | Int_ge s =>
- if s = IntSize.I64 andalso !Control.Native.native
- then simpleCCall (CFunction.intGe s)
- else normal ()
- | Int_gt s =>
- if s = IntSize.I64 andalso !Control.Native.native
- then simpleCCall (CFunction.intGt s)
- else normal ()
- | Int_le s =>
- if s = IntSize.I64 andalso !Control.Native.native
- then simpleCCall (CFunction.intLe s)
- else normal ()
- | Int_lt s =>
- if s = IntSize.I64 andalso !Control.Native.native
- then simpleCCall (CFunction.intLt s)
- else normal ()
- | Int_mul s =>
- if s = IntSize.I64 andalso !Control.Native.native
- then simpleCCall (CFunction.intMul s)
- else normal ()
- | Int_quot s =>
- if s = IntSize.I64
- orelse not (!Control.Native.native)
- then simpleCCall (CFunction.intQuot s)
- else normal ()
- | Int_rem s =>
- if s = IntSize.I64
- orelse not (!Control.Native.native)
- then simpleCCall (CFunction.intRem s)
- else normal ()
+ (case IntSize.bits s of
+ 31 => primApp (Prim.intEqual
+ (IntSize.I 32))
+ | 64 =>
+ if !Control.Native.native
+ then
+ simpleCCall CFunction.int64Equal
+ else normal ()
+ | _ => normal ())
+ | Int_ge s => int (s, CFunction.intGe s)
+ | Int_gt s => int (s, CFunction.intGt s)
+ | Int_le s => int (s, CFunction.intLe s)
+ | Int_lt s => int (s, CFunction.intLt s)
+ | Int_mul s => int (s, CFunction.intMul s)
+ | Int_quot s => int (s, CFunction.intQuot s)
+ | Int_rem s => int (s, CFunction.intRem s)
| Int_toInt (s1, s2) =>
let
- datatype z = datatype IntSize.t
+ fun call () =
+ if !Control.Native.native
+ then
+ simpleCCall
+ (CFunction.intToInt (s1, s2))
+ else normal ()
+ val id = cast
in
- if (case (s1, s2) of
- (I32, I64) => true
- | (I64, I32) => true
- | _ => false)
- andalso !Control.Native.native
- then simpleCCall (CFunction.intToInt (s1, s2))
- else normal ()
+ case (IntSize.bits s1, IntSize.bits s2) of
+ (32, 64) => call ()
+ | (64, 32) => call ()
+ | (31, 32) => id ()
+ | (32, 31) => id ()
+ | _ => normal ()
end
| Int_toWord (s1, s2) =>
let
- datatype z = datatype IntSize.t
+ datatype z = datatype IntSize.prim
datatype z = datatype WordSize.t
in
- if (case (s1, s2) of
+ if (case (IntSize.prim s1, s2) of
(I64, W32) => true
| _ => false)
andalso !Control.Native.native
@@ -1431,10 +1424,10 @@
else normal ()
| Word_toInt (s1, s2) =>
let
- datatype z = datatype IntSize.t
+ datatype z = datatype IntSize.prim
datatype z = datatype WordSize.t
in
- if (case (s1, s2) of
+ if (case (s1, IntSize.prim s2) of
(W32, I64) => true
| _ => false)
andalso !Control.Native.native
1.33 +3 -1 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.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- closure-convert.fun 20 Feb 2004 02:11:13 -0000 1.32
+++ closure-convert.fun 3 Mar 2004 02:09:02 -0000 1.33
@@ -596,7 +596,9 @@
val convertVarExp = convertVar o SvarExp.var
val handlesSignals =
Sexp.hasPrim (body, fn p =>
- Prim.name p = Prim.Name.MLton_installSignalHandler)
+ case Prim.name p of
+ Prim.Name.MLton_installSignalHandler => true
+ | _ => false)
(*------------------------------------*)
(* apply *)
(*------------------------------------*)
1.8 +8 -3 mlton/mlton/closure-convert/globalize.fun
Index: globalize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/globalize.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- globalize.fun 20 Feb 2004 02:11:14 -0000 1.7
+++ globalize.fun 3 Mar 2004 02:09:03 -0000 1.8
@@ -107,15 +107,20 @@
* because polymorphic equality isn't implemented
* there.
*)
- andalso Prim.name prim <> Prim.Name.MLton_equal)
+ andalso
+ (case Prim.name prim of
+ Prim.Name.MLton_equal => false
+ | _ => true))
orelse
(once andalso
(case Prim.name prim of
Prim.Name.Ref_ref => typeIsSmall ty
| _ => false)))
val once =
- once andalso
- Prim.name prim <> Prim.Name.Thread_copyCurrent
+ once andalso
+ (case Prim.name prim of
+ Prim.Name.Thread_copyCurrent => false
+ | _ => true)
in
(global, once)
end
1.73 +3 -3 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.72
retrieving revision 1.73
diff -u -r1.72 -r1.73
--- c-codegen.fun 19 Feb 2004 22:42:11 -0000 1.72
+++ c-codegen.fun 3 Mar 2004 02:09:03 -0000 1.73
@@ -42,7 +42,6 @@
structure WordX = WordX
end
-datatype z = datatype IntSize.t
datatype z = datatype RealSize.t
datatype z = datatype WordSize.t
@@ -85,8 +84,9 @@
else if IntX.isMin i
then min
else neg ()
+ datatype z = datatype IntSize.prim
in
- case size i of
+ case IntSize.prim (size i) of
I8 => simple "8"
| I16 => simple "16"
| I32 => tricky ("0x80000000")
@@ -411,7 +411,7 @@
case t of
EnumPointers {pointers, ...} =>
if 0 = Vector.length pointers
- then int I32
+ then int (IntSize.I 32)
else pointer
| ExnStack => word W32
| Int s => int s
1.27 +0 -2 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.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- x86-mlton-basic.fun 24 Feb 2004 02:28:04 -0000 1.26
+++ x86-mlton-basic.fun 3 Mar 2004 02:09:05 -0000 1.27
@@ -315,7 +315,6 @@
WordSize.memoize
(fn s => Label.fromString (concat ["localWord", WordSize.toString s]))
datatype z = datatype CType.t
- datatype z = datatype IntSize.t
in
fun local_base ty =
case ty of
@@ -336,7 +335,6 @@
val globalW_base =
make ("Word", WordSize.memoize, WordSize.toString)
datatype z = datatype CType.t
- datatype z = datatype IntSize.t
in
fun global_base ty =
case ty of
1.56 +23 -22 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.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- x86-mlton.fun 3 Mar 2004 01:33:16 -0000 1.55
+++ x86-mlton.fun 3 Mar 2004 02:09:05 -0000 1.56
@@ -15,8 +15,9 @@
open Machine
in
structure CFunction = CFunction
+ structure IntSize = IntSize
structure Prim = Prim
- datatype z = datatype IntSize.t
+ datatype z = datatype IntSize.prim
datatype z = datatype RealSize.t
datatype z = datatype WordSize.t
end
@@ -605,49 +606,49 @@
transfer = NONE}]
end
| Int_add s =>
- (case s of
+ (case IntSize.prim s of
I8 => binal Instruction.ADD
| I16 => binal Instruction.ADD
| I32 => binal Instruction.ADD
| I64 => binal64 (Instruction.ADD, Instruction.ADC))
| Int_equal s =>
- (case s of
+ (case IntSize.prim s of
I8 => cmp Instruction.E
| I16 => cmp Instruction.E
| I32 => cmp Instruction.E
| I64 => Error.bug "FIXME")
| Int_ge s =>
- (case s of
+ (case IntSize.prim s of
I8 => cmp Instruction.GE
| I16 => cmp Instruction.GE
| I32 => cmp Instruction.GE
| I64 => Error.bug "FIXME")
| Int_gt s =>
- (case s of
+ (case IntSize.prim s of
I8 => cmp Instruction.G
| I16 => cmp Instruction.G
| I32 => cmp Instruction.G
| I64 => Error.bug "FIXME")
| Int_le s =>
- (case s of
+ (case IntSize.prim s of
I8 => cmp Instruction.LE
| I16 => cmp Instruction.LE
| I32 => cmp Instruction.LE
| I64 => Error.bug "FIXME")
| Int_lt s =>
- (case s of
+ (case IntSize.prim s of
I8 => cmp Instruction.L
| I16 => cmp Instruction.L
| I32 => cmp Instruction.L
| I64 => Error.bug "FIXME")
| Int_mul s =>
- (case s of
+ (case IntSize.prim s of
I8 => pmd Instruction.IMUL
| I16 => imul2 ()
| I32 => imul2 ()
| I64 => Error.bug "FIXME")
| Int_neg s =>
- (case s of
+ (case IntSize.prim s of
I8 => unal Instruction.NEG
| I16 => unal Instruction.NEG
| I32 => unal Instruction.NEG
@@ -658,25 +659,25 @@
src = Operand.immediate_const_int 0,
size = dstsize}]))
| Int_quot s =>
- (case s of
+ (case IntSize.prim s of
I8 => pmd Instruction.IDIV
| I16 => pmd Instruction.IDIV
| I32 => pmd Instruction.IDIV
| I64 => Error.bug "FIXME")
| Int_rem s =>
- (case s of
+ (case IntSize.prim s of
I8 => pmd Instruction.IMOD
| I16 => pmd Instruction.IMOD
| I32 => pmd Instruction.IMOD
| I64 => Error.bug "FIXME")
| Int_sub s =>
- (case s of
+ (case IntSize.prim s of
I8 => binal Instruction.SUB
| I16 => binal Instruction.SUB
| I32 => binal Instruction.SUB
| I64 => binal64 (Instruction.SUB, Instruction.SBB))
| Int_toInt (s, s') =>
- (case (s, s') of
+ (case (IntSize.prim s, IntSize.prim s') of
(I64, I64) => Error.bug "FIXME"
| (I64, I32) => Error.bug "FIXME"
| (I64, I16) => Error.bug "FIXME"
@@ -736,7 +737,7 @@
transfer = NONE}]
end
in
- case (s, s') of
+ case (IntSize.prim s, s') of
(I64, R64) => Error.bug "FIXME"
| (I64, R32) => Error.bug "FIXME"
| (I32, R64) => default ()
@@ -747,7 +748,7 @@
| (I8, R32) => default' ()
end
| Int_toWord (s, s') =>
- (case (s, s') of
+ (case (IntSize.prim s, s') of
(I64, W64) => Error.bug "FIXME"
| (I64, W32) => Error.bug "FIXME"
| (I64, W16) => Error.bug "FIXME"
@@ -1245,7 +1246,7 @@
transfer = NONE}]
end
in
- case (s, s') of
+ case (s, IntSize.prim s') of
(R64, I64) => Error.bug "FIXME"
| (R64, I32) => default ()
| (R64, I16) => default ()
@@ -1455,7 +1456,7 @@
| W32 => binal Instruction.SUB
| W64 => binal64 (Instruction.SUB, Instruction.SBB))
| Word_toInt (s, s') =>
- (case (s, s') of
+ (case (s, IntSize.prim s') of
(W64, I64) => Error.bug "FIXME"
| (W64, I32) => Error.bug "FIXME"
| (W64, I16) => Error.bug "FIXME"
@@ -1473,7 +1474,7 @@
| (W8, I16) => movx Instruction.MOVZX
| (W8, I8) => mov ())
| Word_toIntX (s, s') =>
- (case (s, s') of
+ (case (s, IntSize.prim s') of
(W64, I64) => Error.bug "FIXME"
| (W64, I32) => Error.bug "FIXME"
| (W64, I16) => Error.bug "FIXME"
@@ -1883,25 +1884,25 @@
[comment_begin,
(case Prim.name prim of
Int_addCheck s =>
- (case s of
+ (case IntSize.prim s of
I8 => binal (x86.Instruction.ADD, x86.Instruction.O)
| I16 => binal (x86.Instruction.ADD, x86.Instruction.O)
| I32 => binal (x86.Instruction.ADD, x86.Instruction.O)
| I64 => binal64 (x86.Instruction.ADD, x86.Instruction.ADC, x86.Instruction.O))
| Int_subCheck s =>
- (case s of
+ (case IntSize.prim s of
I8 => binal (x86.Instruction.SUB, x86.Instruction.O)
| I16 => binal (x86.Instruction.SUB, x86.Instruction.O)
| I32 => binal (x86.Instruction.SUB, x86.Instruction.O)
| I64 => binal64 (x86.Instruction.SUB, x86.Instruction.SBB, x86.Instruction.O))
| Int_mulCheck s =>
- (case s of
+ (case IntSize.prim s of
I8 => pmd (x86.Instruction.IMUL, x86.Instruction.O)
| I16 => imul2 x86.Instruction.O
| I32 => imul2 x86.Instruction.O
| I64 => Error.bug "FIXME")
| Int_negCheck s =>
- (case s of
+ (case IntSize.prim s of
I8 => unal (x86.Instruction.NEG, x86.Instruction.O)
| I16 => unal (x86.Instruction.NEG, x86.Instruction.O)
| I32 => unal (x86.Instruction.NEG, x86.Instruction.O)
1.52 +5 -3 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.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- x86-translate.fun 24 Feb 2004 02:28:04 -0000 1.51
+++ x86-translate.fun 3 Mar 2004 02:09:06 -0000 1.52
@@ -32,7 +32,6 @@
structure WordX = WordX
end
- datatype z = datatype IntSize.t
datatype z = datatype RealSize.t
datatype z = datatype WordSize.t
@@ -169,8 +168,9 @@
| Int i =>
let
val i'' = fn () => x86.Operand.immediate_const_int (IntX.toInt i)
+ datatype z = datatype IntSize.prim
in
- case IntX.size i of
+ case IntSize.prim (IntX.size i) of
I8 => Vector.new1 (i'' (), x86.Size.BYTE)
| I16 => Vector.new1 (i'' (), x86.Size.WORD)
| I32 => Vector.new1 (i'' (), x86.Size.LONG)
@@ -864,7 +864,9 @@
end
| Int {cases, default, size, test} =>
(Assert.assert("x86Translate.Transfer.toX86Blocks: Switch/Int",
- fn () => size <> IntSize.I64)
+ fn () =>
+ not (IntSize.equals
+ (size, IntSize.I 64)))
; simple ({cases = (Vector.map
(cases, fn (i, l) =>
(IntX.toInt i, l))),
1.49 +20 -14 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- x86.fun 3 Mar 2004 01:33:16 -0000 1.48
+++ x86.fun 3 Mar 2004 02:09:06 -0000 1.49
@@ -141,12 +141,14 @@
fun fromCType t =
case t of
Int s =>
- let datatype z = datatype IntSize.t
- in case s of
- I8 => Vector.new1 BYTE
- | I16 => Vector.new1 WORD
- | I32 => Vector.new1 LONG
- | I64 => Vector.new2 (LONG, LONG)
+ let
+ datatype z = datatype IntSize.prim
+ in
+ case IntSize.prim s of
+ I8 => Vector.new1 BYTE
+ | I16 => Vector.new1 WORD
+ | I32 => Vector.new1 LONG
+ | I64 => Vector.new2 (LONG, LONG)
end
| Pointer => Vector.new1 LONG
| Real s =>
@@ -698,12 +700,14 @@
fun fromCType t =
case t of
Int s =>
- let datatype z = datatype IntSize.t
- in case s of
- I8 => One
- | I16 => Two
- | I32 => Four
- | I64 => Eight
+ let
+ datatype z = datatype IntSize.prim
+ in
+ case IntSize.prim s of
+ I8 => One
+ | I16 => Two
+ | I32 => Four
+ | I64 => Eight
end
| Pointer => Four
| Real s =>
@@ -1438,8 +1442,10 @@
in
fun cReturnTemps ty =
case ty of
- Int s => let datatype z = datatype IntSize.t
- in case s of
+ Int s => let
+ datatype z = datatype IntSize.prim
+ in
+ case IntSize.prim s of
I8 => [{src = register Register.al,
dst = cReturnTempContent (0, BYTE)}]
| I16 => [{src = register Register.ax,
1.8 +1 -1 mlton/mlton/match-compile/match-compile.fun
Index: match-compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/match-compile.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- match-compile.fun 19 Feb 2004 22:42:15 -0000 1.7
+++ match-compile.fun 3 Mar 2004 02:09:06 -0000 1.8
@@ -143,7 +143,7 @@
Vector.fromList infos))))))
in
val directCases =
- make (List.remove (IntSize.all, fn s => IntSize.I64 = s),
+ make (List.remove (IntSize.all, fn s => IntSize.equals (s, IntSize.I 64)),
IntSize.cardinality, Type.int, Cases.int,
fn Const.Int i => i
| _ => Error.bug "caseInt type error")
1.21 +6 -2 mlton/mlton/ssa/local-ref.fun
Index: local-ref.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/local-ref.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- local-ref.fun 18 Feb 2004 04:24:10 -0000 1.20
+++ local-ref.fun 3 Mar 2004 02:09:07 -0000 1.21
@@ -156,7 +156,9 @@
Option.app (var, fn var =>
case exp
of PrimApp {prim, ...}
- => if Prim.name prim = Prim.Name.Ref_ref
+ => if (case Prim.name prim of
+ Prim.Name.Ref_ref => true
+ | _ => false)
then setGlobalInfo(var, GlobalInfo.new true)
else ()
| _ => ()))
@@ -178,7 +180,9 @@
in
case exp
of PrimApp {prim, args, ...}
- => if Prim.name prim = Prim.Name.Ref_ref
+ => if (case Prim.name prim of
+ Prim.Name.Ref_ref => true
+ | _ => false)
then ignore
(FuncLattice.<=
(GlobalInfo.funcUses
1.8 +7 -2 mlton/mlton/ssa/multi.fun
Index: multi.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/multi.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- multi.fun 20 Feb 2004 02:11:15 -0000 1.7
+++ multi.fun 3 Mar 2004 02:09:08 -0000 1.8
@@ -134,7 +134,10 @@
fun multi (p as Program.T {functions, main, ...})
= let
val usesThreadsOrConts
- = Program.hasPrim (p, fn p => Prim.name p = Prim.Name.Thread_switchTo)
+ = Program.hasPrim (p, fn p =>
+ case Prim.name p of
+ Prim.Name.Thread_switchTo => true
+ | _ => false)
(* funcNode *)
val {get = funcNode: Func.t -> unit Node.t,
@@ -213,7 +216,9 @@
| Runtime {prim, ...}
=> if usesThreadsOrConts
andalso
- Prim.name prim = Prim.Name.Thread_copyCurrent
+ (case Prim.name prim of
+ Prim.Name.Thread_copyCurrent => true
+ | _ => false)
then (ThreadCopyCurrent.force
(LabelInfo.threadCopyCurrent li) ;
ThreadCopyCurrent.force
1.16 +17 -23 mlton/mlton/ssa/redundant-tests.fun
Index: redundant-tests.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant-tests.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- redundant-tests.fun 18 Feb 2004 04:24:21 -0000 1.15
+++ redundant-tests.fun 3 Mar 2004 02:09:08 -0000 1.16
@@ -151,31 +151,25 @@
val (falseVar, f) = make Con.falsee
end
local
- fun make s =
- let
- val one = Var.newNoname ()
- val oneS =
- Statement.T {exp = Exp.Const (Const.int (IntX.one s)),
- ty = Type.int s,
- var = SOME one}
- in
- (one,oneS)
- end
- datatype z = datatype IntX.IntSize.t
- val (one8, oneS8) = make I8
- val (one16, oneS16) = make I16
- val (one32, oneS32) = make I32
- val (one64, oneS64) = make I64
+ val statements = ref []
in
- fun one s =
- case s of
- I8 => one8
- | I16 => one16
- | I32 => one32
- | I64 => one64
- val oneSs = Vector.new4 (oneS8, oneS16, oneS32, oneS64)
+ val one =
+ IntSize.memoize
+ (fn s =>
+ let
+ val one = Var.newNoname ()
+ val () =
+ List.push
+ (statements,
+ Statement.T {exp = Exp.Const (Const.int (IntX.one s)),
+ ty = Type.int s,
+ var = SOME one})
+ in
+ one
+ end)
+ val ones = Vector.fromList (!statements)
end
- val globals = Vector.concat [Vector.new2 (t, f), oneSs, globals]
+ val globals = Vector.concat [Vector.new2 (t, f), ones, globals]
val shrink = shrinkFunction globals
val numSimplified = ref 0
fun simplifyFunction f =
1.65 +12 -13 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- ssa-tree.fun 20 Feb 2004 02:11:15 -0000 1.64
+++ ssa-tree.fun 3 Mar 2004 02:09:08 -0000 1.65
@@ -9,7 +9,6 @@
struct
open S
-datatype z = datatype IntSize.t
datatype z = datatype RealSize.t
datatype z = datatype WordSize.t
@@ -54,19 +53,16 @@
val tycons =
[(Tycon.array, unary Array)]
- @ List.map (Tycon.ints, fn (t, s) =>
- (t, nullary (Int s)))
+ @ Vector.toListMap (Tycon.ints, fn (t, s) => (t, nullary (Int s)))
@ [(Tycon.intInf, nullary IntInf),
(Tycon.preThread, nullary PreThread)]
- @ List.map (Tycon.reals, fn (t, s) =>
- (t, nullary (Real s)))
+ @ Vector.toListMap (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)))
+ @ Vector.toListMap (Tycon.words, fn (t, s) => (t, nullary (Word s)))
in
val _ = List.foreach (tycons, fn (tycon, f) => set (tycon, SOME f))
@@ -614,12 +610,15 @@
return: Label.t} (* Must be nullary. *)
fun iff (test: Var.t, {truee, falsee}) =
- Case
- {cases = Cases.Int (I32,
- Vector.new2 ((IntX.zero I32, falsee),
- (IntX.one I32, truee))),
- default = NONE,
- test = test}
+ let
+ val s = IntSize.I 32
+ in
+ Case
+ {cases = Cases.Int (s, Vector.new2 ((IntX.zero s, falsee),
+ (IntX.one s, truee))),
+ default = NONE,
+ test = test}
+ end
fun foreachFuncLabelVar (t, func, label: Label.t -> unit, var) =
let
1.14 +8 -6 mlton/mlton/xml/implement-exceptions.fun
Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- implement-exceptions.fun 18 Feb 2004 04:24:24 -0000 1.13
+++ implement-exceptions.fun 3 Mar 2004 02:09:08 -0000 1.14
@@ -54,7 +54,8 @@
let
val sumTycon = Tycon.newNoname ()
val sumType = Type.con (sumTycon, Vector.new0 ())
- fun find (name: Prim.Name.t): Var.t * Type.t * PrimExp.t =
+ fun find (nameString: string, isName: Prim.Name.t -> bool)
+ : Var.t * Type.t * PrimExp.t =
let
val var =
DynamicWind.withEscape
@@ -65,14 +66,13 @@
(body, fn (_, _, e) =>
case e of
PrimApp {args, prim, ...} =>
- if Prim.name prim = name
+ if isName (Prim.name prim)
then escape (VarExp.var
(Vector.sub (args, 0)))
else ()
| _ => ())
in
- Error.bug
- (concat ["can't find ", Prim.Name.toString name])
+ Error.bug (concat ["can't find it", nameString])
end)
val (ty, exp) =
DynamicWind.withEscape
@@ -90,10 +90,12 @@
(var, ty, exp)
end
val (initExtraVar, initExtraType, initExtraExp) =
- find Prim.Name.Exn_setInitExtra
+ find ("Exn_setInitExtra",
+ fn Prim.Name.Exn_setInitExtra => true | _ => false)
val extraType = initExtraType
val (extendExtraVar, extendExtraType, extendExtraExp) =
- find Prim.Name.Exn_setExtendExtra
+ find ("Exn_setExtendExtra",
+ fn Prim.Name.Exn_setExtendExtra => true | _ => false)
local
open Type
in
1.5 +1 -0 mlton/regression/fixed-integer.sml
Index: fixed-integer.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/fixed-integer.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- fixed-integer.sml 1 Aug 2003 14:55:56 -0000 1.4
+++ fixed-integer.sml 3 Mar 2004 02:09:08 -0000 1.5
@@ -212,5 +212,6 @@
structure S = Test (Int8)
structure S = Test (Int16)
+structure S = Test (Int31)
structure S = Test (Int32)
structure S = Test (Int64)